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