commit 961af9c49502fee5997c031b6d707d2ceddde4ac
parent da0f04fa645b35e6aeabe740cce8f6018506dffa
Author: Natasha Kerensikova <natgh@instinctive.eu>
Date: Mon, 8 Jan 2024 18:52:57 +0000
First deployed version
Diffstat:
8 files changed, 878 insertions(+), 0 deletions(-)
diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob
@@ -0,0 +1 @@
+git/
diff --git a/LICENSE b/LICENSE
@@ -0,0 +1,13 @@
+Copyright (c) 2024, Natacha Porté
+
+Permission to use, copy, modify, and distribute this software for any
+purpose with or without fee is hereby granted, provided that the above
+copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
diff --git a/sample-assets/edit.html b/sample-assets/edit.html
@@ -0,0 +1,280 @@
+<!DOCTYPE html>
+<html lang="fr">
+ <head>
+ <meta charset="utf-8" />
+ <meta name="viewport" content="width=device-width">
+ <title>Plannification JDR</title>
+ <link rel="stylesheet" type="text/css" href="style.css" />
+ <script>
+var val_class=["val0","val1","val2","val3","val4","val5"];
+var val_text=["?","−−","−","0","+","++"];
+var all_data=null;
+var radio_map=new Map();
+var spinner_map=new Map();
+var subject=null;
+var sent=null;
+var outbox=new Map();
+var sender=null;
+var base_timeout=2000;
+var retry_timeout=base_timeout;
+
+window.onerror = function(msg, url, line) {
+ var item = document.createElement("li");
+ item.appendChild(document.createTextNode(url + "@" + line + ": " + msg));
+ document.getElementById("error-log").appendChild(item);
+ document.getElementById("error-div").style = "display:block";
+ item.scrollIntoView();
+}
+
+async function send(){
+ var req_body = "sub=" + encodeURIComponent(subject);
+ for (const [key, value] of outbox) {
+ req_body += "&" + encodeURIComponent(key) + "=" + encodeURIComponent(value);
+ }
+ sent = outbox;
+ outbox = new Map();
+ const response = await fetch("do/set-pref", {
+ method: "POST",
+ cache: "no-store",
+ headers: { "Content-Type": "application/x-www-form-urlencoded" },
+ body: req_body,
+ });
+ var to = base_timeout;
+ if (response.ok) {
+ for (const [key, value] of sent) {
+ if (!outbox.has(key)) {
+ spinner_map.get(key).style = "display:none";
+ }
+ }
+ retry_timeout = base_timeout;
+ } else {
+ for (const [key, value] of sent) {
+ if (!outbox.has(key)) {
+ outbox.set(key, value);
+ }
+ }
+ to = retry_timeout;
+ retry_timeout *= 2;
+ }
+ sent = null;
+ if (outbox.size) {
+ sender = setTimeout(send, to);
+ }
+}
+
+function radio_click(name, value){
+ spinner_map.get(name).style = "display:inline";
+ outbox.set(name, value);
+ if (!sent) {
+ if (sender) {
+ clearTimeout(sender);
+ }
+ sender = setTimeout(send, 2000);
+ }
+}
+
+function new_table_line(name) {
+ var line = document.createElement("tr");
+
+ var cell = document.createElement("td");
+ cell.className = "date";
+ cell.appendChild(document.createTextNode(name));
+ line.appendChild(cell);
+
+ var radios = new Array;
+
+ for (const i in val_text) {
+ cell = document.createElement("td");
+ var elt1 = document.createElement("label");
+ var elt2 = document.createElement("input");
+ elt2.type = "radio";
+ elt2.name = name;
+ elt2.value = i;
+ elt2.onchange = function() { radio_click(name, i) };
+ radios[i] = elt2;
+ elt1.appendChild(elt2);
+ elt1.appendChild(document.createTextNode(val_text[i]));
+ elt1.className = val_class[i];
+ cell.appendChild(elt1);
+ if (i > 0) {
+ line.appendChild(cell);
+ } else {
+ line.insertBefore(cell, line.childNodes[0]);
+ }
+ }
+ radio_map.set(name, radios);
+
+ cell = document.createElement("td");
+ elt1 = document.createElement("img");
+ elt1.className = "spinner";
+ elt1.src = "spinner.svg";
+ elt1.style = "display:none";
+ spinner_map.set(name, elt1);
+ cell.appendChild(elt1);
+ line.appendChild(cell);
+
+ return line;
+}
+
+function activate_subject(){
+ document.getElementById("cur-subject").textContent = subject;
+
+ if (!subject) {
+ document.getElementById("change-form").style = "display:block";
+ document.getElementById("cur-subject-p").style = "display:none";
+ document.getElementById("pref-form").style = "display:none";
+ document.getElementById("new-subject").style = "display:none";
+ return false;
+ } else if (subject in all_data[1]) {
+ for (const [name, radios] of radio_map) {
+ for (const i in val_text) {
+ radios[i].checked = (i == (all_data[1][subject][name] || 0));
+ }
+ }
+
+ document.getElementById("change-form").style = "display:none";
+ document.getElementById("cur-subject-p").style = "display:block";
+ document.getElementById("pref-form").style = "display:block";
+ document.getElementById("new-subject").style = "display:none";
+ return false;
+ } else {
+ document.getElementById("change-form").style = "display:none";
+ document.getElementById("cur-subject-p").style = "display:block";
+ document.getElementById("pref-form").style = "display:none";
+ document.getElementById("new-subject").style = "display:block";
+ return true;
+ }
+}
+
+async function reload_data(){
+ document.getElementById("reload-spinner").style = "display:inline";
+ const response = await fetch("all.json", { cache: "no-cache" });
+ all_data = await response.json();
+
+ var holder = document.getElementById("pref-table-body");
+ while (holder.childNodes.length > 0) {
+ holder.removeChild(holder.childNodes[0]);
+ }
+
+ var line = null;
+ var cell = null;
+ var elt1 = null;
+ var elt2 = null;
+
+ radio_map.clear();
+ spinner_map.clear();
+
+ for (const name of all_data[0]) {
+ holder.appendChild(new_table_line(name));
+ }
+
+ subject = localStorage.getItem("subject");
+ activate_subject();
+
+ document.getElementById("reload-spinner").style = "display:none";
+}
+
+async function create_subject(){
+ document.getElementById("create-spinner").style = "display:inline";
+ const response = await fetch("do/new-subject", {
+ method: "POST",
+ cache: "no-store",
+ headers: { "Content-Type": "application/x-www-form-urlencoded" },
+ body: "name=" + encodeURIComponent(subject),
+ });
+ document.getElementById("create-spinner").style = "display:none";
+
+ if (response.ok) {
+ document.getElementById("new-subject").style = "display:none";
+ reload_data();
+ }
+}
+
+function set_subject(){
+ subject = document.getElementById("set-subject").value;
+ localStorage.setItem("subject", subject);
+ activate_subject();
+ return false;
+}
+
+function reset_subject(){
+ document.getElementById("change-form").style = "display:block";
+ document.getElementById("cur-subject-p").style = "display:none";
+}
+ </script>
+ </head>
+ <body onload="reload_data()">
+ <h1>Plannification JDR</h1>
+ <p>
+ <a href="view.html">Retour à la vue d'ensemble</a>
+ <input name="test" value="Recharger" type="button" onclick="reload_data()">
+ <img id="reload-spinner" class="spinner" src="spinner.svg" style="display: none">
+ </p>
+ <table style="margin: 1em">
+ <tr><td colspan="2" style="text-align: left"><strong>Symboles des préférences :</strong></td></tr>
+ <tr>
+ <td class="val5">++</td>
+ <td style="text-align: left">j'ai très envie de jouer ce soir-là, je vais m'ennuyer autrement</td>
+ </tr>
+ <tr>
+ <td class="val4">+</td>
+ <td style="text-align: left">j'aimerais bien jouer ce soir-là</td>
+ </tr>
+ <tr>
+ <td class="val3">0</td>
+ <td style="text-align: left">je veux bien jouer mais ça ne me dérange pas de ne pas jouer</td>
+ </tr>
+ <tr>
+ <td class="val2">−</td>
+ <td style="text-align: left">je peux jouer ce soir-là mais ça ne m'arrange pas vraiment</td>
+ </tr>
+ <tr>
+ <td class="val1">−−</td>
+ <td style="text-align: left">je ne suis pas du tout disponible ce soir-là</td>
+ </tr>
+ <tr>
+ <td class="val0">?</td>
+ <td style="text-align: left">je ne veux pas me prononcer</td>
+ </tr>
+ </table>
+ <form id="change-form" onsubmit="return set_subject()">
+ <p>
+ <label>
+ Pseudo : <input name="subject" id="set-subject" value="" type="text">
+ </label>
+ <input name="submit" value="Valider" type="submit">
+ </p>
+ </form>
+ <p id="cur-subject-p" style="display:none">
+ Préférences pour <strong id=cur-subject></strong>
+ <input name="change-subject" value="Changer" type="button" onclick="reset_subject()">
+ </p>
+ <form id="pref-form" style="display:block">
+ <table>
+ <thead>
+ <tr id="table-header">
+ <th></th>
+ <th>Date</th>
+ <th colspan="5">Préférence</th>
+ <th></th>
+ </tr>
+ </thead>
+ <tbody id="pref-table-body">
+ <tr>
+ <td colspan="8">
+ <img src="spinner.svg" with="5em" height"5em">
+ </td>
+ </tr>
+ </tbody>
+ </table>
+ </form>
+ <p id="new-subject" style="display:none">
+ <input name="submit" type="button" value="Créer" onclick="create_subject()">
+ <img id="create-spinner" class="spinner" src="spinner.svg" style="display: none">
+ </p>
+ <div id="error-div" style="display:none">
+ <p>Error log:</p>
+ <ul id="error-log"><ul>
+ </div>
+ </body>
+</html>
diff --git a/sample-assets/spinner.svg b/sample-assets/spinner.svg
@@ -0,0 +1,19 @@
+<?xml version="1.0" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" viewBox="0 0 40 40">
+ <circle cx="20" cy="20" r="18"
+ stroke-width="4"
+ fill="transparent"
+ stroke="#7f7f7f"
+ stroke-linecap="round"
+ stroke-dasharray="13.1 100">
+ <animate attributeName="stroke-dashoffset"
+ values="0;113.1;226.2;282.75;339.3;395.85;452.4"
+ dur="6s"
+ repeatCount="indefinite" />
+ <animate attributeName="stroke-dasharray"
+ values="0 113.1;113.1 0;56.55 56.55;0 113.1"
+ dur="6s"
+ repeatCount="indefinite" />
+ </circle>
+</svg>
diff --git a/sample-assets/style-solarized.sed b/sample-assets/style-solarized.sed
@@ -0,0 +1,12 @@
+s/$BG_0_DARK/#002b36/g
+s/$FG_0_DARK/#839496/g
+s/$BG_1_DARK/#073642/g
+s/$FG_1_DARK/#93a1a1/g
+s/$EMPH_DARK/#268bd2/g
+s/$IMPORTANT_DARK/#cb4b16/g
+s/$BG_0_LIGHT/#fdf6e3/g
+s/$FG_0_LIGHT/#657b83/g
+s/$BG_1_LIGHT/#eee8d5/g
+s/$FG_1_LIGHT/#586e75/g
+s/$EMPH_LIGHT/#268bd2/g
+s/$IMPORTANT_LIGHT/#cb4b16/g
diff --git a/sample-assets/style-tmpl.css b/sample-assets/style-tmpl.css
@@ -0,0 +1,84 @@
+.spinner {
+ display: inline;
+ width: 1em;
+ height: 1em;
+ vertical-align: middle;
+}
+
+button, input, select, textarea {
+ font-family: inherit;
+ font-size: 100%;
+}
+
+table {
+ margin: 1em auto;
+ text-align: center;
+}
+
+td {
+ padding: 0.2ex 1ex;
+}
+
+th {
+ position: sticky;
+ top: 2px;
+}
+
+td.date {
+ position:sticky;
+ left: 2px;
+}
+
+.val0 {
+ font-size: 80%;
+}
+
+.val1 {
+ font-weight: bold;
+}
+
+.val5 {
+ font-weight: bold;
+}
+
+body {
+ background: $BG_0_LIGHT;
+ color: $FG_0_LIGHT;
+}
+
+h1, h2 {
+ color: $FG_1_LIGHT;
+}
+
+button, input, select, textarea {
+ background: $BG_1_LIGHT;
+ color: $EMPH_LIGHT;
+}
+
+input[type=button], input[type=submit] {
+ color: $IMPORTANT_LIGHT;
+}
+
+@media (prefers-color-scheme: dark) {
+ #spinnercover, body {
+ background: $BG_0_DARK;
+ color: $FG_0_DARK;
+ }
+
+ h1, h2 {
+ color: $FG_1_DARK;
+ }
+
+ button, input, select, textarea {
+ background: $BG_1_DARK;
+ color: $EMPH_DARK;
+ }
+
+ input[type=button], input[type=submit] {
+ color: $IMPORTANT_DARK;
+ }
+
+ svg.spinner circle {
+ stroke: $FG_1_DARK;
+ }
+}
diff --git a/sample-assets/view.html b/sample-assets/view.html
@@ -0,0 +1,135 @@
+<!DOCTYPE html>
+<html lang="fr">
+ <head>
+ <meta charset="utf-8" />
+ <meta name="viewport" content="width=device-width">
+ <title>Plannification JDR</title>
+ <link rel="stylesheet" type="text/css" href="style.css" />
+ <script>
+var val_class=["val0","val1","val2","val3","val4","val5"];
+var val_text=["?","−−","−","0","+","++"];
+
+window.onerror = function(msg, url, line) {
+ var item = document.createElement("li");
+ item.appendChild(document.createTextNode(url + "@" + line + ": " + msg));
+ document.getElementById("error-log").appendChild(item);
+ document.getElementById("error-div").style = "display:block";
+ item.scrollIntoView();
+}
+
+function append_cell(line, type, cl, text) {
+ var elt = document.createElement(type);
+ elt.className = cl;
+ elt.appendChild(document.createTextNode(text));
+ line.appendChild(elt);
+}
+
+function set_table(data) {
+ var holder = document.getElementById("pref-table");
+ while (holder.childNodes.length > 0) {
+ holder.removeChild(holder.childNodes[0]);
+ }
+ var line = document.createElement("tr");
+
+ append_cell(line, "th", "", "Date");
+ for (const name in data[1]) {
+ var elt = document.createElement("th");
+ var link = document.createElement("a");
+ link.href = "edit.html";
+ link.onclick = function() { localStorage.setItem("subject", name); };
+ link.appendChild(document.createTextNode(name));
+ elt.appendChild(link);
+ line.appendChild(elt);
+ }
+ holder.appendChild(line);
+
+ for (const name of data[0]) {
+ line = document.createElement("tr");
+ append_cell(line, "td", "date", name);
+ for (const [tmp, prefs] of Object.entries(data[1])) {
+ var v = prefs[name] || 0;
+ append_cell(line, "td", val_class[v], val_text[v]);
+ }
+ holder.appendChild(line);
+ }
+}
+
+async function reload_table(){
+ document.getElementById("reload-spinner").style = "display:inline";
+ const response = await fetch("all.json", { cache: "no-cache" });
+ const data = await response.json();
+ set_table(data);
+ document.getElementById("reload-spinner").style = "display:none";
+}
+
+async function create_subject(name){
+ document.getElementById("create-spinner").style = "display:inline";
+ const response = await fetch("do/new-subject", {
+ method: "POST",
+ cache: "no-store",
+ headers: { "Content-Type": "application/x-www-form-urlencoded" },
+ body: "name=" + encodeURIComponent(name),
+ });
+ if (response.ok) {
+ reload_table();
+ document.getElementById("create-spinner").style = "display:none";
+ }
+
+ return false;
+}
+
+function new_subject(){
+ create_subject(document.getElementById("new-subject").value);
+ document.getElementById("new-subject").value = "";
+ return false;
+}
+ </script>
+ </head>
+ <body onload="reload_table()">
+ <h1>Plannification JDR</h1>
+ <p>Bienvenue sur la page d'organisation des soirés JdR. Cette page présente la vue d'ensemble des préférences. Les préférences peuvent être changées colonne par colonne, en suivant le lien en en-tête de la table. Une nouvelle colonne peut être créée au moyen du formulaire ci-dessous.</p>
+ <form onsubmit="return new_subject()">
+ <p>Nouveau pseudo :
+ <input type="text" name="name" id="new-subject" placeholder="XXX">
+ <input type="submit" name="submit" value="Créer">
+ <img id="create-spinner" class="spinner" src="spinner.svg" style="display: none">
+ </p>
+ </form>
+ <table style="margin: 1em">
+ <tr><td colspan="2" style="text-align: left"><strong>Symboles des préférences :</strong></td></tr>
+ <tr>
+ <td class="val5">++</td>
+ <td style="text-align: left">j'ai très envie de jouer ce soir-là, je vais m'ennuyer autrement</td>
+ </tr>
+ <tr>
+ <td class="val4">+</td>
+ <td style="text-align: left">j'aimerais bien jouer ce soir-là</td>
+ </tr>
+ <tr>
+ <td class="val3">0</td>
+ <td style="text-align: left">je veux bien jouer mais ça ne me dérange pas de ne pas jouer</td>
+ </tr>
+ <tr>
+ <td class="val2">−</td>
+ <td style="text-align: left">je peux jouer ce soir-là mais ça ne m'arrange pas vraiment</td>
+ </tr>
+ <tr>
+ <td class="val1">−−</td>
+ <td style="text-align: left">je ne suis pas du tout disponible ce soir-là</td>
+ </tr>
+ <tr>
+ <td class="val0">?</td>
+ <td style="text-align: left">je ne veux pas me prononcer</td>
+ </tr>
+ </table>
+ <p><input name="test" value="Recharger" type="button" onclick="reload_table()"> <img id="reload-spinner" class="spinner" src="spinner.svg" style="display: none"></p>
+ <table id="pref-table">
+ <tr><th>Chargement</th></tr>
+ <tr><td><img src="spinner.svg" style="display: inline; width: 5em; height: 5em"></td></tr>
+ </table>
+ <div id="error-div" style="display:none">
+ <p>Error log:</p>
+ <ul id="error-log"><ul>
+ </div>
+ </body>
+</html>
diff --git a/src/pref-matrix.scm b/src/pref-matrix.scm
@@ -0,0 +1,334 @@
+; Copyright (c) 2024, Natacha Porté
+;
+; Permission to use, copy, modify, and distribute this software for any
+; purpose with or without fee is hereby granted, provided that the above
+; copyright notice and this permission notice appear in all copies.
+;
+; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+(import (chicken file)
+ (chicken io)
+ (chicken irregex)
+ (chicken process-context)
+ (chicken string)
+ (chicken time)
+ (chicken time posix)
+ intarweb
+ spiffy
+ sql-de-lite
+ srfi-1
+ srfi-18
+ uri-common)
+
+(define replaying? #f)
+
+(define (command-line-argument k default-value)
+ (let ((args (command-line-arguments)))
+ (if (>= (length args) k)
+ (list-ref args (sub1 k))
+ default-value)))
+
+(define (rfc-3339-local seconds)
+ (let ((time-str (time->string (seconds->local-time seconds) "%FT%T%z")))
+ (assert (= 24 (string-length time-str)))
+ (if (equal? "0000" (substring time-str 20))
+ (string-append (substring time-str 0 19) "Z")
+ (string-append (substring time-str 0 22)
+ ":"
+ (substring time-str 22)))))
+
+;;;;;;;;;;;;;
+;; Tracing
+
+(define trace-port
+ (let ((name (command-line-argument 2 #f)))
+ (cond ((not name) #f)
+ ((equal? name "-") (current-output-port))
+ (else (open-output-file name #:text #:append)))))
+
+(define (trace-comment text)
+ (write-line (string-append "; " text) trace-port))
+
+(define trace-prev-time 0)
+(define (trace-time)
+ (let ((sec (current-seconds)))
+ (unless (= sec trace-prev-time)
+ (trace-comment (rfc-3339-local sec))
+ (set! trace-prev-time sec))))
+
+(define (trace-call obj)
+ (trace-time)
+ (write obj trace-port)
+ (newline trace-port)
+ (flush-output trace-port))
+
+(define (trace-result obj result)
+ (trace-time)
+ (write-string ";" 1 trace-port)
+; (write obj trace-port)
+ (write-string " -> " 4 trace-port)
+ (write result trace-port)
+ (newline trace-port)
+ (flush-output trace-port))
+
+(define-syntax define-half-traced
+ (syntax-rules ()
+ ((define-half-traced (name . args) . body)
+ (define (name . args)
+ (trace-call (list 'name . args))
+ . body))))
+
+(define-syntax define-traced
+ (syntax-rules ()
+ ((define-traced (name . args) . body)
+ (define (name . args)
+ (trace-call (list 'name . args))
+ (let ((result (begin . body)))
+ (trace-result (list 'name . args) result)
+ result)))))
+
+(unless trace-port
+ (set! trace-call (lambda (x) #f))
+ (set! trafe-comment (lambda (x) #f))
+ (set! trace-result (lambda (x y) #f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Database Creation/Migration
+
+(define db
+ (open-database (command-line-argument 1 "pref-matrix.sqlite")))
+
+(define (db-version)
+ (query fetch-value (sql db "PRAGMA user_version;")))
+
+(when (= 0 (db-version))
+ (for-each
+ (lambda (s) (exec (sql db s)))
+ (list "PRAGMA user_version = 1;"
+ "PRAGMA foreign_keys = ON;"
+ "PRAGMA journal_mode = wal;"
+ "PRAGMA synchronous = normal;"
+ "CREATE TABLE config (key TEXT PRIMARY KEY, val);"
+ "CREATE TABLE subject (id INTEGER PRIMARY KEY, name TEXT NOT NULL);"
+ "CREATE TABLE object (id INTEGER PRIMARY KEY, name TEXT NOT NULL);"
+ "CREATE TABLE pref (id INTEGER PRIMARY KEY,
+ sub_id REFERENCES subject(id)
+ ON UPDATE CASCADE ON DELETE CASCADE,
+ obj_id REFERENCES object(id)
+ ON UPDATE CASCADE ON DELETE CASCADE,
+ val INTEGER NOT NULL DEFAULT 0);"
+ "CREATE UNIQUE INDEX sub_name ON subject(name);"
+ "CREATE UNIQUE INDEX obj_name ON object(name);"
+ "CREATE UNIQUE INDEX sub_obj ON pref(sub_id,obj_id);")))
+
+(assert (= 1 (db-version)))
+
+;;;;;;;;;;;;;;;;;;;
+;; Database Query
+
+(define (get-config key default-value)
+ (let ((result (query fetch-value
+ (sql db "SELECT val FROM config WHERE key=?;")
+ key)))
+ (if result result default-value)))
+
+(define (object-id name)
+ (query fetch-value (sql db "SELECT id FROM object WHERE name=?;") name))
+
+(define (object-list)
+ (query (map-rows car) (sql db "SELECT name FROM object ORDER BY name;")))
+
+(define (subject-id name)
+ (query fetch-value (sql db "SELECT id FROM subject WHERE name=?;") name))
+
+(define (subject-list)
+ (query (map-rows car) (sql db "SELECT name FROM subject ORDER BY name;")))
+
+(define (subject-pref name start limit)
+ (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))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data File Generation
+
+(define (subject-json name)
+ (string-append
+ "{"
+ (string-intersperse
+ (map (lambda (row)
+ (string-append "\"" (car row) "\":" (number->string (cadr row))))
+ (subject-pref name 0 -1))
+ ",")
+ "}"))
+
+(define (all-json)
+ (string-append
+ "[[\""
+ (string-intersperse (object-list) "\",\"")
+ "\"],{"
+ (string-intersperse
+ (map
+ (lambda (name)
+ (string-append "\"" name "\":" (subject-json name)))
+ (subject-list))
+ ",")
+ "}]"))
+
+(define (generate-json)
+ (with-output-to-file
+ (string-append
+ (get-config "json-prefix" "")
+ "all.json")
+ (lambda () (write-string (all-json)))))
+
+;;;;;;;;;;;;;;;;;;;;;
+;; 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))
+ #f
+ (begin
+ (exec (sql db "INSERT INTO object(name) VALUES (?);") name)
+ (let ((result (last-insert-rowid db)))
+ (unless replaying? (generate-json))
+ 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(name) VALUES (?);") name)
+ (let ((result (last-insert-rowid db)))
+ (unless replaying? (generate-json))
+ result))))
+
+(define-half-traced (set-config key val)
+ (exec (sql db "INSERT OR REPLACE INTO config(key,val) VALUES (?,?);")
+ key
+ val))
+
+; (define-half-traced (set-pref subject-name object-name value)
+; (exec (sql db "INSERT OR REPLACE INTO pref(sub_id,obj_id,val) VALUES
+; ((SELECT id FROM subject WHERE name=?),
+; (SELECT id FROM object WHERE name=?),
+; ?);")
+; subject-name object-name value))
+
+(define-half-traced (set-subject-pref subject-name alist)
+ (with-transaction db
+ (lambda ()
+ (let ((sub-id (subject-id subject-name)))
+ (for-each
+ (lambda (pair)
+ (exec (sql db "INSERT OR REPLACE INTO pref(sub_id,obj_id,val)
+ VALUES (?,(SELECT id FROM object WHERE name=?),?);")
+ sub-id
+ (if (string? (car pair))
+ (car pair)
+ (symbol->string (car pair)))
+ (string->number (cdr pair))))
+ alist))))
+ (unless replaying? (generate-json)))
+
+;;;;;;;;;;;
+;; Replay
+
+(let ((replay-str (command-line-argument 3 #f)))
+ (when replay-str
+ (set! replaying? #t)
+ (load replay-str)
+ (generate-json)
+ (set! replaying? #f)))
+
+;;;;;;;;;;;;;;;;;;;
+;; Database Mutex
+
+(define db-mutex
+ (make-mutex "sqlite-db"))
+
+(define-syntax with-mutex
+ (syntax-rules ()
+ ((with-mutex m . op)
+ (dynamic-wind
+ (lambda () (mutex-lock! m))
+ (lambda () . op)
+ (lambda () (mutex-unlock! m))))))
+
+;;;;;;;;;;;;
+;; Web API
+
+(define cmd-list '())
+(define-syntax defcmd
+ (syntax-rules ()
+ ((defcmd name . body)
+ (set! cmd-list (cons (cons (symbol->string 'name) (lambda () . body))
+ cmd-list)))))
+
+(defcmd new-object
+ (let* ((data (read-urlencoded-request-data (current-request)))
+ (name (alist-ref 'name data eq? #f)))
+ (if name
+ (let ((result (with-mutex db-mutex (new-object name))))
+ (if result
+ (send-status 'ok)
+ (send-status 'conflict "Name already exists")))
+ (send-status 'bad-request "Missing parameter"))))
+
+(defcmd new-subject
+ (let* ((data (read-urlencoded-request-data (current-request)))
+ (name (alist-ref 'name data eq? #f)))
+ (if name
+ (let ((result (with-mutex db-mutex (new-subject 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))))
+ (if (eq? (caar data) 'sub)
+ (begin
+ (with-mutex db-mutex
+ (set-subject-pref
+ (cdar data)
+ (map
+ (lambda (pair) (cons (symbol->string (car pair)) (cdr pair)))
+ (cdr data))))
+ (send-status 'ok))
+ (send-status 'bad-request "Malformed request"))))
+
+;;;;;;;;;;;;;;;
+;; Web Server
+
+(define (web-process continue)
+ (cond ((not (eq? (request-method (current-request)) 'POST))
+ (send-status 'method-not-allowed "This is a POST handler"))
+ ((not (request-has-message-body? (current-request)))
+ (send-status 'bad-request "Needs a body to process"))
+ (else
+ ((alist-ref (last (uri-path (request-uri (current-request))))
+ cmd-list
+ equal?
+ continue)))))
+
+(server-port (get-config "server-port" 8080))
+(vhost-map `((".*" . ,web-process)))
+(start-server)
