commit 8cafa2cf61e4fdbcce85282b907a6c0cba54fdf5
parent 97fc8eaf8ef4d01045b0a177c78e27b2705edc95
Author: Natasha Kerensikova <natgh@instinctive.eu>
Date: Mon, 22 Jan 2024 19:04:43 +0000
Topic support
Diffstat:
5 files changed, 153 insertions(+), 86 deletions(-)
diff --git a/src/pref-matrix.scm b/src/pref-matrix.scm
@@ -201,9 +201,6 @@
(assert (= 2 (db-version)))
-(exec (sql/transient db
- "INSERT OR IGNORE INTO topic(id,name) VALUES (1,'TODO');"))
-
;;;;;;;;;;;;;;;;;;;
;; Database Query
@@ -213,27 +210,56 @@
key)))
(if result result default-value)))
-(define (object-id name)
- (query fetch-value (sql db "SELECT id FROM object WHERE name=?;") name))
+(define (topic-file-name tid)
+ (query fetch-value (sql db "SELECT name FROM topic WHERE id=?;") tid))
+
+(define (topic-id name)
+ (query fetch-value (sql db "SELECT id FROM topic WHERE name=?;") name))
+
+(define (writable-topic-id name)
+ (let* ((resolved-name (if name name (get-config "default_topic" #f)))
+ (row (if resolved-name
+ (query fetch-row
+ (sql db "SELECT id,closed FROM topic WHERE name=?;")
+ resolved-name)
+ '())))
+ (if (and (not (null? row)) (zero? (cadr row)))
+ (car row)
+ #f)))
+
+(define (topic-id-list)
+ (query (map-rows car) (sql db "SELECT id FROM topic;")))
-(define (object-list)
- (query (map-rows car) (sql db "SELECT name FROM object ORDER BY name;")))
+(define (object-id tid name)
+ (query fetch-value
+ (sql db "SELECT id FROM object WHERE topic_id=? AND name=?;")
+ tid
+ name))
-(define (subject-id name)
- (query fetch-value (sql db "SELECT id FROM subject WHERE name=?;") name))
+(define (object-list tid)
+ (query (map-rows car)
+ (sql db "SELECT name FROM object WHERE topic_id=? ORDER BY name;")
+ tid))
-(define (subject-list)
- (query (map-rows car) (sql db "SELECT name FROM subject ORDER BY name;")))
+(define (subject-id tid name)
+ (query fetch-value
+ (sql db "SELECT id FROM subject WHERE topic_id=? AND name=?;")
+ tid
+ name))
-(define (subject-pref name start limit)
+(define (subject-list tid)
+ (query (map-rows car)
+ (sql db "SELECT name FROM subject WHERE topic_id=? ORDER BY name;")
+ tid))
+
+(define (subject-pref tid name)
(query fetch-rows
(sql db "SELECT object.name,val FROM pref
OUTER LEFT JOIN object ON object.id = obj_id
OUTER LEFT JOIN subject ON subject.id = sub_id
- WHERE subject.name=?
- ORDER BY object.name
- LIMIT ?,?;")
- name start limit))
+ WHERE subject.topic_id=? AND subject.name=?
+ ORDER BY object.name")
+ tid name))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data File Generation
@@ -274,10 +300,15 @@
("\"" . "\\\"")
("\\" . "\\\\")))
+(define valid-file-name-irregex
+ (sre->irregex '(+ (or alphanumeric "-" "_"))))
+(define (valid-file-name? name)
+ (irregex-match? valid-file-name-irregex name))
+
(define (json-escape raw-str)
(string-translate* raw-str json-escape-map))
-(define (subject-json name)
+(define (subject-json tid name)
(string-append
"{"
(string-intersperse
@@ -286,64 +317,80 @@
(json-escape (car row))
"\":"
(number->string (cadr row))))
- (subject-pref name 0 -1))
+ (subject-pref tid name))
",")
"}"))
-(define (all-json)
+(define (topic-json tid)
(string-append
"[[\""
- (string-intersperse (map json-escape (object-list)) "\",\"")
+ (string-intersperse (map json-escape (object-list tid)) "\",\"")
"\"],{"
(string-intersperse
(map
(lambda (name)
- (string-append "\"" (json-escape name) "\":" (subject-json name)))
- (subject-list))
+ (string-append "\""
+ (json-escape name)
+ "\":"
+ (subject-json tid name)))
+ (subject-list tid))
",")
"}]"))
+(define (generate-topic-json tid)
+ (let ((name (topic-file-name tid)))
+ (when (valid-file-name? name)
+ (with-output-to-file
+ (string-append
+ (get-config "json-prefix" "")
+ name
+ ".json")
+ (lambda () (write-string (topic-json tid)))))))
+
(define (generate-json)
- (with-output-to-file
- (string-append
- (get-config "json-prefix" "")
- "all.json")
- (lambda () (write-string (all-json)))))
+ (for-each generate-topic-json (topic-id-list)))
;;;;;;;;;;;;;;;;;;;;;
;; Database Updates
-(define-traced (new-object name)
- (if (or (zero? (string-length name))
- (query fetch-value
- (sql db "SELECT id FROM object WHERE name=?;")
- name))
+(define-traced (new-topic name)
+ (if (or (zero? (string-length name)) (topic-id name))
#f
(begin
- (exec (sql db "INSERT INTO object(topic_id,name) VALUES (1,?);") name)
+ (exec (sql db "INSERT INTO topic(name) VALUES (?);") name)
(let ((result (last-insert-rowid db)))
- (unless replaying? (generate-json))
+ (unless replaying? (generate-topic-json result))
result))))
-(define-traced (new-subject name)
- (if (or (zero? (string-length name))
- (query fetch-value
- (sql db "SELECT id FROM subject WHERE name=?;")
- name))
- #f
- (begin
- (exec (sql db "INSERT INTO subject(topic_id,name) VALUES (1,?);") name)
- (let ((result (last-insert-rowid db)))
- (unless replaying? (generate-json))
- result))))
+(define-traced (new-object topic name)
+ (let ((tid (writable-topic-id topic)))
+ (if (or (not tid) (zero? (string-length name)) (object-id tid name))
+ #f
+ (begin
+ (exec (sql db "INSERT INTO object(topic_id,name) VALUES (?,?);")
+ tid name)
+ (let ((result (last-insert-rowid db)))
+ (unless replaying? (generate-topic-json tid))
+ result)))))
+
+(define-traced (new-subject topic name)
+ (let ((tid (writable-topic-id topic)))
+ (if (or (not tid) (zero? (string-length name)) (subject-id tid name))
+ #f
+ (begin
+ (exec (sql db "INSERT INTO subject(topic_id,name) VALUES (?,?);")
+ tid name)
+ (let ((result (last-insert-rowid db)))
+ (unless replaying? (generate-topic-json tid))
+ result)))))
(define-half-traced (set-config key val)
(exec (sql db "INSERT OR REPLACE INTO config(key,val) VALUES (?,?);")
key
val))
-(define (set-pref sub-id object-name value)
- (let ((obj-id (object-id object-name)))
+(define (set-pref tid sub-id object-name value)
+ (let ((obj-id (object-id tid object-name)))
(if obj-id
(begin
(exec (sql db "INSERT OR REPLACE INTO pref(sub_id,obj_id,val)
@@ -354,15 +401,16 @@
(last-insert-rowid db))
#f)))
-(define-traced (set-subject-pref subject-name alist)
- (let ((sub-id (subject-id subject-name)))
+(define-traced (set-subject-pref topic-name subject-name alist)
+ (let* ((tid (writable-topic-id topic-name))
+ (sub-id (if tid (subject-id tid subject-name) #f)))
(if sub-id
(let ((result
(map
(lambda (pair)
- (set-pref sub-id (car pair) (string->number (cdr pair))))
+ (set-pref tid sub-id (car pair) (string->number (cdr pair))))
alist)))
- (unless replaying? (generate-json))
+ (unless replaying? (generate-topic-json tid))
result)
#f)))
@@ -404,11 +452,22 @@
(lambda () (cmd-sleep) . body))
cmd-list)))))
-(defcmd new-object
+(defcmd new-topic
(let* ((data (read-urlencoded-request-data (current-request)))
(name (alist-ref 'name data eq? #f)))
(if name
- (let ((result (with-db (new-object name))))
+ (let ((result (with-db (new-topic name))))
+ (if result
+ (send-status 'ok)
+ (send-status 'conflict "Name already exists")))
+ (send-status 'bad-request "Missing parameter"))))
+
+(defcmd new-object
+ (let* ((data (read-urlencoded-request-data (current-request)))
+ (topic (alist-ref 'topic data eq? #f))
+ (name (alist-ref 'name data eq? #f)))
+ (if name
+ (let ((result (with-db (new-object topic name))))
(if result
(send-status 'ok)
(send-status 'conflict "Name already exists")))
@@ -416,20 +475,24 @@
(defcmd new-subject
(let* ((data (read-urlencoded-request-data (current-request)))
- (name (alist-ref 'name data eq? #f)))
+ (topic (alist-ref 'topic data eq? #f))
+ (name (alist-ref 'name data eq? #f)))
(if name
- (let ((result (with-db (new-subject name))))
+ (let ((result (with-db (new-subject topic name))))
(if result
(send-status 'ok)
(send-status 'conflict "Name already exists")))
(send-status 'bad-request "Missing parameter"))))
(defcmd set-pref
- (let* ((data (read-urlencoded-request-data (current-request))))
+ (let* ((all-data (read-urlencoded-request-data (current-request)))
+ (topic (if (eq? (caar all-data) 'topic) (cdar all-data) #f))
+ (data (if topic (cdr all-data) all-data)))
(if (eq? (caar data) 'sub)
(begin
(with-db
(set-subject-pref
+ topic
(cdar data)
(map
(lambda (pair) (cons (symbol->string (car pair)) (cdr pair)))
diff --git a/test/run.sh b/test/run.sh
@@ -24,7 +24,7 @@ fi
: "${TEST_DIR:=$(dirname "$0")}"
: "${TMP_DIR:=/tmp}"
-TO_CLEAN="test-all.json"
+TO_CLEAN="test-default.json"
trap 'rm -f ${TO_CLEAN}' EXIT
@@ -45,10 +45,10 @@ echo -n "" >|"${TEST_TRACE}"
"$@" :memory: "${TEST_TRACE}" "${TEST_DIR}/test-1.scm"
sed '/; 2[0-9][0-9][0-9]-/d;$s/$/\n(generate-json)\n(exit)/' "${TEST_TRACE}" \
| diff -u "${TEST_DIR}/test-1.scm" -
-diff -u "${TEST_DIR}/test-1.json" test-all.json
+diff -u "${TEST_DIR}/test-1.json" test-default.json
-#################
-## Test 2: HTTP
+####################################
+## Test 2: HTTP with default topic
"$@" "${TEST_DB}" "${TEST_TRACE}" "${TEST_DIR}/test-2.scm" &
SRV_PID=$!
@@ -58,35 +58,35 @@ trap 'rm -f ${TO_CLEAN}; kill ${SRV_PID}' EXIT
sleep 1
curl -s -d 'name=foo' 'http://localhost:9090/new-subject' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-01.json" test-all.json
+diff -u "${TEST_DIR}/test-2-01.json" test-default.json
curl -s -d 'name=01' 'http://localhost:9090/new-object' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-02.json" test-all.json
+diff -u "${TEST_DIR}/test-2-02.json" test-default.json
curl -s -d 'name=03' 'http://localhost:9090/new-object' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-03.json" test-all.json
+diff -u "${TEST_DIR}/test-2-03.json" test-default.json
curl -s -d 'name=bar' 'http://localhost:9090/new-subject' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-04.json" test-all.json
+diff -u "${TEST_DIR}/test-2-04.json" test-default.json
curl -s -d 'sub=bar' -d '01=3' -d '04=4' \
'http://localhost:9090/bin/set-pref' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-05.json" test-all.json
+diff -u "${TEST_DIR}/test-2-05.json" test-default.json
curl -s -d 'name=02' 'http://localhost:9090/do/new-object' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-06.json" test-all.json
+diff -u "${TEST_DIR}/test-2-06.json" test-default.json
curl -s -d 'name=bar' 'http://localhost:9090/new-subject' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-06.json" test-all.json
+diff -u "${TEST_DIR}/test-2-06.json" test-default.json
curl -s -d 'name=04' 'http://localhost:9090/new-object' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-07.json" test-all.json
+diff -u "${TEST_DIR}/test-2-07.json" test-default.json
curl -s -d 'sub=meow' -d '04=2' -d '01=4' \
'http://localhost:9090/set-pref' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-07.json" test-all.json
+diff -u "${TEST_DIR}/test-2-07.json" test-default.json
curl -s -d 'name=meow' 'http://localhost:9090/new-subject' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-08.json" test-all.json
+diff -u "${TEST_DIR}/test-2-08.json" test-default.json
curl -s -d 'sub=foo' -d '01=1' -d '04=2' -d '01=4' \
'http://localhost:9090/set-pref' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-09.json" test-all.json
+diff -u "${TEST_DIR}/test-2-09.json" test-default.json
curl -s -d 'sub=bar' -d '01=0' \
'http://localhost:9090/set-pref' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-10.json" test-all.json
+diff -u "${TEST_DIR}/test-2-10.json" test-default.json
curl -s -d 'name=04' 'http://localhost:9090/new-object' >>"${TEST_TRACE}"
-diff -u "${TEST_DIR}/test-2-10.json" test-all.json
+diff -u "${TEST_DIR}/test-2-10.json" test-default.json
kill "${SRV_PID}"
trap 'rm -f ${TO_CLEAN}' EXIT
@@ -100,5 +100,4 @@ cp -f "${TEST_DIR}/test-2-v1.sqlite" "${TEST_DB}"
rm -f "${TEST_DB}-shm" "${TEST_DB}-wal"
"$@" "${TEST_DB}" "${TEST_TRACE}" "${TEST_DIR}/test-3.scm"
sqlite3 "${TEST_DB}" .dump \
- | sed "/'default_topic'/d;s/'default'/'TODO'/" \
| diff -u "${TEST_DIR}/test-2-dump.sql" -
diff --git a/test/test-1.scm b/test/test-1.scm
@@ -1,24 +1,26 @@
-(new-subject "foo")
+(new-topic "default")
; -> 1
-(new-subject "bar")
+(new-subject "default" "foo")
+; -> 1
+(new-subject "default" "bar")
; -> 2
-(new-subject "meow")
+(new-subject "default" "meow")
; -> 3
-(new-object "01")
+(new-object "default" "01")
; -> 1
-(new-object "02")
+(new-object "default" "02")
; -> 2
-(new-object "03")
+(new-object "default" "03")
; -> 3
-(new-object "04")
+(new-object "default" "04")
; -> 4
-(new-object "05")
+(new-object "default" "05")
; -> 5
-(set-subject-pref "bar" '(("01" . "4")))
+(set-subject-pref "default" "bar" '(("01" . "4")))
; -> (1)
-(set-subject-pref "foo" '(("01" . "2") ("02" . "4") ("03" . "1") ("04" . "3") ("05" . "5")))
+(set-subject-pref "default" "foo" '(("01" . "2") ("02" . "4") ("03" . "1") ("04" . "3") ("05" . "5")))
; -> (2 3 4 5 6)
-(set-subject-pref "meow" '())
+(set-subject-pref "default" "meow" '())
; -> ()
(set-config "json-prefix" "test-")
(set-config "server-port" 9090)
diff --git a/test/test-2-dump.sql b/test/test-2-dump.sql
@@ -3,10 +3,11 @@ BEGIN TRANSACTION;
CREATE TABLE config (key TEXT PRIMARY KEY, val ANY);
INSERT INTO config VALUES('json-prefix','test-');
INSERT INTO config VALUES('server-port',9090);
+INSERT INTO config VALUES('default_topic','default');
CREATE TABLE topic (id INTEGER PRIMARY KEY,
name TEXT NOT NULL,
closed INTEGER NOT NULL DEFAULT 0);
-INSERT INTO topic VALUES(1,'TODO',0);
+INSERT INTO topic VALUES(1,'default',0);
CREATE TABLE subject (id INTEGER PRIMARY KEY,
topic_id NOT NULL REFERENCES topic(id)
ON UPDATE CASCADE ON DELETE CASCADE,
diff --git a/test/test-2.scm b/test/test-2.scm
@@ -1,2 +1,4 @@
(set-config "json-prefix" "test-")
(set-config "server-port" 9090)
+(set-config "default_topic" "default")
+(new-topic "default")
