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