cgi.scm (27283B)
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 string) 20 (chicken time) 21 comparse 22 openssl ; must be above http-client 23 http-client 24 rss 25 sql-de-lite 26 sxml-serializer) 27 28 (define css-style #<<END-OF-CSS 29 h1 { text-align: center; } 30 pre { overflow: scroll; } 31 .form-body { overflow: scroll; } 32 .bad-post { background: #fcc; } 33 .marked-post { background: #ccf; } 34 .locked-post { background: #cfc; } 35 form { 36 margin: 1rex 0; 37 display: grid; 38 gap: 0.5rex; 39 transition: all 0.5s ease-in; 40 } 41 .lsub { width: 4.5rem; height: 3rem; } 42 .rsub { width: 4.5rem; height: 3rem; } 43 textarea { display: block; max-width: 100%; } 44 .tag-list { column-width: 10rem; column-gap: 1rem; } 45 .tag-list label { display: block; } 46 span.ptime { font-size: 80%; } 47 span.section { font-size: 80%; } 48 span.title { font-weight: bold; display: block; } 49 @media (min-width: 60rem) { 50 form { 51 grid-template-columns: 5rem 1fr 5rem; 52 align-items: center; 53 } 54 55 .form-body { grid-column: 2; } 56 .lsub { grid-column: 1; justify-self: start; } 57 .rsub { grid-column: 3; justify-self: end; } 58 } 59 @media (max-width: 59.9rem) { 60 form { 61 grid-template-columns: 1fr 1fr; 62 grid-template-areas: \"c c\" \"l r\"; 63 } 64 65 .form-body { grid-area: c; } 66 .lsub { grid-area: l; justify-self: start; } 67 .rsub { grid-area: r; justify-self: end; } 68 #load-new input, #load-new svg { grid-area: c; } 69 } 70 71 #load-new { text-align: center; grid-template-columns: auto; } 72 #load-new input { width: 4.5rem; height: 3rem; margin: auto; } 73 #load-new svg { width: 4.5rem; height: 3rem; margin: auto; fill: #494949; } 74 #load-new svg { display: none; } 75 #load-new.htmx-request svg { display: block; } 76 .htmx-request input { display: none; } 77 78 body { background: #F0ECE0; color: #000000; } 79 form { background: #FFFFFF; } 80 a:link { color: #007FBF; } 81 a:visited { color: #003F7F; } 82 a:hover { background: #007FBF; color: #F0E8E0; } 83 84 @media (prefers-color-scheme: dark) { 85 body { background: #103c48; color: #adbcbc; } 86 form { background: #184956; color: #cad8d9; } 87 a:link { color: #4695f7; } 88 a:visited { color: #af88eb; } 89 a:hover { background: #4695f7; color: #103c48; } 90 .bad-post { background: #783946; } 91 .marked-post { background: #1849a6; } 92 .locked-post { background: #189956; } 93 #load-new svg { fill: #cad8d9; } 94 } 95 END-OF-CSS 96 ) 97 98 (define content-length 99 (let ((ct (get-environment-variable "CONTENT_LENGTH"))) 100 (if ct (string->number ct) 0))) 101 (define input-text (read-string content-length)) 102 (define input-list 103 (let* ((hdigit* (any-of (preceded-by (is #\0) (result 0)) 104 (preceded-by (is #\1) (result 1)) 105 (preceded-by (is #\2) (result 2)) 106 (preceded-by (is #\3) (result 3)) 107 (preceded-by (is #\4) (result 4)) 108 (preceded-by (is #\5) (result 5)) 109 (preceded-by (is #\6) (result 6)) 110 (preceded-by (is #\7) (result 7)) 111 (preceded-by (is #\8) (result 8)) 112 (preceded-by (is #\9) (result 9)) 113 (preceded-by (is #\a) (result 10)) 114 (preceded-by (is #\A) (result 10)) 115 (preceded-by (is #\b) (result 11)) 116 (preceded-by (is #\B) (result 11)) 117 (preceded-by (is #\c) (result 12)) 118 (preceded-by (is #\C) (result 12)) 119 (preceded-by (is #\d) (result 13)) 120 (preceded-by (is #\D) (result 13)) 121 (preceded-by (is #\e) (result 14)) 122 (preceded-by (is #\E) (result 14)) 123 (preceded-by (is #\f) (result 15)) 124 (preceded-by (is #\F) (result 15)))) 125 (pct* (sequence* ((_ (is #\%)) 126 (h hdigit*) 127 (l hdigit*)) 128 (result (integer->char (+ (* 16 h) l))))) 129 (value* (as-string (repeated (any-of pct* item) until: (is #\&)))) 130 (name* (as-string (repeated item until: (is #\=)))) 131 (pair* (sequence* ((n name*) 132 (_ (is #\=)) 133 (v value*) 134 (_ (is #\&))) 135 (result (list n (string-translate v "\r"))))) 136 (parser (zero-or-more pair*))) 137 (parse parser (string-append input-text "&")))) 138 (define (input-var name) 139 (let loop ((rest input-list)) 140 (cond ((null? rest) #f) 141 ((string=? (caar rest) name) (cadar rest)) 142 (else (loop (cdr rest)))))) 143 (define (required-input-var name) 144 (let ((val (input-var name))) 145 (if val val (bad-input (conc "missing " name))))) 146 147 (define start-html 148 "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\">") 149 150 (define (html-output form) 151 (write-string start-html) 152 (serialize-sxml form 153 method: 'html 154 output: (current-output-port))) 155 156 (define (htmx-output form) 157 (write-string "Content-Type: text/html\r\n\r\n") 158 (serialize-sxml form 159 method: 'html 160 output: (current-output-port))) 161 162 (define (debug-output) 163 (html-output 164 `(html 165 (head (title "Variable dump")) 166 (body (h1 "Variable dump") 167 (p "Current directory: " ,(current-directory)) 168 (table 169 ,@(map 170 (lambda (pair) 171 `(tr (td ,(car pair)) (td ,(cdr pair)))) 172 (get-environment-variables))) 173 (h2 "Inputs") 174 (pre (code ,input-text)) 175 (table 176 ,@(map 177 (lambda (l) (cons 'tr (map (lambda (c) (list 'td c)) l))) 178 input-list)))))) 179 180 (define (die msg) 181 (write-string "Status: 500\r\n") 182 (when msg 183 (write-string "Content-Type: text/plain\r\n\r\n") 184 (write-string msg)) 185 (exit 1)) 186 (define (bad-input msg) 187 (write-string "Status: 400\r\n") 188 (when msg 189 (write-string "Content-Type: text/plain\r\n\r\n") 190 (write-string msg)) 191 (exit 0)) 192 193 (define irc-digit (in #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) 194 (define irc-hex (in #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 195 #\8 #\9 #\a #\b #\c #\d #\e #\f)) 196 (define (irc-digits n) (repeated irc-digit n)) 197 (define irc-date 198 (as-string 199 (sequence (irc-digits 4) (is #\.) 200 (irc-digits 2) (is #\.) 201 (irc-digits 2) (is #\ ) 202 (irc-digits 2) (is #\:) 203 (irc-digits 2) (is #\:) 204 (irc-digits 2)))) 205 (define irc-nick 206 (as-string 207 (enclosed-by (is #\<) 208 (repeated item until: (is #\>)) 209 (is #\>)))) 210 (define irc-source 211 (as-string 212 (enclosed-by (char-seq " [") 213 (repeated item until: (is #\])) 214 (char-seq "] ")))) 215 (define irc-url 216 (as-string 217 (enclosed-by (char-seq " ") 218 (sequence (char-seq "http") 219 (repeated item until: (is #\space))) 220 (char-seq " ")))) 221 (define irc-hash 222 (as-string 223 (enclosed-by (char-seq "#") 224 (repeated irc-hex 8) 225 end-of-input))) 226 (define irc-suffix (sequence irc-url irc-hash)) 227 (define irc-line 228 (sequence irc-date 229 irc-nick 230 irc-source 231 (as-string (repeated item until: irc-suffix)) 232 irc-url 233 irc-hash)) 234 235 (define (read-line-pos fd) 236 (let loop ((acc "")) 237 (let ((c (file-read fd 1))) 238 (if (and (= 1 (cadr c)) 239 (not (string=? (car c) "\n"))) 240 (loop (string-append acc (car c))) 241 (list acc (file-position fd)))))) 242 243 244 245 (define root (get-environment-variable "DOCUMENT_ROOT")) 246 (when (not root) 247 (die "Missing $DOCUMENT_ROOT")) 248 (define db-name (get-environment-variable "IENS_DB")) 249 (when (not db-name) 250 (die "Missing $IENS_DB")) 251 252 (define db (open-database db-name)) 253 (exec (sql/transient db "PRAGMA foreign_keys = ON;")) 254 255 (include "common.scm") 256 257 (unless (= 4 (db-version)) 258 (die "Unexpectad database version")) 259 260 261 (define (get-config key) 262 (query fetch-value (sql db "SELECT val FROM config WHERE key = ?;") key)) 263 264 (define (get-config/default key default-value) 265 (let ((result (get-config key))) 266 (if result 267 result 268 default-value))) 269 270 (define (line->notes line max-width) 271 (let loop ((rest (string-split line " " #t)) 272 (lines '()) 273 (words "")) 274 (cond 275 ((null? rest) 276 (reverse-string-append (cons words lines))) 277 ((<= (+ (string-length words) 1 (string-length (car rest))) max-width) 278 (loop (cdr rest) 279 lines 280 (string-append words 281 (if (string=? words "") "" " ") 282 (car rest)))) 283 (else 284 (loop (cdr rest) 285 (cons (string-append words "\n") lines) 286 (car rest)))))) 287 288 (define (insert-line line offset) 289 (let ((parsed (parse irc-line line)) 290 (now (current-seconds))) 291 (when parsed 292 (exec 293 (sql db 294 "INSERT INTO gruik(position, notes, ptime, section, title, url, ctime, mtime) VALUES (?, ?, ?, ?, ?, ?, ?, ?);") 295 offset 296 (line->notes line 79) 297 (car parsed) 298 (list-ref parsed 2) 299 (list-ref parsed 3) 300 (list-ref parsed 4) 301 now 302 now)))) 303 304 (define (catch-up) 305 (let* ((span (get-config "gruik-clean"))) 306 (when (number? span) 307 (exec 308 (sql db "DELETE FROM gruik WHERE mark<0 AND mtime<?;") 309 (- (current-seconds) span)))) 310 (let ((src-path (get-config "gruik-source"))) 311 (when (not src-path) (die "No source configured")) 312 (let* ((fd (file-open src-path open/rdonly)) 313 (so (get-config/default "gruik-seen" 0)) 314 (_ (set-file-position! fd so seek/set))) 315 (let loop ((offset so)) 316 (let ((rp (read-line-pos fd))) 317 (if (= (cadr rp) offset) 318 (exec 319 (sql/transient db "INSERT OR REPLACE INTO config VALUES (?,?);") 320 "gruik-seen" 321 offset) 322 (begin 323 (apply insert-line rp) 324 (loop (cadr rp))))))))) 325 326 (define (redirect location) 327 (write-string "Status: 302\r\nLocation: ") 328 (write-string (get-config/default "gruik-host" "")) 329 (write-string (get-config/default "gruik-prefix" "")) 330 (write-string location) 331 (write-string "\r\n\r\n")) 332 333 (define (comment-link section url) 334 (let* ((rss-url (query fetch-value 335 (sql db "SELECT url FROM source_rss WHERE name=?;") 336 section))) 337 (if rss-url 338 (let ((rss (with-input-from-request rss-url #f rss:read))) 339 (let loop ((items (rss:feed-items rss))) 340 (cond 341 ((null? items) #f) 342 ((string=? url (rss:item-link (car items))) 343 (alist-ref 'comments (rss:item-attributes (car items)))) 344 (else (loop (cdr items)))))) 345 #f))) 346 347 (define (auto-descr id) 348 (let ((row (query fetch-row 349 (sql db "SELECT section,url FROM gruik 350 WHERE id=? AND COALESCE(description,'')='';") 351 id))) 352 (unless (null? row) 353 (let ((section (car row)) 354 (url (cadr row)) 355 (comm (apply comment-link row))) 356 (if comm 357 (exec 358 (sql db "UPDATE gruik 359 SET description=?,notes=trim(notes||char(10)||?,char(10)) 360 WHERE id=? AND COALESCE(description,'')='';") 361 (conc " + [](" url ")\n(via [" section "](" comm ") sur #gcufeed)") 362 comm 363 id) 364 (exec 365 (sql db "UPDATE gruik SET description=? 366 WHERE id=? AND COALESCE(description,'')='';") 367 (conc " + [](" url ")\n(via " section " sur #gcufeed)") 368 id)))))) 369 370 (define (spinner-bar x y height beg) 371 `(rect (@ (x ,x) (y ,y) (width 15) (height ,height) (rx 6)) 372 (animate (@ (attributeName height) (begin ,beg) (dur "1s") 373 (values "120;110;100;90;80;70;60;50;40;140;120") 374 (calcMode linear) (repeatCount indefinite))) 375 (animate (@ (attributeName y) (begin ,beg) (dur "1s") 376 (values "10;15;20;25;30;35;40;45;50;0;10") 377 (calcMode linear) (repeatCount indefinite))))) 378 (define (spinner) 379 `(svg (@ (width 16) (height 16) (class spinner) 380 (viewBox "0 0 135 140") (xmlns "http://www.w3.org/2000/svg")) 381 ,(spinner-bar 0 10 120 "0.5s") 382 ,(spinner-bar 30 10 120 "0.25s") 383 ,(spinner-bar 60 0 140 "0s") 384 ,(spinner-bar 90 10 120 "0.25s") 385 ,(spinner-bar 120 10 120 "0.5s"))) 386 387 (define (post-p-fragment id ptime section title url) 388 `(p 389 (span (@ (class "ptime") (title ,id)) ,ptime) 390 (span (@ (class "section")) ,section) 391 (span (@ (class "title")) ,title) 392 (a (@ (href ,url)) ,url))) 393 394 (define (edit-post-fragment id ptime section title url mark notes description) 395 `(form (@ (method "POST") (action "do-edit") 396 (id ,(conc "post-" id)) (class "edit-post") 397 (hx-swap "outerHTML") (hx-post "xdo-edit")) 398 (input (@ (type "submit") (name "submit") (class lsub) (value "Edit"))) 399 (div (@ (class "form-body")) 400 ,(post-p-fragment id ptime section title url) 401 (p ,(conc "Mark: " mark) 402 (label (input (@ (type checkbox) (name lock) (value yes))) "Lock")) 403 (pre (code ,notes)) 404 (p (label "Append to notes:" 405 (textarea (@ (name "notes") (cols 80) (rows 5)) ""))) 406 (p (label "Description:" 407 (textarea (@ (name "description") (cols 80) (rows 12)) ,description))) 408 (fieldset (legend "Tags") 409 (details (@ (class tag-list)) (summary "Tags") 410 ,@(query 411 (map-rows* 412 (lambda (tid name checked) 413 `(label 414 (input (@ (type checkbox) (name tags) (value ,tid) 415 ,@(if (= 0 checked) '() '((checked))))) 416 ,name))) 417 (sql db "SELECT id,name,EXISTS (SELECT * FROM gruik_tags WHERE gruik_id=? AND tag_id = tag.id) FROM tag;") 418 id)))) 419 (input (@ (type "hidden") (name "id") (value ,id))) 420 (input (@ (type "submit") (name "submit") (class rsub) (value "Cancel"))))) 421 422 (define (edit-post-fragment* id) 423 (query 424 (map-rows* edit-post-fragment) 425 (sql db "SELECT id,ptime,section,title,url,mark,notes,description FROM gruik WHERE mark=1 AND id=?;") 426 id)) 427 428 (define (db-edit) 429 (let ((id (string->number (required-input-var "id")))) 430 (when (string=? "Edit" (required-input-var "submit")) 431 (exec 432 (sql/transient db 433 "UPDATE gruik SET mtime=?,notes=trim(notes||char(10)||?,char(10)),description=?,mark=? WHERE mark=1 AND id=?;") 434 (current-seconds) 435 (required-input-var "notes") 436 (required-input-var "description") 437 (if (input-var "lock") 2 1) 438 id) 439 (let* ((n-tags (query fetch-value (sql db "SELECT MAX(id) FROM tag"))) 440 (tags (make-vector (+ 1 n-tags) 0))) 441 (let loop ((var input-list)) 442 (unless (null? var) 443 (when (string=? (caar var) "tags") 444 (vector-set! tags (string->number (cadar var)) 1)) 445 (loop (cdr var)))) 446 (query 447 (for-each-row* 448 (lambda (tid) (vector-set! tags tid (- (vector-ref tags tid) 1)))) 449 (sql db "SELECT tag_id FROM gruik_tags WHERE gruik_id=?;") 450 id) 451 (let loop ((tid n-tags)) 452 (unless (= 0 tid) 453 (case (vector-ref tags tid) 454 ((1) 455 (exec 456 (sql db "INSERT INTO gruik_tags(gruik_id,tag_id) VALUES (?,?);") 457 id tid)) 458 ((-1) 459 (exec 460 (sql db "DELETE FROM gruik_tags WHERE gruik_id=? AND tag_id=?;") 461 id tid))) 462 (loop (- tid 1)))))) 463 id)) 464 465 (define (bad-post-fragment id ptime section title url) 466 `(form (@ (method "POST") (action "do-undelete") 467 (id ,(conc "post-" id)) (class "bad-post") 468 (hx-swap "outerHTML") (hx-post "xdo-undelete")) 469 (input (@ (type "submit") (name "submit") (class lsub) (value "Restore"))) 470 (div (@ (class "form-body")) 471 ,(post-p-fragment id ptime section title url)) 472 (input (@ (type "hidden") (name "id") (value ,id))))) 473 474 (define (locked-post-fragment id ptime section title url) 475 `(form (@ (method "POST") (action "do-locked") 476 (id ,(conc "post-" id)) (class "locked-post") 477 (hx-swap "outerHTML") (hx-post "xdo-locked")) 478 (div (@ (class "form-body")) 479 ,(post-p-fragment id ptime section title url)) 480 (input (@ (type "hidden") (name "id") (value ,id))) 481 (input (@ (type "submit") (name "submit") (class rsub) (value "Unlock"))))) 482 483 (define (marked-post-fragment id ptime section title url) 484 `(form (@ (method "POST") (action "do-marked") 485 (id ,(conc "post-" id)) (class "marked-post") 486 (hx-swap "outerHTML") (hx-post "xdo-marked")) 487 (input (@ (type "submit") (name "submit") (class lsub) (value "Edit"))) 488 (div (@ (class "form-body")) 489 ,(post-p-fragment id ptime section title url)) 490 (input (@ (type "hidden") (name "id") (value ,id))) 491 (input (@ (type "submit") (name "submit") (class rsub) (value "Unmark"))))) 492 493 (define (unmarked-post-fragment id ptime section title url) 494 `(form (@ (method "POST") (action "do-unmarked") 495 (id ,(conc "post-" id)) (class "unmarked-post") 496 (hx-swap "outerHTML") (hx-post "xdo-unmarked")) 497 (input (@ (type "submit") (name "submit") (class lsub) (value "Mark"))) 498 (div (@ (class "form-body")) 499 ,(post-p-fragment id ptime section title url)) 500 (input (@ (type "hidden") (name "id") (value ,id))) 501 (input (@ (type "submit") (name "submit") (class rsub) (value "Delete"))))) 502 503 (define (post-fragment id mark ptime section title url) 504 (case mark 505 ((0) (unmarked-post-fragment id ptime section title url)) 506 ((1) (marked-post-fragment id ptime section title url)) 507 ((2) (locked-post-fragment id ptime section title url)) 508 (else (bad-post-fragment id ptime section title url)))) 509 510 (define (post-htmx id) 511 (htmx-output 512 (query 513 (map-rows* post-fragment) 514 (sql db "SELECT id,mark,ptime,section,title,url FROM gruik WHERE id=?;") 515 id))) 516 517 (define (gruik-list-view title q) 518 (html-output 519 `(html 520 (head 521 (meta (@ (charset "utf-8"))) 522 (meta (@ (name "viewport") 523 (content "width=device-width, initial-scale=1"))) 524 (meta (@ (name "color-scheme") (content "light dark"))) 525 (title ,title) 526 (script (@ (src "https://cdn.jsdelivr.net/npm/htmx.org@2.0.8/dist/htmx.min.js")) "") 527 (style ,css-style)) 528 (body (h1 ,title) 529 ,@(query 530 (map-rows* post-fragment) 531 (sql db q)) 532 (form (@ (method GET) (action "new") (id "load-new") 533 (hx-swap "outerHTML") (hx-post "x-new")) 534 ,(spinner) 535 (input (@ (type "hidden") (name "last-id") (value 536 ,(query fetch-value (sql db "SELECT MAX(id) FROM gruik;"))))) 537 (input (@ (type "submit") (name "submit") (value "Load")))) 538 )))) 539 540 (define (new-fragment) 541 (catch-up) 542 (let* ((last-id (string->number (required-input-var "last-id"))) 543 (frags (query 544 (map-rows* post-fragment) 545 (sql db "SELECT id,mark,ptime,section,title,url FROM gruik WHERE id > ? AND mark >= 0;") 546 last-id)) 547 (btn (if (null? frags) "Recheck" "More"))) 548 (htmx-output 549 `(,@frags 550 (form (@ (method GET) (action "new") (id "load-new") 551 (hx-swap "outerHTML") (hx-post "x-new")) 552 ,(spinner) 553 (input (@ (type "hidden") (name "last-id") (value 554 ,(query fetch-value (sql db "SELECT MAX(id) FROM gruik;"))))) 555 (input (@ (type "submit") (name "submit") (value ,btn)))) 556 )))) 557 558 (define (new-view) 559 (redirect "/")) 560 561 (define (deleted-view) 562 (catch-up) 563 (gruik-list-view 564 "Deleted gruiks" 565 "SELECT id,mark,ptime,section,title,url FROM gruik WHERE mark < 0 ORDER BY mtime;")) 566 567 (define (edit-view id) 568 (let ((title (conc "Gruik #" id))) 569 (html-output 570 `(html 571 (head 572 (meta (@ (charset "utf-8"))) 573 (meta (@ (name "viewport") 574 (content "width=device-width, initial-scale=1"))) 575 (meta (@ (name "color-scheme") (content "light dark"))) 576 (title ,title) 577 (script (@ (src "https://cdn.jsdelivr.net/npm/htmx.org@2.0.8/dist/htmx.min.js")) "") 578 (style ,css-style)) 579 (body (h1 ,title) 580 ,@(edit-post-fragment* id)))))) 581 582 (define (main-view) 583 (catch-up) 584 (gruik-list-view 585 "Latest gruiks" 586 "SELECT id,mark,ptime,section,title,url FROM gruik WHERE mark >= 0;")) 587 588 (define (db-set-mark id old-v new-v) 589 (exec (sql db "UPDATE gruik SET mtime=?, mark=?, stime=? WHERE mark=? AND id=?;") 590 (current-seconds) 591 new-v 592 (if (= 1 new-v) (current-seconds) '()) 593 old-v 594 id)) 595 596 (define (xdo-edit) 597 (let ((id (db-edit))) 598 (post-htmx id))) 599 600 (define (do-locked) 601 (let ((id (required-input-var "id")) 602 (submit (required-input-var "submit"))) 603 (cond 604 ((string=? submit "Unlock") (db-set-mark id 2 1) 605 (redirect (conc "/gruik/" id))) 606 (else (bad-input "bad value for submit"))))) 607 608 (define (xdo-locked) 609 (let ((id (required-input-var "id")) 610 (submit (required-input-var "submit"))) 611 (cond 612 ((string=? submit "Unlock") (db-set-mark id 2 1) (post-htmx id)) 613 (else (bad-input "bad value for submit"))))) 614 615 (define (do-marked) 616 (let ((id (required-input-var "id")) 617 (submit (required-input-var "submit"))) 618 (cond 619 ((string=? submit "Edit") (redirect (conc "/gruik/" id))) 620 ((string=? submit "Unmark") (db-set-mark id 1 0) (redirect "/")) 621 (else (bad-input "bad value for submit"))))) 622 623 (define (xdo-marked) 624 (let ((id (required-input-var "id")) 625 (submit (required-input-var "submit"))) 626 (cond 627 ((string=? submit "Edit") (htmx-output 628 (edit-post-fragment* (string->number id)))) 629 ((string=? submit "Unmark") (db-set-mark id 1 0) (post-htmx id)) 630 (else (bad-input "bad value for submit"))))) 631 632 (define (do-undelete) 633 (let ((id (required-input-var "id")) 634 (submit (required-input-var "submit"))) 635 (cond 636 ((string=? submit "Restore") (db-set-mark id -1 0) (redirect "/")) 637 (else (bad-input "bad value for submit"))))) 638 639 (define (xdo-undelete) 640 (let ((id (required-input-var "id")) 641 (submit (required-input-var "submit"))) 642 (cond 643 ((string=? submit "Restore") (db-set-mark id -1 0) (htmx-output '())) 644 (else (bad-input "bad value for submit"))))) 645 646 (define (do-unmarked) 647 (let ((id (required-input-var "id")) 648 (submit (required-input-var "submit"))) 649 (cond 650 ((string=? submit "Mark") (db-set-mark id 0 1) 651 (auto-descr id) 652 (redirect "/")) 653 ((string=? submit "Delete") (db-set-mark id 0 -1) (redirect "/")) 654 (else (bad-input "bad value for submit"))))) 655 656 (define (xdo-unmarked) 657 (let ((id (required-input-var "id")) 658 (submit (required-input-var "submit"))) 659 (cond 660 ((string=? submit "Mark") (db-set-mark id 0 1) 661 (auto-descr id) 662 (post-htmx id)) 663 ((string=? submit "Delete") (db-set-mark id 0 -1) (htmx-output '())) 664 (else (bad-input "bad value for submit"))))) 665 666 667 (define route-xdo-edit 668 (preceded-by (char-seq "xdo-edit") 669 (result xdo-edit))) 670 (define route-do-locked 671 (preceded-by (char-seq "do-locked") 672 (result do-locked))) 673 (define route-xdo-locked 674 (preceded-by (char-seq "xdo-locked") 675 (result xdo-locked))) 676 (define route-do-marked 677 (preceded-by (char-seq "do-marked") 678 (result do-marked))) 679 (define route-xdo-marked 680 (preceded-by (char-seq "xdo-marked") 681 (result xdo-marked))) 682 (define route-do-undelete 683 (preceded-by (char-seq "do-undelete") 684 (result do-undelete))) 685 (define route-xdo-undelete 686 (preceded-by (char-seq "xdo-undelete") 687 (result xdo-undelete))) 688 (define route-do-unmarked 689 (preceded-by (char-seq "do-unmarked") 690 (result do-unmarked))) 691 (define route-xdo-unmarked 692 (preceded-by (char-seq "xdo-unmarked") 693 (result xdo-unmarked))) 694 (define route-deleted 695 (preceded-by (char-seq "deleted") 696 (result deleted-view))) 697 (define route-new 698 (preceded-by (char-seq "new") 699 (result new-view))) 700 (define route-x-new 701 (preceded-by (char-seq "x-new") 702 (result new-fragment))) 703 (define route-spinner 704 (preceded-by (char-seq "spinner") 705 (result (lambda () (htmx-output (spinner)))))) 706 (define route-edit 707 (sequence* ((_ (char-seq "gruik/")) 708 (id (as-string (one-or-more irc-digit)))) 709 (result (lambda () (edit-view (string->number id)))))) 710 (define route-main (result main-view)) 711 (define route-ok 712 (preceded-by (char-seq "ok") 713 (result (lambda () 714 (write-string "Content-Type: text/plain\r\n\r\nOK\n"))))) 715 716 (define router 717 (preceded-by (char-seq (get-config/default "gruik-prefix" "")) 718 (is #\/) 719 (apply any-of 720 (map (lambda (p) (followed-by p end-of-input)) 721 (list route-do-locked 722 route-do-marked 723 route-do-undelete 724 route-do-unmarked 725 route-xdo-edit 726 route-xdo-locked 727 route-xdo-marked 728 route-xdo-undelete 729 route-xdo-unmarked 730 route-deleted 731 route-edit 732 route-main 733 route-ok 734 route-new 735 route-spinner 736 route-x-new))))) 737 738 (let* ((uri (get-environment-variable "REQUEST_URI")) 739 (_ (if uri uri (die "Missing $REQUEST_URI"))) 740 (fn (parse router uri))) 741 (if fn 742 (fn) 743 (debug-output)))