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