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