pref-matrix.scm (20781B)
1 ; Copyright (c) 2024, 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 (chicken file) 16 (chicken io) 17 (chicken irregex) 18 (chicken process-context) 19 (chicken string) 20 (chicken time) 21 (chicken time posix) 22 intarweb 23 spiffy 24 sql-de-lite 25 srfi-1 26 srfi-18 27 uri-common) 28 29 (define replaying? #f) 30 31 (define (command-line-argument k default-value) 32 (let ((args (command-line-arguments))) 33 (if (>= (length args) k) 34 (list-ref args (sub1 k)) 35 default-value))) 36 37 (define (rfc-3339-local seconds) 38 (let ((time-str (time->string (seconds->local-time seconds) "%FT%T%z"))) 39 (assert (= 24 (string-length time-str))) 40 (if (equal? "0000" (substring time-str 20)) 41 (string-append (substring time-str 0 19) "Z") 42 (string-append (substring time-str 0 22) 43 ":" 44 (substring time-str 22))))) 45 46 ;;;;;;;;;;;;; 47 ;; Tracing 48 49 (define trace-port 50 (let ((name (command-line-argument 2 #f))) 51 (cond ((not name) #f) 52 ((equal? name "-") (current-output-port)) 53 (else (open-output-file name #:text #:append))))) 54 55 (define (trace-comment text) 56 (write-line (string-append "; " text) trace-port)) 57 58 (define trace-prev-time 0) 59 (define (trace-time) 60 (let ((sec (current-seconds))) 61 (unless (= sec trace-prev-time) 62 (trace-comment (rfc-3339-local sec)) 63 (set! trace-prev-time sec)))) 64 65 (define (trace-call name args) 66 (trace-time) 67 (write-string "(" #f trace-port) 68 (write name trace-port) 69 (for-each 70 (lambda (arg) 71 (write-string 72 (if (or (string? arg) (number? arg)) " " " '") 73 #f trace-port) 74 (write arg trace-port)) 75 args) 76 (write-line ")" trace-port) 77 (flush-output trace-port)) 78 79 (define (trace-result name args result) 80 (trace-time) 81 (write-string "; -> " #f trace-port) 82 (write result trace-port) 83 (newline trace-port) 84 (flush-output trace-port)) 85 86 (define-syntax define-half-traced 87 (syntax-rules () 88 ((define-half-traced (name . args) . body) 89 (define (name . args) 90 (trace-call 'name (list . args)) 91 . body)))) 92 93 (define-syntax define-traced 94 (syntax-rules () 95 ((define-traced (name . args) . body) 96 (define (name . args) 97 (trace-call 'name (list . args)) 98 (let ((result (begin . body))) 99 (trace-result 'name (list . args) result) 100 result))))) 101 102 (unless trace-port 103 (set! trace-call (lambda (x) #f)) 104 (set! trace-comment (lambda (x) #f)) 105 (set! trace-result (lambda (x y) #f))) 106 107 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 108 ;; Database Creation/Migration 109 110 (define db 111 (open-database (command-line-argument 1 "pref-matrix.sqlite"))) 112 113 (exec (sql db "PRAGMA foreign_keys = ON;")) 114 115 (define (db-version) 116 (query fetch-value (sql db "PRAGMA user_version;"))) 117 118 (when (= 0 (db-version)) 119 (for-each 120 (lambda (s) (exec (sql/transient db s))) 121 (list "PRAGMA user_version = 2;" 122 "PRAGMA journal_mode = wal;" 123 "PRAGMA synchronous = normal;" 124 "CREATE TABLE config (key TEXT PRIMARY KEY, val ANY);" 125 "CREATE TABLE topic (id INTEGER PRIMARY KEY, 126 name TEXT NOT NULL, 127 closed INTEGER NOT NULL DEFAULT 0);" 128 "CREATE TABLE subject (id INTEGER PRIMARY KEY, 129 topic_id NOT NULL REFERENCES topic(id) 130 ON UPDATE CASCADE ON DELETE CASCADE, 131 name TEXT NOT NULL, 132 hidden INTEGER NOT NULL DEFAULT 0);" 133 "CREATE TABLE object (id INTEGER PRIMARY KEY, 134 topic_id NOT NULL REFERENCES topic(id) 135 ON UPDATE CASCADE ON DELETE CASCADE, 136 name TEXT NOT NULL, 137 hidden INTEGER NOT NULL DEFAULT 0);" 138 "CREATE TABLE pref (id INTEGER PRIMARY KEY, 139 sub_id NOT NULL REFERENCES subject(id) 140 ON UPDATE CASCADE ON DELETE CASCADE, 141 obj_id NOT NULL REFERENCES object(id) 142 ON UPDATE CASCADE ON DELETE CASCADE, 143 val INTEGER NOT NULL DEFAULT 0);" 144 "CREATE UNIQUE INDEX topic_name ON topic(name);" 145 "CREATE UNIQUE INDEX sub_name ON subject(topic_id,name);" 146 "CREATE UNIQUE INDEX obj_name ON object(topic_id,name);" 147 "CREATE INDEX v_sub_name ON subject(topic_id,name) WHERE hidden=0;" 148 "CREATE INDEX v_obj_name ON object(topic_id,name) WHERE hidden=0;" 149 "CREATE UNIQUE INDEX sub_obj ON pref(sub_id,obj_id);"))) 150 151 (when (= 1 (db-version)) 152 (with-transaction db (lambda () 153 (for-each 154 (lambda (s) (exec (sql/transient db s))) 155 (list "ALTER TABLE config RENAME TO old_config;" 156 "ALTER TABLE subject RENAME TO old_subject;" 157 "ALTER TABLE object RENAME TO old_object;" 158 "ALTER TABLE pref RENAME TO old_pref;" 159 "CREATE TABLE config (key TEXT PRIMARY KEY, val ANY);" 160 "INSERT INTO config(key,val) SELECT key,val FROM old_config;" 161 "INSERT OR IGNORE INTO config(key,val) 162 VALUES ('default_topic','default');" 163 "DROP TABLE old_config;" 164 "CREATE TABLE topic (id INTEGER PRIMARY KEY, 165 name TEXT NOT NULL, 166 closed INTEGER NOT NULL DEFAULT 0);" 167 "INSERT INTO topic(id,name) 168 SELECT 1,val FROM config WHERE key='default_topic';" 169 "CREATE TABLE subject (id INTEGER PRIMARY KEY, 170 topic_id NOT NULL REFERENCES topic(id) 171 ON UPDATE CASCADE ON DELETE CASCADE, 172 name TEXT NOT NULL, 173 hidden INTEGER NOT NULL DEFAULT 0);" 174 "INSERT INTO subject(id,topic_id,name) 175 SELECT id,1,name FROM old_subject;" 176 "CREATE TABLE object (id INTEGER PRIMARY KEY, 177 topic_id NOT NULL REFERENCES topic(id) 178 ON UPDATE CASCADE ON DELETE CASCADE, 179 name TEXT NOT NULL, 180 hidden INTEGER NOT NULL DEFAULT 0);" 181 "INSERT INTO object(id,topic_id,name) 182 SELECT id,1,name FROM old_object;" 183 "CREATE TABLE pref (id INTEGER PRIMARY KEY, 184 sub_id NOT NULL REFERENCES subject(id) 185 ON UPDATE CASCADE ON DELETE CASCADE, 186 obj_id NOT NULL REFERENCES object(id) 187 ON UPDATE CASCADE ON DELETE CASCADE, 188 val INTEGER NOT NULL DEFAULT 0);" 189 "INSERT INTO pref(id,sub_id,obj_id,val) 190 SELECT id,sub_id,obj_id,val FROM old_pref;" 191 "DROP TABLE old_pref;" 192 "DROP TABLE old_subject;" 193 "DROP TABLE old_object;" 194 "CREATE UNIQUE INDEX topic_name ON topic(name);" 195 "CREATE UNIQUE INDEX sub_name ON subject(topic_id,name);" 196 "CREATE UNIQUE INDEX obj_name ON object(topic_id,name);" 197 "CREATE INDEX v_sub_name ON subject(topic_id,name) WHERE hidden=0;" 198 "CREATE INDEX v_obj_name ON object(topic_id,name) WHERE hidden=0;" 199 "CREATE UNIQUE INDEX sub_obj ON pref(sub_id,obj_id);" 200 "PRAGMA user_version = 2;"))))) 201 202 (assert (= 2 (db-version))) 203 204 ;;;;;;;;;;;;;;;;;;; 205 ;; Database Query 206 207 (define (get-config key default-value) 208 (let ((result (query fetch-value 209 (sql db "SELECT val FROM config WHERE key=?;") 210 key))) 211 (if result result default-value))) 212 213 (define (topic-file-name tid) 214 (query fetch-value (sql db "SELECT name FROM topic WHERE id=?;") tid)) 215 216 (define (topic-id name) 217 (query fetch-value (sql db "SELECT id FROM topic WHERE name=?;") name)) 218 219 (define (writable-topic-id name) 220 (let* ((resolved-name (if name name (get-config "default_topic" #f))) 221 (row (if resolved-name 222 (query fetch-row 223 (sql db "SELECT id,closed FROM topic WHERE name=?;") 224 resolved-name) 225 '()))) 226 (if (and (not (null? row)) (zero? (cadr row))) 227 (car row) 228 #f))) 229 230 (define (topic-id-list) 231 (query (map-rows car) (sql db "SELECT id FROM topic;"))) 232 233 (define (object-id tid name) 234 (query fetch-value 235 (sql db "SELECT id FROM object WHERE topic_id=? AND name=?;") 236 tid 237 name)) 238 239 (define (object-list tid) 240 (query (map-rows car) 241 (sql db "SELECT name FROM object 242 WHERE topic_id=? AND hidden=0 ORDER BY name;") 243 tid)) 244 245 (define (subject-id tid name) 246 (query fetch-value 247 (sql db "SELECT id FROM subject WHERE topic_id=? AND name=?;") 248 tid 249 name)) 250 251 (define (subject-list tid) 252 (query (map-rows car) 253 (sql db "SELECT name FROM subject 254 WHERE topic_id=? AND hidden=0 ORDER BY name;") 255 tid)) 256 257 (define (subject-pref tid name) 258 (query fetch-rows 259 (sql db "SELECT object.name,val FROM pref 260 OUTER LEFT JOIN object ON object.id = obj_id 261 OUTER LEFT JOIN subject ON subject.id = sub_id 262 WHERE subject.topic_id=? AND subject.name=? 263 AND object.hidden=0 264 ORDER BY object.name") 265 tid name)) 266 267 ;;;;;;;;;;;;;;;;;;;;;;;;; 268 ;; Data File Generation 269 270 (define json-escape-map 271 '(("\x00" . "\\u0000") 272 ("\x01" . "\\u0001") 273 ("\x02" . "\\u0002") 274 ("\x03" . "\\u0003") 275 ("\x04" . "\\u0004") 276 ("\x05" . "\\u0005") 277 ("\x06" . "\\u0006") 278 ("\a" . "\\u0007") 279 ("\b" . "\\b") 280 ("\t" . "\\t") 281 ("\n" . "\\n") 282 ("\v" . "\\u000b") 283 ("\f" . "\\f") 284 ("\r" . "\\r") 285 ("\x0e" . "\\u000e") 286 ("\x0f" . "\\u000f") 287 ("\x10" . "\\u0010") 288 ("\x11" . "\\u0011") 289 ("\x12" . "\\u0012") 290 ("\x13" . "\\u0013") 291 ("\x14" . "\\u0014") 292 ("\x15" . "\\u0015") 293 ("\x16" . "\\u0016") 294 ("\x17" . "\\u0017") 295 ("\x18" . "\\u0018") 296 ("\x19" . "\\u0019") 297 ("\x1a" . "\\u001a") 298 ("\x1b" . "\\u001b") 299 ("\x1c" . "\\u001c") 300 ("\x1d" . "\\u001d") 301 ("\x1e" . "\\u001e") 302 ("\x1f" . "\\u001f") 303 ("\"" . "\\\"") 304 ("\\" . "\\\\"))) 305 306 (define valid-file-name-irregex 307 (sre->irregex '(+ (or alphanumeric "-" "_")))) 308 (define (valid-file-name? name) 309 (irregex-match? valid-file-name-irregex name)) 310 311 (define (json-escape raw-str) 312 (string-translate* raw-str json-escape-map)) 313 314 (define (subject-json tid name) 315 (string-append 316 "{" 317 (string-intersperse 318 (map (lambda (row) 319 (string-append "\"" 320 (json-escape (car row)) 321 "\":" 322 (number->string (cadr row)))) 323 (subject-pref tid name)) 324 ",") 325 "}")) 326 327 (define (topic-json tid) 328 (string-append 329 "[[\"" 330 (string-intersperse (map json-escape (object-list tid)) "\",\"") 331 "\"],{" 332 (string-intersperse 333 (map 334 (lambda (name) 335 (string-append "\"" 336 (json-escape name) 337 "\":" 338 (subject-json tid name))) 339 (subject-list tid)) 340 ",") 341 "}]")) 342 343 (define (generate-topic-json tid) 344 (let ((name (topic-file-name tid))) 345 (when (valid-file-name? name) 346 (with-output-to-file 347 (string-append 348 (get-config "json-prefix" "") 349 name 350 ".json") 351 (lambda () (write-string (topic-json tid))))))) 352 353 (define (generate-json) 354 (for-each generate-topic-json (topic-id-list))) 355 356 ;;;;;;;;;;;;;;;;;;;;; 357 ;; Database Updates 358 359 (define-traced (new-topic name) 360 (if (or (zero? (string-length name)) (topic-id name)) 361 #f 362 (begin 363 (exec (sql db "INSERT INTO topic(name) VALUES (?);") name) 364 (let ((result (last-insert-rowid db))) 365 (unless replaying? (generate-topic-json result)) 366 result)))) 367 368 (define-traced (close-topic name n) 369 (let ((tid (topic-id name))) 370 (if tid 371 (begin 372 (exec (sql db "UPDATE topic SET closed=? WHERE id=?") n tid) 373 tid) 374 #f))) 375 376 (define-traced (new-object topic name) 377 (let ((tid (writable-topic-id topic))) 378 (if (or (not tid) (zero? (string-length name))) 379 #f 380 (let ((row (query fetch-row 381 (sql db "SELECT id,hidden FROM object 382 WHERE topic_id=? AND name=?;") 383 tid 384 name))) 385 (cond ((null? row) 386 (exec 387 (sql db "INSERT INTO object(topic_id,name) VALUES (?,?);") 388 tid name) 389 (let ((result (last-insert-rowid db))) 390 (unless replaying? (generate-topic-json tid)) 391 result)) 392 ((zero? (cadr row)) #f) 393 (else 394 (exec (sql db "UPDATE object SET hidden=0 WHERE id=?;") 395 (car row)) 396 (unless replaying? (generate-topic-json tid)) 397 (car row))))))) 398 399 (define-half-traced (hide-object topic name) 400 (let* ((tid (writable-topic-id topic)) 401 (oid (if tid (object-id tid name) #f))) 402 (when oid 403 (exec (sql db "UPDATE object SET hidden=1 WHERE id=?;") oid) 404 (unless replaying? (generate-topic-json tid))))) 405 406 (define-traced (new-subject topic name) 407 (let ((tid (writable-topic-id topic))) 408 (if (or (not tid) (zero? (string-length name))) 409 #f 410 (let ((row (query fetch-row 411 (sql db "SELECT id,hidden FROM subject 412 WHERE topic_id=? AND name=?;") 413 tid 414 name))) 415 (cond ((null? row) 416 (exec 417 (sql db "INSERT INTO subject(topic_id,name) VALUES (?,?);") 418 tid name) 419 (let ((result (last-insert-rowid db))) 420 (unless replaying? (generate-topic-json tid)) 421 result)) 422 ((zero? (cadr row)) #f) 423 (else 424 (exec (sql db "UPDATE subject SET hidden=0 WHERE id=?;") 425 (car row)) 426 (unless replaying? (generate-topic-json tid)) 427 (car row))))))) 428 429 (define-half-traced (hide-subject topic name) 430 (let* ((tid (writable-topic-id topic)) 431 (sid (if tid (subject-id tid name) #f))) 432 (when sid 433 (exec (sql db "UPDATE subject SET hidden=1 WHERE id=?;") sid) 434 (unless replaying? (generate-topic-json tid))))) 435 436 (define-half-traced (set-config key val) 437 (exec (sql db "INSERT OR REPLACE INTO config(key,val) VALUES (?,?);") 438 key 439 val)) 440 441 (define (set-pref tid sub-id object-name value) 442 (let ((obj-id (object-id tid object-name))) 443 (if obj-id 444 (begin 445 (exec (sql db "INSERT OR REPLACE INTO pref(sub_id,obj_id,val) 446 VALUES (?,?,?);") 447 sub-id 448 obj-id 449 value) 450 (last-insert-rowid db)) 451 #f))) 452 453 (define-traced (set-subject-pref topic-name subject-name alist) 454 (let* ((tid (writable-topic-id topic-name)) 455 (sub-id (if tid (subject-id tid subject-name) #f))) 456 (if sub-id 457 (let ((result 458 (map 459 (lambda (pair) 460 (set-pref tid sub-id (car pair) (string->number (cdr pair)))) 461 alist))) 462 (unless replaying? (generate-topic-json tid)) 463 result) 464 #f))) 465 466 ;;;;;;;;;;; 467 ;; Replay 468 469 (let ((replay-str (command-line-argument 3 #f))) 470 (when replay-str 471 (set! replaying? #t) 472 (load replay-str) 473 (generate-json) 474 (set! replaying? #f))) 475 476 ;;;;;;;;;;;;;;;;;;; 477 ;; Database Mutex 478 479 (define db-mutex 480 (make-mutex "sqlite-db")) 481 482 (define-syntax with-db 483 (syntax-rules () 484 ((with-db . op) 485 (dynamic-wind 486 (lambda () (mutex-lock! db-mutex)) 487 (lambda () (with-transaction db (lambda () . op))) 488 (lambda () (mutex-unlock! db-mutex)))))) 489 490 ;;;;;;;;;;;; 491 ;; Web API 492 493 (define cmd-list '()) 494 (define (cmd-sleep) 495 (let ((duration (get-config "tarpit" #f))) 496 (when duration (sleep duration)))) 497 (define-syntax defcmd 498 (syntax-rules () 499 ((defcmd name . body) 500 (set! cmd-list (cons (cons (symbol->string 'name) 501 (lambda () (cmd-sleep) . body)) 502 cmd-list))))) 503 504 (defcmd close-topic 505 (let* ((data (read-urlencoded-request-data (current-request))) 506 (name (alist-ref 'name data eq? #f))) 507 (if name 508 (let ((result (with-db (close-topic name 1)))) 509 (if result 510 (send-status 'ok) 511 (send-status 'bad-request "Name not found"))) 512 (send-status 'bad-request "Missing parameter")))) 513 514 (defcmd hide-object 515 (let* ((data (read-urlencoded-request-data (current-request))) 516 (topic (alist-ref 'topic data eq? #f)) 517 (name (alist-ref 'name data eq? #f))) 518 (if name 519 (begin 520 (with-db (hide-object topic name)) 521 (send-status 'ok)) 522 (send-status 'bad-request "Missing parameter")))) 523 524 (defcmd hide-subject 525 (let* ((data (read-urlencoded-request-data (current-request))) 526 (topic (alist-ref 'topic data eq? #f)) 527 (name (alist-ref 'name data eq? #f))) 528 (if name 529 (begin 530 (with-db (hide-subject topic name)) 531 (send-status 'ok)) 532 (send-status 'bad-request "Missing parameter")))) 533 534 (defcmd new-topic 535 (let* ((data (read-urlencoded-request-data (current-request))) 536 (name (alist-ref 'name data eq? #f))) 537 (if name 538 (let ((result (with-db (new-topic name)))) 539 (if result 540 (send-status 'ok) 541 (send-status 'conflict "Name already exists"))) 542 (send-status 'bad-request "Missing parameter")))) 543 544 (defcmd new-object 545 (let* ((data (read-urlencoded-request-data (current-request))) 546 (topic (alist-ref 'topic data eq? #f)) 547 (name (alist-ref 'name data eq? #f))) 548 (if name 549 (let ((result (with-db (new-object topic name)))) 550 (if result 551 (send-status 'ok) 552 (send-status 'conflict "Name already exists"))) 553 (send-status 'bad-request "Missing parameter")))) 554 555 (defcmd new-subject 556 (let* ((data (read-urlencoded-request-data (current-request))) 557 (topic (alist-ref 'topic data eq? #f)) 558 (name (alist-ref 'name data eq? #f))) 559 (if name 560 (let ((result (with-db (new-subject topic name)))) 561 (if result 562 (send-status 'ok) 563 (send-status 'conflict "Name already exists"))) 564 (send-status 'bad-request "Missing parameter")))) 565 566 (defcmd set-pref 567 (let* ((all-data (read-urlencoded-request-data (current-request))) 568 (topic (if (eq? (caar all-data) 'topic) (cdar all-data) #f)) 569 (data (if topic (cdr all-data) all-data))) 570 (if (eq? (caar data) 'sub) 571 (begin 572 (with-db 573 (set-subject-pref 574 topic 575 (cdar data) 576 (map 577 (lambda (pair) (cons (symbol->string (car pair)) (cdr pair))) 578 (cdr data)))) 579 (send-status 'ok)) 580 (send-status 'bad-request "Malformed request")))) 581 582 ;;;;;;;;;;;;;;; 583 ;; Web Server 584 585 (define (web-process continue) 586 (cond ((not (eq? (request-method (current-request)) 'POST)) 587 (send-status 'method-not-allowed "This is a POST handler")) 588 ((not (request-has-message-body? (current-request))) 589 (send-status 'bad-request "Needs a body to process")) 590 (else 591 ((alist-ref (last (uri-path (request-uri (current-request)))) 592 cmd-list 593 equal? 594 continue))))) 595 596 (server-port (get-config "server-port" 8080)) 597 (vhost-map `((".*" . ,web-process))) 598 (start-server)