cgi.scm (54099B)
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 "Description") 830 (form (@ (method "GET") (action "description")) 831 (div (@ (class "form-body")) 832 (input (@ (type "text") (name "glob") (placeholder "*glob*"))))) 833 (form (@ (method "GET") (action "description")) 834 (div (@ (class "form-body")) 835 (input (@ (type "text") (name "like") (placeholder "%like%"))))) 836 (form (@ (method "GET") (action "description")) 837 (div (@ (class "form-body")) 838 (input (@ (type "text") (name "regexp") 839 (placeholder "^reg.*exp$"))))) 840 (h2 "Notes") 841 (form (@ (method "GET") (action "notes")) 842 (div (@ (class "form-body")) 843 (input (@ (type "text") (name "glob") (placeholder "*glob*"))))) 844 (form (@ (method "GET") (action "notes")) 845 (div (@ (class "form-body")) 846 (input (@ (type "text") (name "like") (placeholder "%like%"))))) 847 (form (@ (method "GET") (action "notes")) 848 (div (@ (class "form-body")) 849 (input (@ (type "text") (name "regexp") 850 (placeholder "^reg.*exp$"))))) 851 (h2 "Title") 852 (form (@ (method "GET") (action "title")) 853 (div (@ (class "form-body")) 854 (input (@ (type "text") (name "glob") (placeholder "*glob*"))))) 855 (form (@ (method "GET") (action "title")) 856 (div (@ (class "form-body")) 857 (input (@ (type "text") (name "like") (placeholder "%like%"))))) 858 (form (@ (method "GET") (action "title")) 859 (div (@ (class "form-body")) 860 (input (@ (type "text") (name "regexp") 861 (placeholder "^reg.*exp$"))))) 862 (h2 "URL") 863 (form (@ (method "GET") (action "url")) 864 (div (@ (class "form-body")) 865 (input (@ (type "text") (name "glob") (placeholder "*glob*"))))) 866 (form (@ (method "GET") (action "url")) 867 (div (@ (class "form-body")) 868 (input (@ (type "text") (name "like") (placeholder "%like%"))))) 869 (form (@ (method "GET") (action "url")) 870 (div (@ (class "form-body")) 871 (input (@ (type "text") (name "regexp") 872 (placeholder "^reg.*exp$"))))))))) 873 874 (define (view-search-field fi op q limit-offset) 875 (gruik-list-view 876 (conc "Gruiks with " fi " " op " " q) 877 post-fragment 878 '() 879 (conc "SELECT gruik.id,mark,ptime,mtime,section,title,url,comment_url, 880 group_concat('#'||name,' '),COALESCE(description,notes) 881 FROM gruik LEFT OUTER JOIN gruik_tags ON gruik_id=gruik.id 882 LEFT OUTER JOIN tag ON tag_id=tag.id 883 WHERE " fi " " op " ?1 GROUP BY gruik.id 884 UNION ALL 885 SELECT -entry.id,(CASE WHEN protected=0 THEN 10 ELSE 11 END), 886 strftime('%Y-%m-%d %H:%M:%S',ctime,'unixepoch') AS ptime, 887 mtime,COALESCE(source,'Untracked Ien'), 888 COALESCE(title,''),url,source_url, 889 group_concat('#'||name,' '),COALESCE(description,notes) 890 FROM entry LEFT OUTER JOIN tagrel ON url_id=entry.id 891 LEFT OUTER JOIN tag ON tag_id=tag.id 892 WHERE " fi " " op " ?1 GROUP BY url_id 893 ORDER BY mtime DESC LIMIT ?2 OFFSET ?3;") 894 q 895 (car limit-offset) 896 (cadr limit-offset))) 897 898 (define (view-selection id limit-offset) 899 (let ((row (query fetch-row 900 (sql/transient db "SELECT name,text 901 FROM selector WHERE id=?;") 902 id))) 903 (if (null? row) 904 (write-string "Status: 404\r\n\r\n") 905 (gruik-list-view 906 (conc "Selection #" id ": " (car row)) 907 post-fragment 908 '() 909 (conc 910 "SELECT -entry.id,(CASE WHEN protected=0 THEN 10 ELSE 11 END), 911 strftime('%Y.%m.%d %H:%M:%S',ctime,'unixepoch') AS ptime, 912 mtime,COALESCE(source,'Untracked Ien'), 913 COALESCE(title,''),url,source_url, 914 group_concat('#'||name,' '),COALESCE(description,notes) 915 FROM entry LEFT OUTER JOIN tagrel ON url_id=entry.id 916 LEFT OUTER JOIN tag ON tag_id=tag.id " 917 (cadr row) 918 " GROUP BY url_id ORDER BY mtime DESC LIMIT ? OFFSET ?") 919 (car limit-offset) 920 (cadr limit-offset))))) 921 922 (define (view-tag tag limit-offset) 923 (let ((row (query fetch-row 924 (sql/transient db "SELECT id,name 925 FROM tag WHERE name=?;") 926 tag))) 927 (if (null? row) 928 (write-string "Status: 404\r\n\r\n") 929 (gruik-list-view 930 (conc "Tag " (cadr row)) 931 post-fragment 932 '() 933 "SELECT gruik.id,mark,ptime,mtime,section,title,url,comment_url, 934 group_concat('#'||name,' '),COALESCE(description,notes) 935 FROM gruik LEFT OUTER JOIN gruik_tags ON gruik_id=gruik.id 936 LEFT OUTER JOIN tag ON tag_id=tag.id 937 WHERE gruik.id IN (SELECT gruik_id FROM gruik_tags WHERE tag_id=?1) 938 GROUP BY gruik.id 939 UNION ALL 940 SELECT -entry.id,(CASE WHEN protected=0 THEN 10 ELSE 11 END), 941 strftime('%Y.%m.%d %H:%M:%S',ctime,'unixepoch') AS ptime, 942 mtime,COALESCE(source,'Untracked Ien'), 943 COALESCE(title,''),url,source_url, 944 group_concat('#'||name,' '),COALESCE(description,notes) 945 FROM entry LEFT OUTER JOIN tagrel ON url_id=entry.id 946 LEFT OUTER JOIN tag ON tag_id=tag.id 947 WHERE entry.id IN (SELECT url_id FROM tagrel WHERE tag_id=?1) 948 GROUP BY url_id ORDER BY mtime DESC LIMIT ?2 OFFSET ?3" 949 (car row) 950 (car limit-offset) 951 (cadr limit-offset))))) 952 953 (define (db-push-gruik id) 954 (with-transaction db 955 (lambda () 956 (exec 957 (sql db "INSERT INTO entry(url,type,description,notes, 958 title,source,source_url, 959 ctime,mtime,ptime,protected) 960 SELECT url, 961 CASE WHEN description IS NULL THEN NULL 962 WHEN substr(description,1,1)='<' THEN 'html' 963 WHEN substr(description,1,3)=' - ' 964 OR substr(description,1,3)=' + ' 965 THEN 'markdown-li' 966 ELSE 'text' END, 967 trim(description,char(10))||char(10), 968 trim(notes,char(10))||char(10), 969 title,section,comment_url, 970 stime,?, 971 CASE WHEN mark>=3 THEN ? ELSE NULL END, 972 CASE WHEN mark>=3 THEN 1 ELSE 0 END 973 FROM gruik 974 WHERE id=?;") 975 (current-seconds) 976 (current-seconds) 977 id) 978 (exec 979 (sql db "INSERT OR IGNORE INTO tagrel(url_id,tag_id) 980 SELECT entry.id,tag_id 981 FROM gruik_tags LEFT OUTER JOIN gruik ON gruik_id=gruik.id 982 LEFT OUTER JOIN entry ON gruik.url=entry.url 983 WHERE gruik_id=?;") 984 id) 985 (db-set-mark id 2 -10) 986 (db-set-mark id 3 -10))) 987 (log-counts)) 988 989 (define (db-set-mark id old-v new-v) 990 (exec (sql db "UPDATE gruik SET mtime=?, mark=?, stime=COALESCE(stime,?) 991 WHERE mark=? AND id=?;") 992 (current-seconds) 993 new-v 994 (if (= 1 new-v) (current-seconds) '()) 995 old-v 996 id)) 997 998 (define (db-set-protected id old-p new-p) 999 (exec (sql db "UPDATE entry SET mtime=?, ptime=?, protected=? 1000 WHERE protected=? AND id=?;") 1001 (current-seconds) 1002 (if (zero? new-p) '() (current-seconds)) 1003 new-p 1004 old-p 1005 (- id))) 1006 1007 (define (db-sel-count id text name) 1008 (list id text name 1009 (query fetch-value 1010 (sql db (string-append "SELECT COUNT(id) FROM entry " text ";"))))) 1011 (define (db-sel-counts) 1012 (query (map-rows* db-sel-count) 1013 (sql db "SELECT id,text,name FROM selector ORDER BY id DESC;"))) 1014 (define (diff-sel-counts before after) 1015 (let loop ((rest-before before) (rest-after after) (acc '())) 1016 (cond 1017 ((and (null? rest-before) (null? rest-after)) acc) 1018 ((null? rest-before) 1019 (loop rest-before 1020 (cdr rest-after) 1021 (cons (list 0 (conc "extra after: " (cadar rest-after)) 0 0) 1022 acc))) 1023 ((null? rest-after) 1024 (loop (cdr rest-before) 1025 rest-after 1026 (cons (list 0 (conc "extra before: " (cadar rest-before)) 0 0) 1027 acc))) 1028 ((not (= (caar rest-before) (caar rest-after))) 1029 (loop (cdr rest-before) 1030 (cdr rest-after) 1031 (cons (list 0 1032 (conc "id mismatch: " 1033 (caar rest-before) " / " (caar rest-after)) 1034 0 0) 1035 acc))) 1036 ((not (string=? (cadar rest-before) (cadar rest-after))) 1037 (loop (cdr rest-before) 1038 (cdr rest-after) 1039 (cons (list 0 1040 (conc "text mismatch: " 1041 (cadar rest-before) " / " (cadar rest-after)) 1042 0 0) 1043 acc))) 1044 ((not (string=? (caddar rest-before) (caddar rest-after))) 1045 (loop (cdr rest-before) 1046 (cdr rest-after) 1047 (cons (list 0 1048 (conc "name mismatch: " 1049 (caddar rest-before) " / " (caddar rest-after)) 1050 0 0) 1051 acc))) 1052 (else 1053 (let ((n-before (car (cdddar rest-before))) 1054 (n-after (car (cdddar rest-after)))) 1055 (loop (cdr rest-before) 1056 (cdr rest-after) 1057 (if (= n-before n-after) 1058 acc 1059 (cons (list (caar rest-before) 1060 (cadar rest-before) 1061 (caddar rest-before) 1062 n-after 1063 (- n-after n-before)) 1064 acc)))))))) 1065 (define (fragment-diff-sel-counts before after) 1066 (let ((diff (diff-sel-counts before after))) 1067 (if (null? diff) '() 1068 `((table 1069 ,@(map (lambda (line) 1070 `(tr (td (a (@ (href ,(conc "selection/" (car line)))) 1071 ,(conc "Selection #" (car line)))) 1072 (td (@ (title ,(list-ref line 1))) ,(list-ref line 2)) 1073 (td ,(->string (list-ref line 3))) 1074 (td ,(conc (if (positive? (list-ref line 4)) "(+" "(") 1075 (list-ref line 4) ")")))) 1076 diff)))))) 1077 1078 (define (feed-sig-base) 1079 (query (map-rows (lambda (row) (append row (build-signature (caddr row))))) 1080 (sql db "SELECT id,title,selector FROM feed WHERE active=1;"))) 1081 (define (linked-ien n) 1082 `(a (@ (href ,(conc "ien/" n))) ,(conc "item #" n))) 1083 (define (fragment-sig-diff id title diff) 1084 `((p ,(conc "Feed #" id ": " title)) 1085 (ul ,@(map (lambda (hunk) (cond 1086 ((eqv? (car hunk) 'add) 1087 `(li "added " ,(linked-ien (cadr hunk)) 1088 ,(conc " at " (rfc-3339 (caddr hunk))))) 1089 ((eqv? (car hunk) 'del) 1090 `(li "removed " ,(linked-ien (cadr hunk)) 1091 ,(conc " at " (rfc-3339 (caddr hunk))))) 1092 ((eqv? (car hunk) 'chg) 1093 `(li "updated " ,(linked-ien (cadr hunk)) 1094 ,(conc " from " (rfc-3339 (caddr hunk)) 1095 " to " (rfc-3339 (cadddr hunk))))) 1096 (else `(li ,(conc "malformed hunk: " hunk))))) 1097 diff)))) 1098 (define (update-feed id) 1099 (exec (sql/transient db "UPDATE feed SET mtime=? WHERE id=?;") 1100 (current-seconds) 1101 id) 1102 (query (for-each-row* 1103 (lambda (filename mtime title self-url selector) 1104 (let ((rows (feed-rows selector))) 1105 (unless (null? rows) 1106 (with-output-to-file (string-append feed-root filename) 1107 (lambda () 1108 (write-feed 1109 (if (null? mtime) (list-ref (car rows) 7) mtime) 1110 title 1111 self-url 1112 rows))))))) 1113 (sql/transient db 1114 "SELECT filename,mtime,title,url,selector FROM feed WHERE id=?;") 1115 id)) 1116 (define (fragment-diff-feed* base-sig) 1117 (let ((id (car base-sig)) 1118 (title (cadr base-sig)) 1119 (selector (caddr base-sig)) 1120 (old-sig (cdddr base-sig))) 1121 (let ((diff (diff-signature old-sig (build-signature selector)))) 1122 (if (null? diff) 1123 '() 1124 (begin 1125 (update-feed id) 1126 (fragment-sig-diff id title diff)))))) 1127 (define (fragment-diff-feed base-sigs) 1128 (join (map fragment-diff-feed* base-sigs))) 1129 1130 (define (fragment-push-report frag-diff-sel frag-diff-sig) 1131 (if (and (null? frag-diff-sel) (null? frag-diff-sig)) 1132 '() 1133 `(form 1134 (div (@ (class "form-body")) ,@frag-diff-sel ,@frag-diff-sig) 1135 (button (@ (class rsub) (onclick "this.closest('form').remove()")) 1136 "Dismiss")))) 1137 1138 (define (htmx-push-gruik id) 1139 (let ((before (db-sel-counts)) 1140 (base-sigs (feed-sig-base))) 1141 (db-push-gruik id) 1142 (htmx-output 1143 (fragment-push-report 1144 (fragment-diff-sel-counts before (db-sel-counts)) 1145 (fragment-diff-feed base-sigs))))) 1146 1147 (define (xdo-edit) 1148 (let ((id (db-edit))) 1149 (post-htmx id))) 1150 1151 (define (do-ien htmx?) 1152 (let ((id (string->number (required-input-var "id"))) 1153 (submit (required-input-var "submit"))) 1154 (cond 1155 ((positive? id) (bad-input "bad value for id")) 1156 ((string=? submit "Edit") 1157 (if htmx? (htmx-output (edit-post-fragment* id)) 1158 (redirect (conc "/ien/" (- id))))) 1159 ((string=? submit "Protect") 1160 (db-set-protected id 0 1) 1161 (if htmx? (post-htmx id) 1162 (redirect (conc "/ien/" (- id))))) 1163 ((string=? submit "Unprotect") 1164 (db-set-protected id 1 0) 1165 (if htmx? (post-htmx id) 1166 (redirect (conc "/ien/" (- id))))) 1167 (else (bad-input "bad value for submit"))))) 1168 1169 (define (do-locked htmx?) 1170 (let ((id (string->number (required-input-var "id"))) 1171 (submit (required-input-var "submit"))) 1172 (cond 1173 ((string=? submit "Push") 1174 (if htmx? (htmx-push-gruik id) 1175 (begin (db-push-gruik id) (redirect "/")))) 1176 ((string=? submit "Edit") 1177 (if htmx? (htmx-output (edit-post-fragment* id)) 1178 (redirect (conc "/gruik/" id)))) 1179 (else (bad-input "bad value for submit"))))) 1180 1181 (define (do-marked htmx?) 1182 (let ((id (string->number (required-input-var "id"))) 1183 (submit (required-input-var "submit"))) 1184 (cond 1185 ((string=? submit "Edit") 1186 (if htmx? (htmx-output (edit-post-fragment* id)) 1187 (redirect (conc "/gruik/" id)))) 1188 ((string=? submit "Unmark") 1189 (db-set-mark id 1 0) 1190 (log-counts) 1191 (if htmx? (post-htmx id) (redirect "/"))) 1192 (else (bad-input "bad value for submit"))))) 1193 1194 (define (do-undelete htmx?) 1195 (let ((id (string->number (required-input-var "id"))) 1196 (oldmark (string->number (optional-input-var "from" ""))) 1197 (submit (required-input-var "submit"))) 1198 (cond 1199 ((and oldmark (<= -5 oldmark -1)) 1200 (cond 1201 ((string=? submit "Restore") 1202 (db-set-mark id oldmark 0) 1203 (if htmx? (post-htmx id) 1204 (redirect (conc "/gruik/" id)))) 1205 ((string=? submit "Hide") 1206 (db-set-mark id oldmark -10) 1207 (if htmx? (htmx-output '()) (redirect "/"))) 1208 (else (bad-input "bad value for submit")))) 1209 ((string=? submit "Restore") 1210 (db-set-mark id -10 0) 1211 (if htmx? (htmx-output '()) (redirect "/"))) 1212 (else (bad-input "bad value for submit"))))) 1213 1214 (define (do-unmarked htmx?) 1215 (let ((id (string->number (required-input-var "id"))) 1216 (submit (required-input-var "submit"))) 1217 (cond 1218 ((string=? submit "Mark") 1219 (db-set-mark id 0 1) 1220 (log-counts) 1221 (auto-descr id) 1222 (if htmx? (post-htmx id) (redirect "/"))) 1223 ((string=? submit "Delete") 1224 (db-set-mark id 0 -10) 1225 (if htmx? (htmx-output '()) (redirect "/"))) 1226 (else (bad-input "bad value for submit"))))) 1227 1228 (define route-xdo-edit 1229 (preceded-by (any-of (char-seq "xdo-edit") 1230 (char-seq "gruik/xdo-edit") 1231 (char-seq "ien/xdo-edit")) 1232 (result xdo-edit))) 1233 (define route-do-ien 1234 (sequence* ((x? (maybe (is #\x))) 1235 (_ (char-seq "do-ien"))) 1236 (result (lambda () (do-ien x?))))) 1237 (define route-do-locked 1238 (sequence* ((x? (maybe (is #\x))) 1239 (_ (char-seq "do-locked"))) 1240 (result (lambda () (do-locked x?))))) 1241 (define route-do-marked 1242 (sequence* ((x? (maybe (is #\x))) 1243 (_ (char-seq "do-marked"))) 1244 (result (lambda () (do-marked x?))))) 1245 (define route-do-undelete 1246 (sequence* ((x? (maybe (is #\x))) 1247 (_ (char-seq "do-undelete"))) 1248 (result (lambda () (do-undelete x?))))) 1249 (define route-do-unmarked 1250 (sequence* ((x? (maybe (is #\x))) 1251 (_ (char-seq "do-unmarked"))) 1252 (result (lambda () (do-unmarked x?))))) 1253 (define route-deleted 1254 (sequence* ((_ (char-seq "deleted")) 1255 (lo url-query)) 1256 (result (lambda () (deleted-view (q-limit-offset lo)))))) 1257 (define route-feed 1258 (sequence* ((_ (char-seq "feed/")) 1259 (id (as-string parse-number)) 1260 (_ (char-seq ".atom"))) 1261 (result (lambda () (feed-view (string->number id)))))) 1262 (define route-new 1263 (preceded-by (char-seq "new") 1264 (result new-view))) 1265 (define route-x-new 1266 (preceded-by (char-seq "x-new") 1267 (result new-fragment))) 1268 (define route-no-comm 1269 (preceded-by (char-seq "no-comm") 1270 (result view-no-comm))) 1271 (define route-search 1272 (preceded-by (char-seq "search") 1273 (result view-search))) 1274 (define route-search-domain 1275 (sequence* ((_ (char-seq "domains/")) 1276 (q (as-string (repeated item))) 1277 (lo url-query)) 1278 (result (lambda () (view-domain-search q (q-limit-offset lo)))))) 1279 (define route-search-field 1280 (sequence* ((fi (any-of (char-seq "description") 1281 (char-seq "notes") 1282 (char-seq "title") 1283 (char-seq "url"))) 1284 (_ (is #\?)) 1285 (op (any-of (char-seq "glob") 1286 (char-seq "like") 1287 (char-seq "regexp"))) 1288 (_ (is #\=)) 1289 (q url-value) 1290 (lo url-extra-query)) 1291 (result (lambda () (view-search-field fi op q (q-limit-offset lo)))))) 1292 (define route-selection 1293 (sequence* ((_ (char-seq "selection/")) 1294 (id (as-string parse-number)) 1295 (lo url-query)) 1296 (result (lambda () (view-selection (string->number id) 1297 (q-limit-offset lo)))))) 1298 (define route-tag 1299 (sequence* ((_ (char-seq "tag/")) 1300 (tag (as-string (repeated item until: (is #\?)))) 1301 (q url-query)) 1302 (result (lambda () (view-tag tag (q-limit-offset q)))))) 1303 (define route-edit-gruik 1304 (sequence* ((_ (char-seq "gruik/")) 1305 (id (as-string parse-number))) 1306 (result (lambda () (edit-view (string->number id)))))) 1307 (define route-edit-ien 1308 (sequence* ((_ (char-seq "ien/")) 1309 (id (as-string parse-number))) 1310 (result (lambda () (edit-view (- (string->number id))))))) 1311 (define route-main (result main-view)) 1312 (define route-ok 1313 (preceded-by (char-seq "ok") 1314 (result (lambda () 1315 (write-string "Content-Type: text/plain\r\n\r\nOK\n"))))) 1316 1317 (define router 1318 (preceded-by (char-seq (get-config/default "gruik-prefix" "")) 1319 (is #\/) 1320 (apply any-of 1321 (map (lambda (p) (followed-by p end-of-input)) 1322 (list route-do-ien 1323 route-do-locked 1324 route-do-marked 1325 route-do-undelete 1326 route-do-unmarked 1327 route-xdo-edit 1328 route-deleted 1329 route-edit-gruik 1330 route-edit-ien 1331 route-feed 1332 route-main 1333 route-ok 1334 route-new 1335 route-no-comm 1336 route-search 1337 route-search-domain 1338 route-search-field 1339 route-selection 1340 route-tag 1341 route-x-new))))) 1342 1343 (let* ((uri (get-environment-variable "REQUEST_URI")) 1344 (_ (if uri uri (die "Missing $REQUEST_URI"))) 1345 (fn (parse router uri))) 1346 (if fn 1347 (fn) 1348 (debug-output)))