cgi.scm (55425B)
1 ; Copyright (c) 2026, Natacha Porté 2 ; 3 ; Permission to use, copy, modify, and distribute this software for any 4 ; purpose with or without fee is hereby granted, provided that the above 5 ; copyright notice and this permission notice appear in all copies. 6 ; 7 ; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 ; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 ; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 ; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 ; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 ; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 ; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 15 (import 16 (chicken file posix) 17 (chicken io) 18 (chicken process-context) 19 (chicken sort) 20 (chicken string) 21 (chicken time) 22 (chicken time posix) 23 comparse 24 openssl ; must be above http-client 25 http-client 26 lowdown 27 message-digest-byte-vector 28 rss 29 sha256-primitive 30 sql-de-lite 31 sxml-serializer) 32 33 (define sha-256 (sha256-primitive)) 34 (define css-style #<<END-OF-CSS 35 * { box-sizing: border-box; } 36 h1 { text-align: center; } 37 nav ul { display: flex; justify-content: space-evenly; align-items: center; list-style-type: none; margin: 2ex 0; padding: 0; } 38 pre { overflow: auto; } 39 .form-body { overflow: auto; } 40 .bad-post { background: #fcc; } 41 .marked-post { background: #ccf; } 42 .locked-post { background: #cff; } 43 .protected-post { background: #cfc; } 44 form { 45 position: relative; 46 margin: 1rex 0; 47 display: grid; 48 gap: 0.5rex; 49 transition: all 0.5s ease-in; 50 } 51 .sidenote { 52 position: absolute; 53 top: 1ex; right: 1ex; 54 margin: 0; 55 opacity: 0.6; 56 } 57 .lsub { width: 4.5rem; height: 3rem; } 58 .rsub { width: 4.5rem; height: 3rem; } 59 input[type=url],input[type=text] { display: block; width: 100%; } 60 textarea { display: block; max-width: 100%; } 61 .tag-list { column-width: 10rem; column-gap: 1rem; } 62 .tag-list label { display: block; } 63 span.ptime { font-size: 80%; } 64 span.section { font-size: 80%; } 65 a.section { font-size: 80%; } 66 span.title { font-weight: bold; display: block; } 67 span.taglist { font-weight: bold; font-size: 80%; } 68 span.hashid { font-size: 90%; opacity: 0.6; } 69 @media (min-width: 60rem) { 70 form { 71 grid-template-columns: 5rem 1fr 5rem; 72 align-items: center; 73 } 74 75 .form-body { grid-column: 2; } 76 .lsub { grid-column: 1; justify-self: start; } 77 .rsub { grid-column: 3; justify-self: end; } 78 } 79 @media (max-width: 59.9rem) { 80 form { 81 grid-template-columns: 1fr 1fr; 82 grid-template-areas: "c c" "l r"; 83 } 84 85 .form-body { grid-area: c; } 86 .lsub { grid-area: l; justify-self: start; } 87 .rsub { grid-area: r; justify-self: end; } 88 #load-new input, #load-new svg { grid-area: c; } 89 } 90 91 #load-new { text-align: center; grid-template-columns: auto; } 92 #load-new input { width: 4.5rem; height: 3rem; margin: auto; } 93 #load-new svg { width: 4.5rem; height: 3rem; margin: auto; fill: #494949; } 94 #load-new svg { display: none; } 95 #load-new.htmx-request svg { display: block; } 96 .htmx-request input { display: none; } 97 98 body { background: #F0ECE0; color: #000000; } 99 form { background: #FFFFFF; } 100 a:link { color: #007FBF; } 101 a:visited { color: #003F7F; } 102 a:hover { background: #007FBF; color: #F0E8E0; } 103 104 @media (prefers-color-scheme: dark) { 105 body { background: #103c48; color: #adbcbc; } 106 form { background: #184956; color: #cad8d9; } 107 a:link { color: #4695f7; } 108 a:visited { color: #af88eb; } 109 a:hover { background: #4695f7; color: #103c48; } 110 .bad-post { background: #783946; } 111 .marked-post { background: #1849a6; } 112 .locked-post { background: #189999; } 113 .protected-post { background: #189956; } 114 #load-new svg { fill: #cad8d9; } 115 } 116 END-OF-CSS 117 ) 118 119 (define content-length 120 (let ((ct (get-environment-variable "CONTENT_LENGTH"))) 121 (if ct (string->number ct) 0))) 122 (define input-text (read-string content-length)) 123 (define url-hdigit 124 (any-of (preceded-by (is #\0) (result 0)) 125 (preceded-by (is #\1) (result 1)) 126 (preceded-by (is #\2) (result 2)) 127 (preceded-by (is #\3) (result 3)) 128 (preceded-by (is #\4) (result 4)) 129 (preceded-by (is #\5) (result 5)) 130 (preceded-by (is #\6) (result 6)) 131 (preceded-by (is #\7) (result 7)) 132 (preceded-by (is #\8) (result 8)) 133 (preceded-by (is #\9) (result 9)) 134 (preceded-by (is #\a) (result 10)) 135 (preceded-by (is #\A) (result 10)) 136 (preceded-by (is #\b) (result 11)) 137 (preceded-by (is #\B) (result 11)) 138 (preceded-by (is #\c) (result 12)) 139 (preceded-by (is #\C) (result 12)) 140 (preceded-by (is #\d) (result 13)) 141 (preceded-by (is #\D) (result 13)) 142 (preceded-by (is #\e) (result 14)) 143 (preceded-by (is #\E) (result 14)) 144 (preceded-by (is #\f) (result 15)) 145 (preceded-by (is #\F) (result 15)))) 146 (define url-percent-escape 147 (sequence* ((_ (is #\%)) 148 (h url-hdigit) 149 (l url-hdigit)) 150 (result (integer->char (+ (* 16 h) l))))) 151 (define url-value-char 152 (any-of url-percent-escape 153 (preceded-by (is #\+) (result #\space)) 154 item)) 155 (define url-value 156 (as-string 157 (any-of (repeated url-value-char until: (is #\&)) 158 (repeated url-value-char)))) 159 (define url-key 160 (as-string (repeated item until: (is #\=)))) 161 (define url-kv-pair 162 (sequence* ((k url-key) 163 (_ (is #\=)) 164 (v url-value)) 165 (result (cons k (string-translate v "\r"))))) 166 (define url-kv-pairs 167 (sequence* ((h url-kv-pair) 168 (t (zero-or-more (preceded-by (is #\&) url-kv-pair)))) 169 (result (cons h t)))) 170 (define url-query 171 (any-of (preceded-by (is #\?) url-kv-pairs) 172 (result '()))) 173 (define url-extra-query 174 (any-of (preceded-by (is #\&) url-kv-pairs) 175 (result '()))) 176 (define input-list 177 (if (string=? input-text "") '() (parse url-kv-pairs input-text))) 178 (define (input-var name) 179 (alist-ref name input-list string=?)) 180 (define (optional-input-var name fallback) 181 (let ((val (input-var name))) 182 (if val val fallback))) 183 (define (required-input-var name) 184 (let ((val (input-var name))) 185 (if val val (bad-input (conc "missing " name))))) 186 187 (define-constant default-n 100) 188 (define (q-limit-offset q) 189 (let* ((ns (alist-ref "n" q string=?)) 190 (nn (if ns (string->number ns) #f)) 191 (n (if (and nn (positive? nn)) nn default-n)) 192 (ps (alist-ref "p" q string=?)) 193 (pn (if ps (string->number ps) #f)) 194 (p (if (and pn (positive? pn)) pn 1))) 195 (list (add1 n) (* n (sub1 p))))) 196 (define (np-limit-offset l o) 197 (let ((n (sub1 l))) 198 (cons n (add1 (quotient o n))))) 199 200 (define start-html 201 "Content-Type: text/html\r\n\r\n<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">") 202 203 (define (html-output form) 204 (write-string start-html) 205 (serialize-sxml form 206 method: 'html 207 output: (current-output-port))) 208 209 (define (htmx-output form) 210 (write-string "Content-Type: text/html\r\n\r\n") 211 (serialize-sxml form 212 method: 'html 213 output: (current-output-port))) 214 215 (define (debug-output) 216 (html-output 217 `(html 218 (head (title "Variable dump")) 219 (body (h1 "Variable dump") 220 (p "Current directory: " ,(current-directory)) 221 (table 222 ,@(map 223 (lambda (pair) 224 `(tr (td ,(car pair)) (td ,(cdr pair)))) 225 (get-environment-variables))) 226 (h2 "Inputs") 227 (pre (code ,input-text)) 228 (table 229 ,@(map 230 (lambda (p) `(tr (td ,(car p)) (td ,(car p)))) 231 input-list)))))) 232 233 (define (die msg) 234 (write-string "Status: 500\r\n") 235 (when msg 236 (write-string "Content-Type: text/plain\r\n\r\n") 237 (write-string msg)) 238 (exit 1)) 239 (define (bad-input msg) 240 (write-string "Status: 400\r\n") 241 (when msg 242 (write-string "Content-Type: text/plain\r\n\r\n") 243 (write-string msg)) 244 (exit 0)) 245 246 (define parse-number 247 (one-or-more (in #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))) 248 249 250 (define root (get-environment-variable "DOCUMENT_ROOT")) 251 (when (not root) 252 (die "Missing $DOCUMENT_ROOT")) 253 (define db-name (get-environment-variable "IENS_DB")) 254 (when (not db-name) 255 (die "Missing $IENS_DB")) 256 (define feed-root 257 (let ((raw (get-environment-variable "FEED_ROOT"))) 258 (cond 259 ((or (not raw) (zero? (string-length raw))) "") 260 ((eqv? #\/ (string-ref raw (sub1 (string-length raw)))) raw) 261 (else (string-append raw "/"))))) 262 263 (define db (open-database db-name)) 264 (exec (sql/transient db "PRAGMA foreign_keys = ON; 265 PRAGMA journal_mode = WAL; 266 PRAGMA synchronous = NORMAL; 267 PRAGMA busy_timeout = 5000;")) 268 (set-busy-handler! db (busy-timeout 10000)) 269 270 (include "common.scm") 271 272 (unless (= 8 (db-version)) 273 (die "Unexpectad database version")) 274 275 276 (define (clean-up) 277 (let* ((span (get-config "gruik-clean"))) 278 (when (number? span) 279 (exec 280 (sql db "DELETE FROM gruik 281 WHERE mark < 0 AND mtime < ?1 282 AND (lastseen IS NULL OR lastseen < ?1);") 283 (- (current-seconds) span))))) 284 285 (define (redirect location) 286 (write-string "Status: 302\r\nLocation: ") 287 (write-string (get-config/default "gruik-host" "")) 288 (write-string (get-config/default "gruik-prefix" "")) 289 (write-string location) 290 (write-string "\r\n\r\n")) 291 292 (define (auto-descr id) 293 (let ((row (query fetch-row 294 (sql db 295 (if (positive? id) 296 "SELECT section,url,comment_url FROM gruik 297 WHERE id=? AND COALESCE(description,'')='';" 298 "SELECT section,url,section_url FROM entry 299 WHERE protected=0 AND id=? 300 AND COALESCE(description,'')='';")) 301 (abs id)))) 302 (unless (null? row) 303 (let* ((section (car row)) 304 (url (cadr row)) 305 (dbcomm (caddr row)) 306 (comm (if (or (null? dbcomm) (string=? dbcomm "")) 307 (comment-link section url) 308 dbcomm))) 309 (if comm 310 (exec 311 (sql db 312 (if (positive? id) 313 "UPDATE gruik 314 SET description=?, 315 notes=trim(notes||char(10)||?,char(10)), 316 comment_url=? 317 WHERE id=? AND COALESCE(description,'')='';" 318 "UPDATE entry 319 SET description=?, 320 notes=trim(notes||char(10)||?,char(10)), 321 source_url=? 322 WHERE protected=0 AND id=? AND COALESCE(description,'')='';")) 323 (conc " + [](" url ")\n(via [" section "](" comm ") sur #gcufeed)") 324 comm 325 comm 326 (abs id)) 327 (exec 328 (sql db 329 (if (positive? id) 330 "UPDATE gruik SET description=? 331 WHERE id=? AND COALESCE(description,'')='';" 332 "UPDATE entry SET description=? 333 WHERE protected=0 AND id=? AND COALESCE(description,'')='';")) 334 (conc " + [](" url ")\n(via " section " sur #gcufeed)") 335 (abs id))))))) 336 337 (define (output-log-counts) 338 (let ((ne (query fetch-value 339 (sql db "SELECT COUNT(*) FROM entry WHERE protected=0;"))) 340 (ng (query fetch-value 341 (sql db "SELECT COUNT(*) FROM gruik WHERE mark>0;")))) 342 (write-line (conc (rfc-3339 (current-seconds)) "\t" ne "\t" ng)))) 343 (define (log-counts) 344 (let ((fname (get-environment-variable "NLOG"))) 345 (when fname 346 (with-output-to-file fname output-log-counts #:append #:text)))) 347 348 (define (spinner-bar x y height beg) 349 `(rect (@ (x ,x) (y ,y) (width 15) (height ,height) (rx 6)) 350 (animate (@ (attributeName height) (begin ,beg) (dur "1s") 351 (values "120;110;100;90;80;70;60;50;40;140;120") 352 (calcMode linear) (repeatCount indefinite))) 353 (animate (@ (attributeName y) (begin ,beg) (dur "1s") 354 (values "10;15;20;25;30;35;40;45;50;0;10") 355 (calcMode linear) (repeatCount indefinite))))) 356 (define (spinner-symbol) 357 `(svg (@ (style "display: none") (xmlns "http://www.w3.org/2000/svg")) 358 (symbol (@ (id "spinner") (viewBox "0 0 135 140")) 359 ,(spinner-bar 0 10 120 "0.5s") 360 ,(spinner-bar 30 10 120 "0.25s") 361 ,(spinner-bar 60 0 140 "0s") 362 ,(spinner-bar 90 10 120 "0.25s") 363 ,(spinner-bar 120 10 120 "0.5s")))) 364 (define (spinner-ref) 365 `(svg (@ (class spinner)) (use (@ (href "#spinner")) ""))) 366 367 (define (post-p-fragment id ptime mtime section title url comm-url tags) 368 `(p 369 (span (@ (class "ptime") (title ,(rfc-3339 mtime))) ,ptime) 370 ,(if (null? comm-url) 371 `(span (@ (class "section")) ,section) 372 `(a (@ (href ,comm-url) (class "section")) ,section)) 373 ,@(if (or (null? tags) (string=? tags "")) '() 374 `((span (@ (class "taglist")) ,tags))) 375 (span (@ (class "title")) ,title) 376 (a (@ (href ,url)) ,url) 377 (span (@ (class "hashid") (title ,id)) 378 "#" ,(substring (message-digest-string sha-256 url) 0 8)))) 379 380 (define (domain-counts url) 381 (and-let* ((i1 (substring-index "://" url)) 382 (i2 (substring-index "/" url (+ i1 3))) 383 (s (substring url i1 (add1 i2))) 384 (domain (substring url (+ i1 3) i2))) 385 (list domain 386 (query fetch-value 387 (sql db "SELECT COUNT(*) FROM entry WHERE instr(url,?)>0") s) 388 (query fetch-value 389 (sql db "SELECT COUNT(*) FROM gruik 390 WHERE mark>=0 AND instr(url,?)>0") s)))) 391 392 (define (edit-post-fragment id ptime mtime section title url comm-url mark notes description tags) 393 `(form (@ (method "POST") (action "do-edit") 394 (id ,(conc "post-" id)) (class "edit-post") 395 (hx-swap "outerHTML") (hx-post "xdo-edit")) 396 (input (@ (type "submit") (name "submit") (class lsub) (value "Edit"))) 397 (div (@ (class "form-body")) 398 ,(post-p-fragment id ptime mtime section title url comm-url tags) 399 ,@(let ((counts (domain-counts url))) 400 (if (and counts (positive? (+ (cadr counts) (caddr counts) -1))) 401 `((p "Entries and gruiks from " 402 (a (@ (href ,(conc "domains/" (car counts)))) 403 ,(car counts)) 404 ,(conc ": " (cadr counts) "+" (caddr counts)))) 405 '())) 406 (p (label "URL:" 407 (input (@ (type "url") (name "url") (value ,url))))) 408 ,(if (positive? id) 409 `(p ,(conc "Mark: " mark) 410 (label (input (@ (type radio) (name mark) (value 0))) "Unmark") 411 (label (input (@ (type radio) (name mark) (value 1) (checked))) 412 "Keep") 413 (label (input (@ (type radio) (name mark) (value 2))) "Lock") 414 (label (input (@ (type radio) (name mark) (value 3))) "Protect")) 415 `(p (label "Protected: " 416 (input (@ (type checkbox) (name protected) (value yes) 417 ,@(if (zero? mark) '() '((checked)))))))) 418 (pre (code ,notes)) 419 ,@(if (null? comm-url) 420 `((p (label (input (@ (type checkbox) (name retry-comm) (value y))) 421 "Retry fetching comment URL"))) 422 '()) 423 (p (label "Comment URL:" 424 (input (@ (type "url") (name "commenturl") (value ,comm-url))))) 425 (p (label "Append to notes:" 426 (textarea (@ (name "notes") (cols 80) (rows 5)) ""))) 427 (p (label "Description:" 428 (textarea (@ (name "description") (cols 80) (rows 12)) ,description))) 429 (fieldset (legend "Tags") 430 (details (@ (class tag-list)) (summary "Tags") 431 ,@(query 432 (map-rows* 433 (lambda (tid name checked) 434 `(label 435 (input (@ (type checkbox) (name tags) (value ,tid) 436 ,@(if (= 0 checked) '() '((checked))))) 437 ,name))) 438 (sql db 439 (if (positive? id) 440 "SELECT id,name, 441 EXISTS (SELECT * FROM gruik_tags 442 WHERE gruik_id=? AND tag_id = tag.id) 443 FROM tag;" 444 "SELECT id,name, 445 EXISTS (SELECT * FROM tagrel 446 WHERE url_id=? AND tag_id = tag.id) 447 FROM tag;")) 448 (abs id))))) 449 (input (@ (type "hidden") (name "id") (value ,id))) 450 (input (@ (type "submit") (name "submit") (class rsub) (value "Cancel"))))) 451 452 (define (edit-post-fragment* id) 453 (query 454 (map-rows* edit-post-fragment) 455 (sql db 456 (if (positive? id) 457 "SELECT gruik.id,ptime,mtime,section,title,url,comment_url,mark, 458 notes,description,group_concat('#'||name,' ') 459 FROM gruik LEFT OUTER JOIN gruik_tags ON gruik_id=gruik.id 460 LEFT OUTER JOIN tag ON tag_id=tag.id 461 WHERE gruik.id=? GROUP BY gruik.id;" 462 "SELECT -entry.id, 463 strftime('%Y.%m.%d %H:%M:%S', ctime, 'unixepoch') AS ptime, 464 mtime,COALESCE(source, 'Untracked Ien'), 465 COALESCE(title, ''), url, source_url, protected, 466 notes, description, group_concat('#'||name, ' ') 467 FROM entry LEFT OUTER JOIN tagrel ON url_id=entry.id 468 LEFT OUTER JOIN tag ON tag_id=tag.id 469 WHERE entry.id=? GROUP BY url_id;")) 470 (abs id))) 471 472 (define (db-edit) 473 (let ((id (string->number (required-input-var "id"))) 474 (comm-url (input-var "commenturl")) 475 (main-url (input-var "url")) 476 (retry-comm (input-var "retry-comm"))) 477 (when (string=? "Edit" (required-input-var "submit")) 478 (exec 479 (sql/transient db 480 (if (positive? id) 481 "UPDATE gruik SET mtime=?,notes=trim(notes||char(10)||?,char(10)), 482 description=?,mark=?,comment_url=?, 483 url=COALESCE(?,url) 484 WHERE (mark=1 OR mark=2) AND id=?;" 485 "UPDATE entry SET mtime=?,notes=trim(notes||char(10)||?,char(10)), 486 description=?,protected=?,source_url=?, 487 url=COALESCE(?,url) 488 WHERE protected=0 AND id=?;")) 489 (current-seconds) 490 (required-input-var "notes") 491 (if retry-comm "" (required-input-var "description")) 492 (if (positive? id) (string->number (required-input-var "mark")) 0) 493 (if (and comm-url (not (string=? comm-url ""))) comm-url '()) 494 (if (and main-url (not (string=? main-url ""))) main-url '()) 495 (abs id)) 496 (when retry-comm (auto-descr id)) 497 (let* ((n-tags (query fetch-value (sql db "SELECT MAX(id) FROM tag"))) 498 (tags (make-vector (+ 1 n-tags) 0)) 499 (add-tag (sql db 500 (if (positive? id) 501 "INSERT INTO gruik_tags(gruik_id,tag_id) 502 VALUES (?,?);" 503 "INSERT INTO tagrel(url_id,tag_id) 504 VALUES (?,?);"))) 505 (del-tag (sql db 506 (if (positive? id) 507 "DELETE FROM gruik_tags 508 WHERE gruik_id=? AND tag_id=?;" 509 "DELETE FROM tagrel 510 WHERE url_id=? AND tag_id=?;")))) 511 (let loop ((var input-list)) 512 (unless (null? var) 513 (when (string=? (caar var) "tags") 514 (vector-set! tags (string->number (cdar var)) 1)) 515 (loop (cdr var)))) 516 (query 517 (for-each-row* 518 (lambda (tid) (vector-set! tags tid (- (vector-ref tags tid) 1)))) 519 (sql db 520 (if (positive? id) 521 "SELECT tag_id FROM gruik_tags WHERE gruik_id=?;" 522 "SELECT tag_id FROM tagrel WHERE url_id=?;")) 523 (abs id)) 524 (let loop ((tid n-tags)) 525 (unless (= 0 tid) 526 (case (vector-ref tags tid) 527 ((1) (exec add-tag (abs id) tid)) 528 ((-1) (exec del-tag (abs id) tid))) 529 (loop (- tid 1)))))) 530 id)) 531 532 (define (post-fragment-id id) 533 (if (positive? id) (conc "post-" id) (conc "entry" id))) 534 535 (define (post-fragment id mark ptime mtime section title url comm-url tags . details) 536 (let* ((data (case mark 537 ((0) '("unmarked" "unmarked" "Mark" "Delete")) 538 ((1) '("marked" "marked" "Edit" "Unmark")) 539 ((2) '("locked" "locked" "Push" "Edit")) 540 ((3) '("locked" "protected" "Push" "Edit")) 541 ((10) '("ien" "locked" "Protect" "Edit")) 542 ((11) '("ien" "protected" #f "Unprotect")) 543 (else `("undelete" "bad" "Restore" ,(if (<= -5 mark 0) 544 "Hide" #f))))) 545 (action (car data)) 546 (class (cadr data)) 547 (llabel (caddr data)) 548 (rlabel (cadddr data))) 549 `(form (@ (method "POST") (action ,(conc "do-" action)) 550 (id ,(post-fragment-id id)) 551 (class ,(conc class "-post")) 552 (hx-swap "outerHTML") (hx-post ,(conc "xdo-" action))) 553 ,@(if (or llabel rlabel) 554 `((input (@ (type "hidden") (name "id") (value ,id)))) 555 '()) 556 ,@(if llabel 557 `((input (@ (type "submit") (name "submit") 558 (class lsub) (value ,llabel)))) 559 '()) 560 (div (@ (class "form-body")) 561 ,(post-p-fragment id ptime mtime section title url comm-url tags) 562 ,@(if (or (null? details) (string=? (car details) "")) 563 '() `((pre (code ,(car details)))))) 564 ,@(if rlabel 565 `(,@(if (<= -5 mark -1) 566 `((input (@ (type "hidden") (name "from") (value ,mark)))) 567 '()) 568 (input (@ (type "submit") (name "submit") 569 (class rsub) (value ,rlabel)))) 570 '())))) 571 572 (define (post-htmx id) 573 (htmx-output 574 (query 575 (map-rows* post-fragment) 576 (sql db 577 (if (positive? id) 578 "SELECT gruik.id,mark,ptime,mtime,section,title,url,comment_url, 579 group_concat('#'||name,' ') 580 FROM gruik LEFT OUTER JOIN gruik_tags ON gruik_id=gruik.id 581 LEFT OUTER JOIN tag ON tag_id=tag.id 582 WHERE gruik.id=? GROUP BY gruik.id;" 583 "SELECT -entry.id,(CASE WHEN protected=0 THEN 10 ELSE 11 END), 584 strftime('%Y.%m.%d %H:%M:%S',ctime,'unixepoch') AS ptime, 585 mtime,COALESCE(source,'Untracked Ien'), 586 COALESCE(title,''),url,source_url, 587 group_concat('#'||name,' ') 588 FROM entry LEFT OUTER JOIN tagrel ON url_id=entry.id 589 LEFT OUTER JOIN tag ON tag_id=tag.id 590 WHERE entry.id=? GROUP BY entry.id;")) 591 (abs id)))) 592 593 (define (gruik-list-items row->fragment q args) 594 (let ((items (apply query (map-rows* row->fragment) (sql db q) args)) 595 (np (if (or (null? args) (null? (cdr args))) 596 #f 597 (let loop ((a (car args)) (b (cadr args)) (rest (cddr args))) 598 (if (null? rest) 599 (np-limit-offset a b) 600 (loop b (car rest) (cdr rest))))))) 601 (if (and np (or (> (cdr np) 1) (> (length items) (car np)))) 602 (let* ((n-part (if (= (car np) default-n) "" (conc "n=" (car np) "&"))) 603 (p-btn (lambda (cl p) 604 `(button (@ (type "submit") (class ,cl) 605 (name "p") (value ,p)) 606 ,(conc "Page " p)))) 607 (nav `(form (@ (method "GET")) 608 ,@(if (> (cdr np) 1) 609 (list (p-btn "lsub" (sub1 (cdr np)))) 610 '()) 611 (div (@ (class "form-body")) 612 ,@(if (= (car np) default-n) 613 '() 614 `((input (@ (type "hidden") (name "n") 615 (value ,(car np)))))) 616 (p (@ (style "text-align: center")) 617 ,(conc "Page " (cdr np)))) 618 ,@(if (> (length items) (car np)) 619 (list (p-btn "rsub" (add1 (cdr np)))) 620 '())))) 621 (append (list nav) items (list nav))) 622 items))) 623 (define (gruik-list-view title row->fragment footer q . args) 624 (html-output 625 `(html 626 (head 627 (base (@ (href ,(conc (get-config/default "gruik-prefix" "") "/")))) 628 (meta (@ (charset "utf-8"))) 629 (meta (@ (name "viewport") 630 (content "width=device-width, initial-scale=1"))) 631 (meta (@ (name "color-scheme") (content "light dark"))) 632 (title ,title) 633 (script (@ (src "https://cdn.jsdelivr.net/npm/htmx.org@2.0.8/dist/htmx.min.js")) "") 634 (script "\ 635 const beforeUnloadHandler = (event) => { 636 if (document.getElementsByClassName(\"edit-post\").length > 0) { 637 event.preventDefault(); 638 event.returnValue=true; 639 } 640 }; 641 window.addEventListener(\"beforeunload\", beforeUnloadHandler); 642 ") 643 (style ,css-style)) 644 (body 645 ,(spinner-symbol) 646 (h1 ,title) 647 (nav (ul 648 (li (a (@ (href "./")) "Latest gruiks")) 649 (li (a (@ (href "deleted")) "Deleted gruiks")) 650 (li (a (@ (href "search")) "Search forms")) 651 (li (a (@ (href "no-comm")) "Sourceless gruiks")))) 652 ,@(gruik-list-items row->fragment q args) 653 ,@footer)))) 654 655 (define (new-fragment) 656 (clean-up) 657 (let* ((last-id (string->number (required-input-var "last-id"))) 658 (last-time (string->number (required-input-var "last-time"))) 659 (n-new 0) 660 (n-upd 0) 661 (n-del 0) 662 (frags (query 663 (map-rows* 664 (lambda (id mark ptime mtime section title url comm-url tags) 665 (let ((base (post-fragment id mark ptime mtime section 666 title url comm-url tags))) 667 (cond 668 ((> id last-id) 669 (set! n-new (add1 n-new)) 670 base) 671 ((>= mark -5) 672 (set! n-upd (add1 n-upd)) 673 `(form (@ (hx-swap-oob "true") ,@(cdadr base)) 674 ,@(cddr base))) 675 (else 676 (set! n-del (add1 n-del)) 677 `(form (@ (hx-swap-oob "delete") 678 (id ,(post-fragment-id id))) 679 "")))))) 680 (sql db "SELECT gruik.id,mark,ptime,mtime,section,title,url, 681 comment_url,group_concat('#'||name,' ') 682 FROM gruik LEFT OUTER JOIN gruik_tags 683 ON gruik_id=gruik.id 684 LEFT OUTER JOIN tag ON tag_id=tag.id 685 WHERE mtime > ? AND (gruik.id <= ? OR mark >= -5) 686 GROUP BY gruik.id;") 687 last-time last-id)) 688 (btn (if (null? frags) "Recheck" "More"))) 689 (htmx-output 690 `(,@frags 691 (form (@ (method GET) (action "new") (id "load-new") 692 (hx-swap "outerHTML") (hx-post "x-new")) 693 ,@(if (positive? (+ n-new n-upd n-del)) 694 `((p (@ (class sidenote)) 695 ,(if (positive? n-new) (conc "+" n-new) "") 696 ,(if (positive? n-upd) (conc "~" n-upd) "") 697 ,(if (positive? n-del) (conc "−" n-del) ""))) 698 '()) 699 ,(spinner-ref) 700 (input (@ (type "hidden") (name "last-time") 701 (value ,(current-seconds)))) 702 (input (@ (type "hidden") (name "last-id") (value 703 ,(query fetch-value (sql db "SELECT MAX(id) FROM gruik;"))))) 704 (input (@ (type "submit") (name "submit") (value ,btn)))) 705 )))) 706 707 (define (new-view) 708 (redirect "/")) 709 710 (define (deleted-view limit-offset) 711 (clean-up) 712 (gruik-list-view 713 "Deleted gruiks" 714 post-fragment 715 '() 716 "SELECT gruik.id,mark,ptime,mtime,section,title,url,comment_url, 717 group_concat('#'||name,' ') 718 FROM gruik LEFT OUTER JOIN gruik_tags ON gruik_id=gruik.id 719 LEFT OUTER JOIN tag ON tag_id=tag.id 720 WHERE mark < 0 GROUP BY gruik.id ORDER BY mtime DESC LIMIT ? OFFSET ?;" 721 (car limit-offset) 722 (cadr limit-offset))) 723 724 (define (edit-view id) 725 (let ((title (conc (if (positive? id) "Gruik #" "Ien #") (abs id)))) 726 (html-output 727 `(html 728 (head 729 (base (@ (href ,(conc (get-config/default "gruik-prefix" "") "/")))) 730 (meta (@ (charset "utf-8"))) 731 (meta (@ (name "viewport") 732 (content "width=device-width, initial-scale=1"))) 733 (meta (@ (name "color-scheme") (content "light dark"))) 734 (title ,title) 735 (script (@ (src "https://cdn.jsdelivr.net/npm/htmx.org@2.0.8/dist/htmx.min.js")) "") 736 (style ,css-style)) 737 (body 738 ,(spinner-symbol) 739 (h1 ,title) 740 ,@(edit-post-fragment* id)))))) 741 742 (define (feed-view id) 743 (let ((row (query fetch-row 744 (sql/transient db "SELECT mtime,title,url,selector 745 FROM feed WHERE id=?;") 746 id))) 747 (if (null? row) 748 (write-string "Status: 404\r\n\r\n") 749 (let ((mtime (car row)) 750 (title (cadr row)) 751 (self-url (caddr row)) 752 (selector (cadddr row))) 753 (write-string "Content-Type: application/atom+xml\r\n\r\n") 754 (write-feed mtime title self-url (feed-rows selector)))))) 755 756 (define (main-view) 757 (clean-up) 758 (gruik-list-view 759 "Latest gruiks" 760 post-fragment 761 `((form (@ (method GET) (action "new") (id "load-new") 762 (hx-swap "outerHTML") (hx-post "x-new")) 763 ,(spinner-ref) 764 (input (@ (type "hidden") (name "last-time") 765 (value ,(current-seconds)))) 766 (input (@ (type "hidden") (name "last-id") (value 767 ,(query fetch-value (sql db "SELECT MAX(id) FROM gruik;"))))) 768 (input (@ (type "submit") (name "submit") (value "Load"))))) 769 "SELECT gruik.id,mark,ptime,mtime,section,title,url,comment_url, 770 group_concat('#'||name,' ') 771 FROM gruik LEFT OUTER JOIN gruik_tags ON gruik_id=gruik.id 772 LEFT OUTER JOIN tag ON tag_id=tag.id 773 WHERE mark >= -5 GROUP BY gruik.id;")) 774 775 (define (view-domain-search q limit-offset) 776 (gruik-list-view 777 (conc "Domain " q) 778 post-fragment 779 '() 780 "SELECT gruik.id,mark,ptime,mtime,section,title,url,comment_url, 781 group_concat('#'||name,' '),COALESCE(description,notes) 782 FROM gruik LEFT OUTER JOIN gruik_tags ON gruik_id=gruik.id 783 LEFT OUTER JOIN tag ON tag_id=tag.id 784 WHERE instr(url,?1)>0 GROUP BY gruik.id 785 UNION ALL 786 SELECT -entry.id,(CASE WHEN protected=0 THEN 10 ELSE 11 END), 787 strftime('%Y.%m.%d %H:%M:%S',ctime,'unixepoch') AS ptime, 788 mtime,COALESCE(source,'Untracked Ien'), 789 COALESCE(title,''),url,source_url, 790 group_concat('#'||name,' '),COALESCE(description,notes) 791 FROM entry LEFT OUTER JOIN tagrel ON url_id=entry.id 792 LEFT OUTER JOIN tag ON tag_id=tag.id 793 WHERE instr(url,?1)>0 GROUP BY url_id 794 ORDER BY mtime DESC LIMIT ?2 OFFSET ?3" 795 (conc "://" q "/") 796 (car limit-offset) 797 (cadr limit-offset))) 798 799 (define (view-no-comm) 800 (clean-up) 801 (gruik-list-view 802 "Marked gruiks without comment URL" 803 post-fragment 804 '() 805 "SELECT gruik.id,mark,ptime,mtime,section,title,url,comment_url, 806 group_concat('#'||name,' ') 807 FROM gruik LEFT OUTER JOIN gruik_tags ON gruik_id=gruik.id 808 LEFT OUTER JOIN tag ON tag_id=tag.id 809 WHERE mark >= 1 AND COALESCE(comment_url,'') = '' GROUP BY gruik.id;")) 810 811 (define (view-search) 812 (html-output 813 `(html 814 (head 815 (base (@ (href ,(conc (get-config/default "gruik-prefix" "") "/")))) 816 (meta (@ (charset "utf-8"))) 817 (meta (@ (name "viewport") 818 (content "width=device-width, initial-scale=1"))) 819 (meta (@ (name "color-scheme") (content "light dark"))) 820 (title "Search Forms") 821 (style ,css-style)) 822 (body 823 (h1 "Search Forms") 824 (nav (ul 825 (li (a (@ (href "./")) "Latest gruiks")) 826 (li (a (@ (href "deleted")) "Deleted gruiks")) 827 (li (a (@ (href "search")) "Search forms")) 828 (li (a (@ (href "no-comm")) "Sourceless gruiks")))) 829 (h2 "Any Field") 830 (form (@ (method "GET") (action "search")) 831 (div (@ (class "form-body")) 832 (input (@ (type "text") (name "glob") (placeholder "*glob*"))))) 833 (form (@ (method "GET") (action "search")) 834 (div (@ (class "form-body")) 835 (input (@ (type "text") (name "like") (placeholder "%like%"))))) 836 (form (@ (method "GET") (action "search")) 837 (div (@ (class "form-body")) 838 (input (@ (type "text") (name "regexp") 839 (placeholder "^reg.*exp$"))))) 840 (h2 "Description") 841 (form (@ (method "GET") (action "description")) 842 (div (@ (class "form-body")) 843 (input (@ (type "text") (name "glob") (placeholder "*glob*"))))) 844 (form (@ (method "GET") (action "description")) 845 (div (@ (class "form-body")) 846 (input (@ (type "text") (name "like") (placeholder "%like%"))))) 847 (form (@ (method "GET") (action "description")) 848 (div (@ (class "form-body")) 849 (input (@ (type "text") (name "regexp") 850 (placeholder "^reg.*exp$"))))) 851 (h2 "Notes") 852 (form (@ (method "GET") (action "notes")) 853 (div (@ (class "form-body")) 854 (input (@ (type "text") (name "glob") (placeholder "*glob*"))))) 855 (form (@ (method "GET") (action "notes")) 856 (div (@ (class "form-body")) 857 (input (@ (type "text") (name "like") (placeholder "%like%"))))) 858 (form (@ (method "GET") (action "notes")) 859 (div (@ (class "form-body")) 860 (input (@ (type "text") (name "regexp") 861 (placeholder "^reg.*exp$"))))) 862 (h2 "Title") 863 (form (@ (method "GET") (action "title")) 864 (div (@ (class "form-body")) 865 (input (@ (type "text") (name "glob") (placeholder "*glob*"))))) 866 (form (@ (method "GET") (action "title")) 867 (div (@ (class "form-body")) 868 (input (@ (type "text") (name "like") (placeholder "%like%"))))) 869 (form (@ (method "GET") (action "title")) 870 (div (@ (class "form-body")) 871 (input (@ (type "text") (name "regexp") 872 (placeholder "^reg.*exp$"))))) 873 (h2 "URL") 874 (form (@ (method "GET") (action "url")) 875 (div (@ (class "form-body")) 876 (input (@ (type "text") (name "glob") (placeholder "*glob*"))))) 877 (form (@ (method "GET") (action "url")) 878 (div (@ (class "form-body")) 879 (input (@ (type "text") (name "like") (placeholder "%like%"))))) 880 (form (@ (method "GET") (action "url")) 881 (div (@ (class "form-body")) 882 (input (@ (type "text") (name "regexp") 883 (placeholder "^reg.*exp$"))))))))) 884 885 (define (view-search-field fi op q limit-offset) 886 (let ((title (if (string=? fi "any") 887 (conc "Gruiks " op " " q) 888 (conc "Gruiks with " fi " " op " " q))) 889 (where (if (string=? fi "any") 890 (conc "description " op " ?1 OR notes " op 891 " ?1 OR title " op " ?1 OR url " op " ?1") 892 (conc fi " " op " ?1")))) 893 (gruik-list-view 894 title 895 post-fragment 896 '() 897 (conc "SELECT gruik.id,mark,ptime,mtime,section,title,url,comment_url, 898 group_concat('#'||name,' '),COALESCE(description,notes) 899 FROM gruik LEFT OUTER JOIN gruik_tags ON gruik_id=gruik.id 900 LEFT OUTER JOIN tag ON tag_id=tag.id 901 WHERE " where " GROUP BY gruik.id 902 UNION ALL 903 SELECT -entry.id,(CASE WHEN protected=0 THEN 10 ELSE 11 END), 904 strftime('%Y-%m-%d %H:%M:%S',ctime,'unixepoch') AS ptime, 905 mtime,COALESCE(source,'Untracked Ien'), 906 COALESCE(title,''),url,source_url, 907 group_concat('#'||name,' '),COALESCE(description,notes) 908 FROM entry LEFT OUTER JOIN tagrel ON url_id=entry.id 909 LEFT OUTER JOIN tag ON tag_id=tag.id 910 WHERE " where " GROUP BY url_id 911 ORDER BY mtime DESC LIMIT ?2 OFFSET ?3;") 912 q 913 (car limit-offset) 914 (cadr limit-offset)))) 915 916 (define (view-selection id limit-offset) 917 (let ((row (query fetch-row 918 (sql/transient db "SELECT name,text 919 FROM selector WHERE id=?;") 920 id))) 921 (if (null? row) 922 (write-string "Status: 404\r\n\r\n") 923 (gruik-list-view 924 (conc "Selection #" id ": " (car row)) 925 post-fragment 926 '() 927 (conc 928 "SELECT -entry.id,(CASE WHEN protected=0 THEN 10 ELSE 11 END), 929 strftime('%Y.%m.%d %H:%M:%S',ctime,'unixepoch') AS ptime, 930 mtime,COALESCE(source,'Untracked Ien'), 931 COALESCE(title,''),url,source_url, 932 group_concat('#'||name,' '),COALESCE(description,notes) 933 FROM entry LEFT OUTER JOIN tagrel ON url_id=entry.id 934 LEFT OUTER JOIN tag ON tag_id=tag.id " 935 (cadr row) 936 " GROUP BY url_id ORDER BY mtime DESC LIMIT ? OFFSET ?") 937 (car limit-offset) 938 (cadr limit-offset))))) 939 940 (define (view-tag tag limit-offset) 941 (let ((row (query fetch-row 942 (sql/transient db "SELECT id,name 943 FROM tag WHERE name=?;") 944 tag))) 945 (if (null? row) 946 (write-string "Status: 404\r\n\r\n") 947 (gruik-list-view 948 (conc "Tag " (cadr row)) 949 post-fragment 950 '() 951 "SELECT gruik.id,mark,ptime,mtime,section,title,url,comment_url, 952 group_concat('#'||name,' '),COALESCE(description,notes) 953 FROM gruik LEFT OUTER JOIN gruik_tags ON gruik_id=gruik.id 954 LEFT OUTER JOIN tag ON tag_id=tag.id 955 WHERE gruik.id IN (SELECT gruik_id FROM gruik_tags WHERE tag_id=?1) 956 GROUP BY gruik.id 957 UNION ALL 958 SELECT -entry.id,(CASE WHEN protected=0 THEN 10 ELSE 11 END), 959 strftime('%Y.%m.%d %H:%M:%S',ctime,'unixepoch') AS ptime, 960 mtime,COALESCE(source,'Untracked Ien'), 961 COALESCE(title,''),url,source_url, 962 group_concat('#'||name,' '),COALESCE(description,notes) 963 FROM entry LEFT OUTER JOIN tagrel ON url_id=entry.id 964 LEFT OUTER JOIN tag ON tag_id=tag.id 965 WHERE entry.id IN (SELECT url_id FROM tagrel WHERE tag_id=?1) 966 GROUP BY url_id ORDER BY mtime DESC LIMIT ?2 OFFSET ?3" 967 (car row) 968 (car limit-offset) 969 (cadr limit-offset))))) 970 971 (define (db-push-gruik id) 972 (with-transaction db 973 (lambda () 974 (exec 975 (sql db "INSERT INTO entry(url,type,description,notes, 976 title,source,source_url, 977 ctime,mtime,ptime,protected) 978 SELECT url, 979 CASE WHEN description IS NULL THEN NULL 980 WHEN substr(description,1,1)='<' THEN 'html' 981 WHEN substr(description,1,3)=' - ' 982 OR substr(description,1,3)=' + ' 983 THEN 'markdown-li' 984 ELSE 'text' END, 985 trim(description,char(10))||char(10), 986 trim(notes,char(10))||char(10), 987 title,section,comment_url, 988 stime,?, 989 CASE WHEN mark>=3 THEN ? ELSE NULL END, 990 CASE WHEN mark>=3 THEN 1 ELSE 0 END 991 FROM gruik 992 WHERE id=?;") 993 (current-seconds) 994 (current-seconds) 995 id) 996 (exec 997 (sql db "INSERT OR IGNORE INTO tagrel(url_id,tag_id) 998 SELECT entry.id,tag_id 999 FROM gruik_tags LEFT OUTER JOIN gruik ON gruik_id=gruik.id 1000 LEFT OUTER JOIN entry ON gruik.url=entry.url 1001 WHERE gruik_id=?;") 1002 id) 1003 (db-set-mark id 2 -10) 1004 (db-set-mark id 3 -10))) 1005 (log-counts)) 1006 1007 (define (db-set-mark id old-v new-v) 1008 (exec (sql db "UPDATE gruik SET mtime=?, mark=?, stime=COALESCE(stime,?) 1009 WHERE mark=? AND id=?;") 1010 (current-seconds) 1011 new-v 1012 (if (= 1 new-v) (current-seconds) '()) 1013 old-v 1014 id)) 1015 1016 (define (db-set-protected id old-p new-p) 1017 (exec (sql db "UPDATE entry SET mtime=?, ptime=?, protected=? 1018 WHERE protected=? AND id=?;") 1019 (current-seconds) 1020 (if (zero? new-p) '() (current-seconds)) 1021 new-p 1022 old-p 1023 (- id))) 1024 1025 (define (db-sel-count id text name) 1026 (list id text name 1027 (query fetch-value 1028 (sql db (string-append "SELECT COUNT(id) FROM entry " text ";"))))) 1029 (define (db-sel-counts) 1030 (query (map-rows* db-sel-count) 1031 (sql db "SELECT id,text,name FROM selector ORDER BY id DESC;"))) 1032 (define (diff-sel-counts before after) 1033 (let loop ((rest-before before) (rest-after after) (acc '())) 1034 (cond 1035 ((and (null? rest-before) (null? rest-after)) acc) 1036 ((null? rest-before) 1037 (loop rest-before 1038 (cdr rest-after) 1039 (cons (list 0 (conc "extra after: " (cadar rest-after)) 0 0) 1040 acc))) 1041 ((null? rest-after) 1042 (loop (cdr rest-before) 1043 rest-after 1044 (cons (list 0 (conc "extra before: " (cadar rest-before)) 0 0) 1045 acc))) 1046 ((not (= (caar rest-before) (caar rest-after))) 1047 (loop (cdr rest-before) 1048 (cdr rest-after) 1049 (cons (list 0 1050 (conc "id mismatch: " 1051 (caar rest-before) " / " (caar rest-after)) 1052 0 0) 1053 acc))) 1054 ((not (string=? (cadar rest-before) (cadar rest-after))) 1055 (loop (cdr rest-before) 1056 (cdr rest-after) 1057 (cons (list 0 1058 (conc "text mismatch: " 1059 (cadar rest-before) " / " (cadar rest-after)) 1060 0 0) 1061 acc))) 1062 ((not (string=? (caddar rest-before) (caddar rest-after))) 1063 (loop (cdr rest-before) 1064 (cdr rest-after) 1065 (cons (list 0 1066 (conc "name mismatch: " 1067 (caddar rest-before) " / " (caddar rest-after)) 1068 0 0) 1069 acc))) 1070 (else 1071 (let ((n-before (car (cdddar rest-before))) 1072 (n-after (car (cdddar rest-after)))) 1073 (loop (cdr rest-before) 1074 (cdr rest-after) 1075 (if (= n-before n-after) 1076 acc 1077 (cons (list (caar rest-before) 1078 (cadar rest-before) 1079 (caddar rest-before) 1080 n-after 1081 (- n-after n-before)) 1082 acc)))))))) 1083 (define (fragment-diff-sel-counts before after) 1084 (let ((diff (diff-sel-counts before after))) 1085 (if (null? diff) '() 1086 `((table 1087 ,@(map (lambda (line) 1088 `(tr (td (a (@ (href ,(conc "selection/" (car line)))) 1089 ,(conc "Selection #" (car line)))) 1090 (td (@ (title ,(list-ref line 1))) ,(list-ref line 2)) 1091 (td ,(->string (list-ref line 3))) 1092 (td ,(conc (if (positive? (list-ref line 4)) "(+" "(") 1093 (list-ref line 4) ")")))) 1094 diff)))))) 1095 1096 (define (feed-sig-base) 1097 (query (map-rows (lambda (row) (append row (build-signature (caddr row))))) 1098 (sql db "SELECT id,title,selector FROM feed WHERE active=1;"))) 1099 (define (linked-ien n) 1100 `(a (@ (href ,(conc "ien/" n))) ,(conc "item #" n))) 1101 (define (fragment-sig-diff id title diff) 1102 `((p ,(conc "Feed #" id ": " title)) 1103 (ul ,@(map (lambda (hunk) (cond 1104 ((eqv? (car hunk) 'add) 1105 `(li "added " ,(linked-ien (cadr hunk)) 1106 ,(conc " at " (rfc-3339 (caddr hunk))))) 1107 ((eqv? (car hunk) 'del) 1108 `(li "removed " ,(linked-ien (cadr hunk)) 1109 ,(conc " at " (rfc-3339 (caddr hunk))))) 1110 ((eqv? (car hunk) 'chg) 1111 `(li "updated " ,(linked-ien (cadr hunk)) 1112 ,(conc " from " (rfc-3339 (caddr hunk)) 1113 " to " (rfc-3339 (cadddr hunk))))) 1114 (else `(li ,(conc "malformed hunk: " hunk))))) 1115 diff)))) 1116 (define (update-feed id) 1117 (exec (sql/transient db "UPDATE feed SET mtime=? WHERE id=?;") 1118 (current-seconds) 1119 id) 1120 (query (for-each-row* 1121 (lambda (filename mtime title self-url selector) 1122 (let ((rows (feed-rows selector))) 1123 (unless (null? rows) 1124 (with-output-to-file (string-append feed-root filename) 1125 (lambda () 1126 (write-feed 1127 (if (null? mtime) (list-ref (car rows) 7) mtime) 1128 title 1129 self-url 1130 rows))))))) 1131 (sql/transient db 1132 "SELECT filename,mtime,title,url,selector FROM feed WHERE id=?;") 1133 id)) 1134 (define (fragment-diff-feed* base-sig) 1135 (let ((id (car base-sig)) 1136 (title (cadr base-sig)) 1137 (selector (caddr base-sig)) 1138 (old-sig (cdddr base-sig))) 1139 (let ((diff (diff-signature old-sig (build-signature selector)))) 1140 (if (null? diff) 1141 '() 1142 (begin 1143 (update-feed id) 1144 (fragment-sig-diff id title diff)))))) 1145 (define (fragment-diff-feed base-sigs) 1146 (join (map fragment-diff-feed* base-sigs))) 1147 1148 (define (fragment-push-report frag-diff-sel frag-diff-sig) 1149 (if (and (null? frag-diff-sel) (null? frag-diff-sig)) 1150 '() 1151 `(form 1152 (div (@ (class "form-body")) ,@frag-diff-sel ,@frag-diff-sig) 1153 (button (@ (class rsub) (onclick "this.closest('form').remove()")) 1154 "Dismiss")))) 1155 1156 (define (htmx-push-gruik id) 1157 (let ((before (db-sel-counts)) 1158 (base-sigs (feed-sig-base))) 1159 (db-push-gruik id) 1160 (htmx-output 1161 (fragment-push-report 1162 (fragment-diff-sel-counts before (db-sel-counts)) 1163 (fragment-diff-feed base-sigs))))) 1164 1165 (define (xdo-edit) 1166 (let ((id (db-edit))) 1167 (post-htmx id))) 1168 1169 (define (do-ien htmx?) 1170 (let ((id (string->number (required-input-var "id"))) 1171 (submit (required-input-var "submit"))) 1172 (cond 1173 ((positive? id) (bad-input "bad value for id")) 1174 ((string=? submit "Edit") 1175 (if htmx? (htmx-output (edit-post-fragment* id)) 1176 (redirect (conc "/ien/" (- id))))) 1177 ((string=? submit "Protect") 1178 (db-set-protected id 0 1) 1179 (if htmx? (post-htmx id) 1180 (redirect (conc "/ien/" (- id))))) 1181 ((string=? submit "Unprotect") 1182 (db-set-protected id 1 0) 1183 (if htmx? (post-htmx id) 1184 (redirect (conc "/ien/" (- id))))) 1185 (else (bad-input "bad value for submit"))))) 1186 1187 (define (do-locked htmx?) 1188 (let ((id (string->number (required-input-var "id"))) 1189 (submit (required-input-var "submit"))) 1190 (cond 1191 ((string=? submit "Push") 1192 (if htmx? (htmx-push-gruik id) 1193 (begin (db-push-gruik id) (redirect "/")))) 1194 ((string=? submit "Edit") 1195 (if htmx? (htmx-output (edit-post-fragment* id)) 1196 (redirect (conc "/gruik/" id)))) 1197 (else (bad-input "bad value for submit"))))) 1198 1199 (define (do-marked htmx?) 1200 (let ((id (string->number (required-input-var "id"))) 1201 (submit (required-input-var "submit"))) 1202 (cond 1203 ((string=? submit "Edit") 1204 (if htmx? (htmx-output (edit-post-fragment* id)) 1205 (redirect (conc "/gruik/" id)))) 1206 ((string=? submit "Unmark") 1207 (db-set-mark id 1 0) 1208 (log-counts) 1209 (if htmx? (post-htmx id) (redirect "/"))) 1210 (else (bad-input "bad value for submit"))))) 1211 1212 (define (do-undelete htmx?) 1213 (let ((id (string->number (required-input-var "id"))) 1214 (oldmark (string->number (optional-input-var "from" ""))) 1215 (submit (required-input-var "submit"))) 1216 (cond 1217 ((and oldmark (<= -5 oldmark -1)) 1218 (cond 1219 ((string=? submit "Restore") 1220 (db-set-mark id oldmark 0) 1221 (if htmx? (post-htmx id) 1222 (redirect (conc "/gruik/" id)))) 1223 ((string=? submit "Hide") 1224 (db-set-mark id oldmark -10) 1225 (if htmx? (htmx-output '()) (redirect "/"))) 1226 (else (bad-input "bad value for submit")))) 1227 ((string=? submit "Restore") 1228 (db-set-mark id -10 0) 1229 (if htmx? (htmx-output '()) (redirect "/"))) 1230 (else (bad-input "bad value for submit"))))) 1231 1232 (define (do-unmarked htmx?) 1233 (let ((id (string->number (required-input-var "id"))) 1234 (submit (required-input-var "submit"))) 1235 (cond 1236 ((string=? submit "Mark") 1237 (db-set-mark id 0 1) 1238 (log-counts) 1239 (auto-descr id) 1240 (if htmx? (post-htmx id) (redirect "/"))) 1241 ((string=? submit "Delete") 1242 (db-set-mark id 0 -10) 1243 (if htmx? (htmx-output '()) (redirect "/"))) 1244 (else (bad-input "bad value for submit"))))) 1245 1246 (define route-xdo-edit 1247 (preceded-by (any-of (char-seq "xdo-edit") 1248 (char-seq "gruik/xdo-edit") 1249 (char-seq "ien/xdo-edit")) 1250 (result xdo-edit))) 1251 (define route-do-ien 1252 (sequence* ((x? (maybe (is #\x))) 1253 (_ (char-seq "do-ien"))) 1254 (result (lambda () (do-ien x?))))) 1255 (define route-do-locked 1256 (sequence* ((x? (maybe (is #\x))) 1257 (_ (char-seq "do-locked"))) 1258 (result (lambda () (do-locked x?))))) 1259 (define route-do-marked 1260 (sequence* ((x? (maybe (is #\x))) 1261 (_ (char-seq "do-marked"))) 1262 (result (lambda () (do-marked x?))))) 1263 (define route-do-undelete 1264 (sequence* ((x? (maybe (is #\x))) 1265 (_ (char-seq "do-undelete"))) 1266 (result (lambda () (do-undelete x?))))) 1267 (define route-do-unmarked 1268 (sequence* ((x? (maybe (is #\x))) 1269 (_ (char-seq "do-unmarked"))) 1270 (result (lambda () (do-unmarked x?))))) 1271 (define route-deleted 1272 (sequence* ((_ (char-seq "deleted")) 1273 (lo url-query)) 1274 (result (lambda () (deleted-view (q-limit-offset lo)))))) 1275 (define route-feed 1276 (sequence* ((_ (char-seq "feed/")) 1277 (id (as-string parse-number)) 1278 (_ (char-seq ".atom"))) 1279 (result (lambda () (feed-view (string->number id)))))) 1280 (define route-new 1281 (preceded-by (char-seq "new") 1282 (result new-view))) 1283 (define route-x-new 1284 (preceded-by (char-seq "x-new") 1285 (result new-fragment))) 1286 (define route-no-comm 1287 (preceded-by (char-seq "no-comm") 1288 (result view-no-comm))) 1289 (define route-search 1290 (preceded-by (char-seq "search") 1291 (result view-search))) 1292 (define route-search-any-field 1293 (sequence* ((_ (char-seq "search?")) 1294 (op (any-of (char-seq "glob") 1295 (char-seq "like") 1296 (char-seq "regexp"))) 1297 (_ (is #\=)) 1298 (q url-value) 1299 (lo url-extra-query)) 1300 (result (lambda () (view-search-field "any" op q (q-limit-offset lo)))))) 1301 (define route-search-domain 1302 (sequence* ((_ (char-seq "domains/")) 1303 (q (as-string (repeated item))) 1304 (lo url-query)) 1305 (result (lambda () (view-domain-search q (q-limit-offset lo)))))) 1306 (define route-search-field 1307 (sequence* ((fi (any-of (char-seq "description") 1308 (char-seq "notes") 1309 (char-seq "title") 1310 (char-seq "url"))) 1311 (_ (is #\?)) 1312 (op (any-of (char-seq "glob") 1313 (char-seq "like") 1314 (char-seq "regexp"))) 1315 (_ (is #\=)) 1316 (q url-value) 1317 (lo url-extra-query)) 1318 (result (lambda () (view-search-field fi op q (q-limit-offset lo)))))) 1319 (define route-selection 1320 (sequence* ((_ (char-seq "selection/")) 1321 (id (as-string parse-number)) 1322 (lo url-query)) 1323 (result (lambda () (view-selection (string->number id) 1324 (q-limit-offset lo)))))) 1325 (define route-tag 1326 (sequence* ((_ (char-seq "tag/")) 1327 (tag (as-string (repeated item until: (is #\?)))) 1328 (q url-query)) 1329 (result (lambda () (view-tag tag (q-limit-offset q)))))) 1330 (define route-edit-gruik 1331 (sequence* ((_ (char-seq "gruik/")) 1332 (id (as-string parse-number))) 1333 (result (lambda () (edit-view (string->number id)))))) 1334 (define route-edit-ien 1335 (sequence* ((_ (char-seq "ien/")) 1336 (id (as-string parse-number))) 1337 (result (lambda () (edit-view (- (string->number id))))))) 1338 (define route-main (result main-view)) 1339 (define route-ok 1340 (preceded-by (char-seq "ok") 1341 (result (lambda () 1342 (write-string "Content-Type: text/plain\r\n\r\nOK\n"))))) 1343 1344 (define router 1345 (preceded-by (char-seq (get-config/default "gruik-prefix" "")) 1346 (is #\/) 1347 (apply any-of 1348 (map (lambda (p) (followed-by p end-of-input)) 1349 (list route-do-ien 1350 route-do-locked 1351 route-do-marked 1352 route-do-undelete 1353 route-do-unmarked 1354 route-xdo-edit 1355 route-deleted 1356 route-edit-gruik 1357 route-edit-ien 1358 route-feed 1359 route-main 1360 route-ok 1361 route-new 1362 route-no-comm 1363 route-search 1364 route-search-any-field 1365 route-search-domain 1366 route-search-field 1367 route-selection 1368 route-tag 1369 route-x-new))))) 1370 1371 (let* ((uri (get-environment-variable "REQUEST_URI")) 1372 (_ (if uri uri (die "Missing $REQUEST_URI"))) 1373 (fn (parse router uri))) 1374 (if fn 1375 (fn) 1376 (debug-output)))