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