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