cgi.scm (12629B)
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 string) 20 (chicken time) 21 comparse 22 sql-de-lite 23 sxml-serializer) 24 25 (define css-style " 26 .bad-post { background: #fcc; } 27 .marked-post { backgound: #ccf; } 28 ") 29 30 (define content-length 31 (let ((ct (get-environment-variable "CONTENT_LENGTH"))) 32 (if ct (string->number ct) 0))) 33 (define input-text (read-string content-length)) 34 (define input-list 35 (map 36 (lambda (s) 37 (let ((index (substring-index "=" s))) 38 (if index 39 (list (substring s 0 index) (substring s (+ 1 index))) 40 s))) 41 (string-split input-text "&"))) 42 (define (input-var name) 43 (let loop ((rest input-list)) 44 (cond ((null? rest) #f) 45 ((string=? (caar rest) name) (cadar rest)) 46 (else (loop (cdr rest)))))) 47 48 (define start-html 49 "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\">") 50 51 (define (html-output form) 52 (write-string start-html) 53 (serialize-sxml form 54 method: 'html 55 output: (current-output-port))) 56 57 (define (htmx-output form) 58 (write-string "Content-Type: text/html\r\n\r\n") 59 (serialize-sxml form 60 method: 'html 61 output: (current-output-port))) 62 63 (define (debug-output) 64 (html-output 65 `(html 66 (head (title "Variable dump")) 67 (body (h1 "Variable dump") 68 (p "Current directory: " ,(current-directory)) 69 (table 70 ,@(map 71 (lambda (pair) 72 `(tr (td ,(car pair)) (td ,(cdr pair)))) 73 (get-environment-variables))) 74 (h2 "Inputs") 75 (pre (code ,input-text)) 76 (table 77 ,@(map 78 (lambda (l) (cons 'tr (map (lambda (c) (list 'td c)) l))) 79 input-list)))))) 80 81 (define (die msg) 82 (write-string "Status: 500\r\n") 83 (when msg 84 (write-string "Content-Type: text/plain\r\n\r\n") 85 (write-string msg)) 86 (exit 1)) 87 (define (bad-input msg) 88 (write-string "Status: 400\r\n") 89 (when msg 90 (write-string "Content-Type: text/plain\r\n\r\n") 91 (write-string msg)) 92 (exit 0)) 93 94 (define irc-digit (in #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) 95 (define irc-hex (in #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 96 #\8 #\9 #\a #\b #\c #\d #\e #\f)) 97 (define (irc-digits n) (repeated irc-digit n)) 98 (define irc-date 99 (as-string 100 (sequence (irc-digits 4) (is #\.) 101 (irc-digits 2) (is #\.) 102 (irc-digits 2) (is #\ ) 103 (irc-digits 2) (is #\:) 104 (irc-digits 2) (is #\:) 105 (irc-digits 2)))) 106 (define irc-nick 107 (as-string 108 (enclosed-by (is #\<) 109 (repeated item until: (is #\>)) 110 (is #\>)))) 111 (define irc-source 112 (as-string 113 (enclosed-by (char-seq " [") 114 (repeated item until: (is #\])) 115 (char-seq "] ")))) 116 (define irc-url 117 (as-string 118 (enclosed-by (char-seq " ") 119 (sequence (char-seq "http") 120 (repeated item until: (is #\space))) 121 (char-seq " ")))) 122 (define irc-hash 123 (as-string 124 (enclosed-by (char-seq "#") 125 (repeated irc-hex 8) 126 end-of-input))) 127 (define irc-suffix (sequence irc-url irc-hash)) 128 (define irc-line 129 (sequence irc-date 130 irc-nick 131 irc-source 132 (as-string (repeated item until: irc-suffix)) 133 irc-url 134 irc-hash)) 135 136 (define (read-line-pos fd) 137 (let loop ((acc "")) 138 (let ((c (file-read fd 1))) 139 (if (and (= 1 (cadr c)) 140 (not (string=? (car c) "\n"))) 141 (loop (string-append acc (car c))) 142 (list acc (file-position fd)))))) 143 144 145 146 (define root (get-environment-variable "DOCUMENT_ROOT")) 147 (when (not root) 148 (die "Missing $DOCUMENT_ROOT")) 149 (define db-name (string-append root "/./iens.sqlite")) 150 151 (define db (open-database db-name)) 152 (exec (sql/transient db "PRAGMA foreign_keys = ON;")) 153 (define (db-version) 154 (query fetch-value (sql db "PRAGMA user_version;"))) 155 156 (when (= 2 (db-version)) 157 (for-each 158 (lambda (s) (exec (sql/transient db s))) 159 (list "CREATE TABLE gruik 160 (id INTEGER PRIMARY KEY, 161 position INTEGER NOT NULL, 162 notes TEXT NOT NULL, 163 description TEXT, 164 ptime INTEGER NOT NULL, 165 section TEXT NOT NULL, 166 title TEXT NOT NULL, 167 url TEXT NOT NULL, 168 mark INTEGER NOT NULL DEFAULT FALSE, 169 ctime INTEGER NOT NULL, 170 mtime INTEGER NOT NULL);" 171 "CREATE UNIQUE INDEX i_gruik ON gruik(position);" 172 "CREATE INDEX i_gruik_time ON gruik(ptime);" 173 "CREATE TABLE gruik_tags 174 (gruik_id REFERENCES gruik(id) ON UPDATE CASCADE ON DELETE CASCADE, 175 tag_id REFERENCES tag(id) ON UPDATE CASCADE ON DELETE CASCADE);" 176 "CREATE UNIQUE INDEX i_gruik_rel ON gruik_tags(gruik_id,tag_id);" 177 "CREATE INDEX i_gruik_tags ON gruik_tags(tag_id,gruik_id);" 178 "INSERT INTO config(key, val) VALUES ('gruik-source', '/home/nat/irclogs/libera/#gcufeed.log');" 179 "INSERT INTO config(key, val) VALUES ('gruik-seen', 38678556);" 180 "INSERT INTO config(key, val) VALUES ('gruik-host', 'https://users.instinctive.eu');" 181 "INSERT INTO config(key, val) VALUES ('gruik-prefix', '/iens');" 182 "PRAGMA user_version = 3;"))) 183 184 (unless (= 3 (db-version)) 185 (die "Unexpectad database version")) 186 187 188 (define (get-config key) 189 (query fetch-value (sql db "SELECT val FROM config WHERE key = ?;") key)) 190 191 (define (get-config/default key default-value) 192 (let ((result (get-config key))) 193 (if result 194 result 195 default-value))) 196 197 (define (insert-line line offset) 198 (let ((parsed (parse irc-line line)) 199 (now (current-seconds))) 200 (when parsed 201 (exec 202 (sql db 203 "INSERT INTO gruik(position, notes, ptime, section, title, url, ctime, mtime) VALUES (?, ?, ?, ?, ?, ?, ?, ?);") 204 offset 205 line 206 (car parsed) 207 (list-ref parsed 2) 208 (list-ref parsed 3) 209 (list-ref parsed 4) 210 now 211 now)))) 212 213 (define (catch-up) 214 (let ((src-path (get-config "gruik-source"))) 215 (when (not src-path) (die "No source configured")) 216 (let* ((fd (file-open src-path open/rdonly)) 217 (so (get-config/default "gruik-seen" 0)) 218 (_ (set-file-position! fd so seek/set))) 219 (let loop ((offset so)) 220 (let ((rp (read-line-pos fd))) 221 (if (= (cadr rp) offset) 222 (exec 223 (sql/transient db "INSERT OR REPLACE INTO config VALUES (?,?);") 224 "gruik-seen" 225 offset) 226 (begin 227 (apply insert-line rp) 228 (loop (cadr rp))))))))) 229 230 (define (redirect location) 231 (write-string "Status: 302\r\nLocation: ") 232 (write-string (get-config/default "gruik-host" "")) 233 (write-string (get-config/default "gruik-prefix" "")) 234 (write-string location) 235 (write-string "\r\n\r\n")) 236 237 (define (post-p-fragment ptime section title url) 238 `(p 239 (span (@ (class "ptime")) ,ptime) 240 (span (@ (class "section")) ,section) 241 (span (@ (class "title")) ,title) 242 (a (@ (href ,url)) ,url))) 243 244 (define (bad-post-fragment id ptime section title url) 245 `(form (@ (method "POST") (action "do-undelete") (class "bad-post")) 246 ,(post-p-fragment ptime section title url) 247 (input (@ (type "hidden") (name "id") (value ,id))) 248 (input (@ (type "submit") (name "submit") (value "Restore"))))) 249 250 (define (marked-post-fragment id ptime section title url) 251 `(form (@ (method "POST") (action "do-marked") (class "marked-post")) 252 ,(post-p-fragment ptime section title url) 253 (input (@ (type "hidden") (name "id") (value ,id))) 254 (input (@ (type "submit") (name "submit") (value "Unmark"))) 255 (input (@ (type "submit") (name "submit") (value "Edit"))))) 256 257 (define (unmarked-post-fragment id ptime section title url) 258 `(form (@ (method "POST") (action "do-unmarked") (class "unmarked-post")) 259 ,(post-p-fragment ptime section title url) 260 (input (@ (type "hidden") (name "id") (value ,id))) 261 (input (@ (type "submit") (name "submit") (value "Mark"))) 262 (input (@ (type "submit") (name "submit") (value "Delete"))))) 263 264 (define (post-fragment id mark ptime section title url) 265 (case mark 266 ((0) (unmarked-post-fragment id ptime section title url)) 267 ((1) (marked-post-fragment id ptime section title url)) 268 (else (bad-post-fragment id ptime section title url)))) 269 270 (define (gruik-list-view title q) 271 (html-output 272 `(html 273 (head 274 (title ,title) 275 (script (@ (src "https://cdn.jsdelivr.net/npm/htmx.org@2.0.8/dist/htmx.min.js")) "")) 276 (style ,css-style) 277 (body (h1 ,title) 278 ,@(query 279 (map-rows* post-fragment) 280 (sql db q)))))) 281 282 (define (deleted-view) 283 (catch-up) 284 (gruik-list-view 285 "Deleted gruiks" 286 "SELECT id,mark,ptime,section,title,url FROM gruik WHERE mark < 0 ORDER BY mtime;")) 287 288 (define (main-view) 289 (catch-up) 290 (gruik-list-view 291 "Latest gruiks" 292 "SELECT id,mark,ptime,section,title,url FROM gruik WHERE mark >= 0;")) 293 294 (define (do-set-mark id old-v new-v) 295 (exec (sql db "UPDATE gruik SET mtime=?, mark=? WHERE mark=? AND id=?;") 296 (current-seconds) new-v old-v id)) 297 298 (define (do-marked) 299 (let ((id (input-var "id")) 300 (submit (input-var "submit"))) 301 (cond 302 ((not id) (bad-input "missing id")) 303 ((not submit) (bad-input "missing submit")) 304 ((string=? submit "Edit") (redirect (conc "/gruik/" id))) 305 ((string=? submit "Unmark") (do-set-mark id 0 -1) (redirect "/")) 306 (else (bad-input "bad value for submit"))))) 307 308 (define (do-undelete) 309 (let ((id (input-var "id")) 310 (submit (input-var "submit"))) 311 (cond 312 ((not id) (bad-input "missing id")) 313 ((not submit) (bad-input "missing submit")) 314 ((string=? submit "Restore") (do-set-mark id -1 0) (redirect "/")) 315 (else (bad-input "bad value for submit"))))) 316 317 (define (do-unmarked) 318 (let ((id (input-var "id")) 319 (submit (input-var "submit"))) 320 (cond 321 ((not id) (bad-input "missing id")) 322 ((not submit) (bad-input "missing submit")) 323 ((string=? submit "Mark") (do-set-mark id 0 1) (redirect "/")) 324 ((string=? submit "Delete") (do-set-mark id 0 -1) (redirect "/")) 325 (else (bad-input "bad value for submit"))))) 326 327 328 (defrne route-do-marked 329 (preceded-by (char-seq "do-marked") 330 (result do-marked))) 331 (define route-do-undelete 332 (preceded-by (char-seq "do-undelete") 333 (result do-undelete))) 334 (define route-do-unmarked 335 (preceded-by (char-seq "do-unmarked") 336 (result do-unmarked))) 337 (define route-do-unmarked 338 (preceded-by (char-seq "do-unmarked") 339 (result do-unmarked))) 340 (define route-deleted 341 (preceded-by (char-seq "deleted") 342 (result deleted-view))) 343 (define route-main (result main-view)) 344 (define route-ok 345 (preceded-by (char-seq "ok") 346 (result (lambda () 347 (write-string "Content-Type: text/plain\r\n\r\nOK\n"))))) 348 349 (define router 350 (preceded-by (char-seq (get-config/default "gruik-prefix" "")) 351 (is #\/) 352 (apply any-of 353 (map (lambda (p) (followed-by p end-of-input)) 354 (list route-do-marked 355 route-do-undelete 356 route-do-unmarked 357 route-deleted 358 route-main 359 route-ok))))) 360 361 (let* ((uri (get-environment-variable "REQUEST_URI")) 362 (_ (if uri uri (die "Missing $REQUEST_URI"))) 363 (fn (parse router uri))) 364 (if fn 365 (fn) 366 (debug-output)))