diff --git a/AndroidManifest.xml b/android/AndroidManifest.xml similarity index 100% rename from AndroidManifest.xml rename to android/AndroidManifest.xml diff --git a/README.md b/android/README.md similarity index 100% rename from README.md rename to android/README.md diff --git a/ant.properties b/android/ant.properties similarity index 100% rename from ant.properties rename to android/ant.properties diff --git a/assets/eavdb.scm b/android/assets/eavdb.scm similarity index 100% rename from assets/eavdb.scm rename to android/assets/eavdb.scm diff --git a/assets/fonts/DejaVuSans.ttf b/android/assets/fonts/DejaVuSans.ttf similarity index 100% rename from assets/fonts/DejaVuSans.ttf rename to android/assets/fonts/DejaVuSans.ttf diff --git a/assets/fonts/DejaVuSerif.ttf b/android/assets/fonts/DejaVuSerif.ttf similarity index 100% rename from assets/fonts/DejaVuSerif.ttf rename to android/assets/fonts/DejaVuSerif.ttf diff --git a/assets/fonts/Ginger-Light.otf b/android/assets/fonts/Ginger-Light.otf similarity index 100% rename from assets/fonts/Ginger-Light.otf rename to android/assets/fonts/Ginger-Light.otf diff --git a/assets/fonts/Ginger-Regular.otf b/android/assets/fonts/Ginger-Regular.otf similarity index 100% rename from assets/fonts/Ginger-Regular.otf rename to android/assets/fonts/Ginger-Regular.otf diff --git a/assets/fonts/Pfennig.ttf b/android/assets/fonts/Pfennig.ttf similarity index 100% rename from assets/fonts/Pfennig.ttf rename to android/assets/fonts/Pfennig.ttf diff --git a/assets/fonts/RobotoCondensed-Regular.ttf b/android/assets/fonts/RobotoCondensed-Regular.ttf similarity index 100% rename from assets/fonts/RobotoCondensed-Regular.ttf rename to android/assets/fonts/RobotoCondensed-Regular.ttf diff --git a/assets/fonts/grobold.ttf b/android/assets/fonts/grobold.ttf similarity index 100% rename from assets/fonts/grobold.ttf rename to android/assets/fonts/grobold.ttf diff --git a/assets/fonts/grstylus.ttf b/android/assets/fonts/grstylus.ttf similarity index 100% rename from assets/fonts/grstylus.ttf rename to android/assets/fonts/grstylus.ttf diff --git a/assets/init.scm b/android/assets/init.scm similarity index 100% rename from assets/init.scm rename to android/assets/init.scm diff --git a/assets/json.scm b/android/assets/json.scm similarity index 100% rename from assets/json.scm rename to android/assets/json.scm diff --git a/assets/lib.scm b/android/assets/lib.scm similarity index 100% rename from assets/lib.scm rename to android/assets/lib.scm diff --git a/assets/starwisp.scm b/android/assets/starwisp.scm similarity index 100% rename from assets/starwisp.scm rename to android/assets/starwisp.scm diff --git a/assets/test.scm b/android/assets/test.scm similarity index 100% rename from assets/test.scm rename to android/assets/test.scm diff --git a/assets/testing.scm b/android/assets/testing.scm similarity index 100% rename from assets/testing.scm rename to android/assets/testing.scm diff --git a/assets/unit-tests.scm b/android/assets/unit-tests.scm similarity index 100% rename from assets/unit-tests.scm rename to android/assets/unit-tests.scm diff --git a/build.xml b/android/build.xml similarity index 100% rename from build.xml rename to android/build.xml diff --git a/gen/R.java.d b/android/gen/R.java.d similarity index 100% rename from gen/R.java.d rename to android/gen/R.java.d diff --git a/gen/foam/opensauces/BuildConfig.java b/android/gen/foam/opensauces/BuildConfig.java similarity index 100% rename from gen/foam/opensauces/BuildConfig.java rename to android/gen/foam/opensauces/BuildConfig.java diff --git a/gen/foam/opensauces/R.java b/android/gen/foam/opensauces/R.java similarity index 100% rename from gen/foam/opensauces/R.java rename to android/gen/foam/opensauces/R.java diff --git a/gen/foam/starwisp/R.java b/android/gen/foam/starwisp/R.java similarity index 100% rename from gen/foam/starwisp/R.java rename to android/gen/foam/starwisp/R.java diff --git a/local.properties b/android/local.properties similarity index 100% rename from local.properties rename to android/local.properties diff --git a/proguard-project.txt b/android/proguard-project.txt similarity index 100% rename from proguard-project.txt rename to android/proguard-project.txt diff --git a/project.properties b/android/project.properties similarity index 100% rename from project.properties rename to android/project.properties diff --git a/res/animator/card_flip_left_in.xml b/android/res/animator/card_flip_left_in.xml similarity index 100% rename from res/animator/card_flip_left_in.xml rename to android/res/animator/card_flip_left_in.xml diff --git a/res/animator/card_flip_left_out.xml b/android/res/animator/card_flip_left_out.xml similarity index 100% rename from res/animator/card_flip_left_out.xml rename to android/res/animator/card_flip_left_out.xml diff --git a/res/animator/card_flip_right_in.xml b/android/res/animator/card_flip_right_in.xml similarity index 100% rename from res/animator/card_flip_right_in.xml rename to android/res/animator/card_flip_right_in.xml diff --git a/res/animator/card_flip_right_out.xml b/android/res/animator/card_flip_right_out.xml similarity index 100% rename from res/animator/card_flip_right_out.xml rename to android/res/animator/card_flip_right_out.xml diff --git a/res/drawable-hdpi/ic_launcher.png b/android/res/drawable-hdpi/ic_launcher.png similarity index 100% rename from res/drawable-hdpi/ic_launcher.png rename to android/res/drawable-hdpi/ic_launcher.png diff --git a/res/drawable-hdpi/logo.png b/android/res/drawable-hdpi/logo.png similarity index 100% rename from res/drawable-hdpi/logo.png rename to android/res/drawable-hdpi/logo.png diff --git a/res/drawable-ldpi/ic_launcher.png b/android/res/drawable-ldpi/ic_launcher.png similarity index 100% rename from res/drawable-ldpi/ic_launcher.png rename to android/res/drawable-ldpi/ic_launcher.png diff --git a/res/drawable-mdpi/ic_launcher.png b/android/res/drawable-mdpi/ic_launcher.png similarity index 100% rename from res/drawable-mdpi/ic_launcher.png rename to android/res/drawable-mdpi/ic_launcher.png diff --git a/res/drawable-xhdpi/ic_launcher.png b/android/res/drawable-xhdpi/ic_launcher.png similarity index 100% rename from res/drawable-xhdpi/ic_launcher.png rename to android/res/drawable-xhdpi/ic_launcher.png diff --git a/res/raw/active.wav b/android/res/raw/active.wav similarity index 100% rename from res/raw/active.wav rename to android/res/raw/active.wav diff --git a/res/raw/ping.wav b/android/res/raw/ping.wav similarity index 100% rename from res/raw/ping.wav rename to android/res/raw/ping.wav diff --git a/res/values/strings.xml b/android/res/values/strings.xml similarity index 100% rename from res/values/strings.xml rename to android/res/values/strings.xml diff --git a/web/README b/web/README new file mode 100644 index 0000000000000000000000000000000000000000..2c8d29be0a69d956c4ba1f001a03af8bfb022837 --- /dev/null +++ b/web/README @@ -0,0 +1,21 @@ +Raspberry Pi/Android syncing + +Server interface: + +/sync: + +Called once per entity, taking a full entity description and either: + +- Inserts a new entry if the entity doesn't exist and dirty is true +- Updates the database entry if it's out of date and dirty is true +- Returns a more recent copy if it's older than the stored one and it's not dirty +- Returns an error message + +/mongoose?fn=sync&table=sync&entity-type=mongoose&unique-id=0&dirty=0&version=0&next:varchar=%22foodle%22&blah:int=20 + +/entity-versions + +Returns a list of all unique ids and version numbers. Used to check for new +entities and ??? (provide list of newer updated ones to request?) + +/mongoose?fn=all-entities&table=sync diff --git a/web/client/conf/not-found.html b/web/client/conf/not-found.html new file mode 100644 index 0000000000000000000000000000000000000000..5e4241cd7818596f68b95775f000126a4699fb12 --- /dev/null +++ b/web/client/conf/not-found.html @@ -0,0 +1,3 @@ +not found +not found... + diff --git a/web/client/htdocs/index.html b/web/client/htdocs/index.html new file mode 100755 index 0000000000000000000000000000000000000000..54f5328fea90c0dfd1125693a1924fc2d793c89c --- /dev/null +++ b/web/client/htdocs/index.html @@ -0,0 +1,8 @@ + + + mongoose web + + + hello there + + diff --git a/web/scripts/eavdb.ss b/web/scripts/eavdb.ss new file mode 100644 index 0000000000000000000000000000000000000000..dbc8d6d5ed3f47c96e3a9c8681c898bdd71221b8 --- /dev/null +++ b/web/scripts/eavdb.ss @@ -0,0 +1,633 @@ +#lang racket + +;; MongooseWeb Copyright (C) 2013 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require (planet jaymccarthy/sqlite:5:1/sqlite)) +(require "utils.ss") +(provide (all-defined-out)) + +;; tinyscheme +;(define db-select db-exec) + +;; racket +(define db-exec exec/ignore) +(define db-select select) +(define db-insert insert) +(define (db-status db) (errmsg db)) +(define (time) (list (random) (random))) ; ahem + + +;; create eav tables (add types as required) +(define (setup db table) + (db-exec db (string-append "create table " table "_entity ( entity_id integer primary key autoincrement, entity_type varchar(256), unique_id varchar(256), dirty integer, version integer)")) + (db-exec db (string-append "create table " table "_attribute ( id integer primary key autoincrement, attribute_id varchar(256), entity_type varchar(256), attribute_type varchar(256))")) + (db-exec db (string-append "create table " table "_value_varchar ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer)")) + (db-exec db (string-append "create table " table "_value_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer, dirty integer)")) + (db-exec db (string-append "create table " table "_value_real ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value real, dirty integer)"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; basic key/type/value structure +(define (ktv key type value) (list key type value)) +(define ktv-key car) +(define ktv-type cadr) +(define ktv-value caddr) + +;; stringify based on type (for url) +(define (stringify-value ktv) + (cond + ((null? (ktv-value ktv)) "NULL") + ((equal? (ktv-type ktv) "varchar") (string-append "'" (ktv-value ktv) "'")) + (else + (if (not (string? (ktv-value ktv))) + (number->string (ktv-value ktv)) + (ktv-value ktv))))) + +;; stringify based on type (for url) +(define (stringify-value-url ktv) + (cond + ((null? (ktv-value ktv)) "NULL") + ((equal? (ktv-type ktv) "varchar") (ktv-value ktv)) + (else + (if (not (string? (ktv-value ktv))) + (number->string (ktv-value ktv)) + (ktv-value ktv))))) + + +;; helper to return first instance from a select +(define (select-first db str . args) + (let ((s (apply db-select (append (list db str) args)))) + (if (or (null? s) (eq? s #t)) + '() + (vector-ref (cadr s) 0)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; putting data in + +;; get the type from the attribute table with an entity/key +(define (get-attribute-type db table entity-type key) + (let ((sql (string-append + "select attribute_type from " table + "_attribute where entity_type = ? and attribute_id = ?"))) + (select-first db sql entity-type key))) + +;; search for a type and add it if it doesn't exist +(define (find/add-attribute-type db table entity-type key type) + (let ((t (get-attribute-type db table entity-type key))) + ;; add and return passed in type if not exist + (cond + ((null? t) + (msg "adding new attribute for" entity-type " called " key " of type " type) + (db-insert + db (string-append "insert into " table "_attribute values (null, ?, ?, ?)") + key entity-type type) + type) + (else + (cond + ((equal? type t) t) + (else + (msg "type has changed for" entity-type key "from" t "to" type "???") + ;; wont work + ;; what do we do? + ;; some kind of coercion for existing data??? + type)))))) + +;; low level insert of a ktv +(define (insert-value db table entity-id ktv) + ;; use type to dispatch insert to correct value table + (db-insert db (string-append "insert into " table "_value_" (ktv-type ktv) + " values (null, ?, ?, ?, 0)") + entity-id (ktv-key ktv) (ktv-value ktv))) + +(define (get-unique user) + (let ((t (time))) + (string-append + user "-" (number->string (car t)) ":" (number->string (cadr t))))) + +;; insert an entire entity +(define (insert-entity db table entity-type user ktvlist) + (insert-entity-wholesale db table entity-type (get-unique user) 1 0 ktvlist)) + +;; insert an entire entity +(define (insert-entity/get-unique db table entity-type user ktvlist) + (let ((uid (get-unique user))) + (insert-entity-wholesale db table entity-type uid 1 0 ktvlist) + uid)) + +(define sema (make-semaphore 1)) + +;; all the parameters - for syncing purposes +(define (insert-entity-wholesale db table entity-type unique-id dirty version ktvlist) + (semaphore-wait sema) + (db-exec db "begin transaction") + (let ((id (db-insert + db (string-append + "insert into " table "_entity values (null, ?, ?, ?, ?)") + entity-type unique-id dirty version))) + + ;; create the attributes if they are new, and validate them if they exist + (for-each + (lambda (ktv) + (find/add-attribute-type db table entity-type (ktv-key ktv) (ktv-type ktv))) + ktvlist) + + ;; add all the keys + (for-each + (lambda (ktv) + (insert-value db table id ktv)) + ktvlist) + + (db-exec db "end transaction") + (semaphore-post sema) + + id)) + +;; update the value given an entity type, a attribute type and it's key (= attriute_id) +;; creates the value if it doesn't already exist, updates it otherwise +(define (update-value db table entity-id ktv) + (if (null? (select-first + db (string-append + "select * from " table "_value_" (ktv-type ktv) " where entity_id = ? and attribute_id = ?") + entity-id (ktv-key ktv))) + (insert-value db table entity-id ktv) + (db-exec + db (string-append "update " table "_value_" (ktv-type ktv) + " set value=? where entity_id = ? and attribute_id = ?") + (ktv-value ktv) entity-id (ktv-key ktv)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; getting data out + +(define (entity-exists? db table unique-id) + (not (null? (select-first + db (string-append + "select * from " table "_entity where unique_id = ?") + unique-id)))) + +(define (get-entity-type db table entity-id) + (select-first + db (string-append + "select entity_type from " table "_entity where entity_id = ?") + entity-id)) + +(define (get-all-entity-types db table) + (cdr (db-select db (string-append "select distinct entity_type from " table "_entity;")))) + +;; get all the (current) attributes for an entity type +(define (get-attribute-ids/types db table entity-type) + (let ((s (db-select + db (string-append + "select * from " table "_attribute where entity_type = ?") + entity-type))) + (if (null? s) '() + (map + (lambda (row) + (list (vector-ref row 1) ;; id + (vector-ref row 3))) ;; type + (cdr s))))) + +;; get the value given an entity type, a attribute type and it's key (= attriute_id) +(define (get-value db table entity-id kt) + (select-first + db (string-append "select value from " table "_value_" (ktv-type kt) + " where entity_id = ? and attribute_id = ?") + entity-id (ktv-key kt))) + +;; get an entire entity, as a list of key/value pairs +(define (get-entity-plain db table entity-id) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) (msg "entity" entity-id "not found!") '()) + (else + (map + (lambda (kt) + (list (ktv-key kt) (ktv-type kt) (get-value db table entity-id kt))) + (get-attribute-ids/types db table entity-type)))))) + +;; get an entire entity, as a list of key/value pairs (includes entity id) +(define (get-entity db table entity-id) + (let ((unique-id (get-unique-id db table entity-id))) + (cons + (list "unique_id" "varchar" unique-id) + (get-entity-plain db table entity-id)))) + +(define (all-entities db table type) + (let ((s (db-select + db (string-append "select entity_id from " table "_entity where entity_type = ?") + type))) + (if (null? s) + '() + (map + (lambda (i) + (vector-ref i 0)) + (cdr s))))) + +(define (validate db) + ;; check attribute for duplicate entity-id/attribute-ids + 0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; helpers + +(define (ktv-get ktv-list key) + (cond + ((null? ktv-list) #f) + ((equal? (ktv-key (car ktv-list)) key) + (ktv-value (car ktv-list))) + (else (ktv-get (cdr ktv-list) key)))) + +(define (ktv-set ktv-list ktv) + (cond + ((null? ktv-list) (list ktv)) + ((equal? (ktv-key (car ktv-list)) (ktv-key ktv)) + (cons ktv (cdr ktv-list))) + (else (cons (car ktv-list) (ktv-set (cdr ktv-list) ktv))))) + +(define (db-all db table type) + (map + (lambda (i) + (get-entity db table i)) + (all-entities db table type))) + +(define (db-all-where db table type clause) + (foldl + (lambda (i r) + (let ((e (get-entity db table i))) + (if (equal? (ktv-get e (car clause)) (cadr clause)) + (cons e r) r))) + '() + (all-entities db table type))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; updating data + +;; update an entire entity (version incl), via a (possibly partial) list of key/value pairs +(define (update-to-version db table entity-id version ktvlist) + (update-entity-values db table entity-id ktvlist) + (update-entity-version db table entity-id version)) + +;; auto update version +(define (update-entity db table entity-id ktvlist) + (update-entity-changed db table entity-id) + (update-entity-values db table entity-id ktvlist)) + +;; update an entity, via a (possibly partial) list of key/value pairs +(define (update-entity-values db table entity-id ktvlist) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) (msg "entity" entity-id "not found!") '()) + (else + ;; update main entity type + (for-each + (lambda (ktv) + (when (not (equal? (ktv-key ktv) "unique_id")) + (find/add-attribute-type db table entity-type (ktv-key ktv) (ktv-type ktv)))) + ktvlist) + (for-each + (lambda (ktv) + (update-value db table entity-id ktv)) + ktvlist))))) + +;; update or create an entire entity if it doesn't exist +;; will return the new entity id if it's created +(define (update/insert-entity db table entity-type user entity-id ktvlist) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) + (insert-entity db table entity-type user ktvlist)) + (else + (update-entity db table entity-id ktvlist) + #f)))) + +(define (insert-entity-if-not-exists db table entity-type user entity-id ktvlist) + (let ((found (get-entity-type db table entity-id))) + (if (null? found) + (insert-entity db table entity-type user ktvlist) + #f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; versioning + +(define (get-entity-version db table entity-id) + (select-first + db (string-append "select version from " table "_entity where entity_id = ?") + entity-id)) + +(define (get-entity-dirty db table entity-id) + (select-first + db (string-append "select dirty from " table "_entity where entity_id = ?") + entity-id)) + +(define (update-entity-changed db table entity-id) + (db-exec + db (string-append + "update " table "_entity set dirty=?, version=? where entity_id = ?") + 1 (+ 1 (get-entity-version db table entity-id)) entity-id)) + +(define (update-entity-version db table entity-id version) + (db-exec + db (string-append + "update " table "_entity set dirty=?, version=? where entity_id = ?") + 1 version entity-id)) + +(define (update-entity-clean db table unique-id) + (db-exec + db (string-append "update " table "_entity set dirty=? where unique_id = ?") + 0 unique-id)) + +(define (get-dirty-stats db table) + (list + (select-first + db (string-append "select count(entity_id) from " table "_entity where dirty=1")) + (select-first + db (string-append "select count(entity_id) from " table "_entity;")))) + +(define (dirty-entities db table) + (let ((de (db-select + db (string-append + "select entity_id, entity_type, unique_id, dirty, version from " table "_entity where dirty=1;")))) + (if (null? de) + '() + (map + (lambda (i) + (list + ;; build according to url ([table] entity-type unique-id dirty version) + (cdr (vector->list i)) + ;; data entries (todo - only dirty values!) + (get-entity-plain db table (vector-ref i 0)))) + (cdr de))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syncing + +(define (stringify-list l) + (foldl + (lambda (i r) + (string-append r " " i)) + "" l)) + +(define (stringify-ktvlist ktvlist) + (foldl + (lambda (i r) + (string-append r " " (ktv-key i) ":" (stringify-value i))) + "" + ktvlist)) + +(define (build-sync-debug db table) + (foldl + (lambda (i r) + (string-append + r "\n" (vector-ref i 0) " " (vector-ref i 1) " " + (stringify-ktvlist (get-entity db table (vector-ref i 0))))) + "" + (cdr (db-select + db (string-append "select * from " table "_entity where dirty=1;"))))) + + +(define (build-sync db table) + (map + (lambda (i) + (list + (vector->list i) + (get-entity db table (vector-ref i 0)))) + (cdr (db-select + db (string-append "select * from " table "_entity where dirty=1;"))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; doing things with unique ids + +(define (entity-id-from-unique db table unique-id) + (select-first + db (string-append "select entity_id from " table "_entity where unique_id = ?") + unique-id)) + +(define (entity-version-from-unique db table unique-id) + (select-first + db (string-append "select version from " table "_entity where unique_id = ?") + unique-id)) + + +(define (get-unique-id db table entity-id) + (select-first + db (string-append + "select unique_id from " table "_entity where entity_id = ?") + entity-id)) + +(define (get-entity-id db table unique-id) + (select-first + db (string-append + "select entity_id from " table "_entity where unique_id = ?") + unique-id)) + +(define (get-entity-name db table unique-id) + (let ((e (get-entity-id db table unique-id))) + (if (null? e) + unique-id + (let ((r (ktv-get (get-entity db table e) "name"))) + (if (null? r) + (begin ;(msg "no name for" unique-id "found") + unique-id) + r))))) + +(define (get-entity-names db table id-list) + (foldl + (lambda (id r) + (if (equal? r "") + (get-entity-name db table id) + (string-append r ", " (get-entity-name db table id)))) + "" + id-list)) + +(define (csv-titles db table entity-type) + (foldl + (lambda (kt r) + (if (equal? r "") (string-append "\"" (ktv-key kt) "\"") + (string-append r ", \"" (ktv-key kt) "\""))) + "\"id\"" + (get-attribute-ids/types db table entity-type))) + +(define (csv db table entity-type) + (foldl + (lambda (res r) + (let ((entity (get-entity db table (vector-ref res 0)))) + (string-append + r "\n" + (foldl + (lambda (ktv r) + (cond + ((equal? (ktv-key ktv) "unique_id") r) + ((null? (ktv-value ktv)) + ;;(msg "value not found in csv for " (ktv-key ktv)) + r) + ;; dereferences lists of ids + ((and + (> (string-length (ktv-key ktv)) 8) + (equal? (substring (ktv-key ktv) 0 8) "id-list-")) + (string-append r ", \"" (get-entity-names db "sync" (string-split (ktv-value ktv) '(#\,))) "\"")) + ;; look for unique ids and dereference them + ((and + (> (string-length (ktv-key ktv)) 3) + (equal? (substring (ktv-key ktv) 0 3) "id-")) + (string-append r ", \"" (get-entity-name db "sync" (ktv-value ktv)) "\"")) + (else + (string-append r ", \"" (stringify-value-url ktv) "\"")))) + (string-append "\"" (vector-ref res 1) "\"") ;; unique_id + entity)))) + (csv-titles db table entity-type) + (let ((r (db-select + db (string-append + "select entity_id, unique_id from " + table "_entity where entity_type = ?") entity-type))) + (if (null? r) r (cdr r))))) + + +(define (db-open db-name) + (cond + ((file-exists? (string->path db-name)) + (display "open existing db")(newline) + (open (string->path db-name))) + (else + (display "making new db")(newline) + (let ((db (open (string->path db-name)))) + ;; todo, dynamically create these tables + (setup db "sync") + (setup db "stream") + db)))) + + + + + +(define (unit-tests) + ;; db +(msg "testing db") +(define db "unit-test.db") +(set! db (db-open db)) + +(define (feq a b) + (< (abs (- a b)) 0.001)) + +;;(msg (db-status db)) + +;; test low level sql +(db-exec db "create table unittest ( id integer primary key autoincrement, name varchar(256), num int, r real )") + +(define id (db-insert db "insert into unittest values (null, ?, ?, ?)" "hello" 23 1.1)) +(asserteq "sql autoinc" (+ id 1) (db-insert db "insert into unittest values (null, ?, ?, ?)" "hello2" 26 2.3)) + +(let ((q (db-select db "select * from unittest"))) + (assert "sql length" (> (length q) 2))) + +(let ((q (db-select db "select * from unittest where id = ?" id))) + (asserteq "sql select one" (length q) 2) + (assert "sql select two" (vector? (car q))) + (asserteq "sql select 3" (vector-ref (cadr q) 2) 23) + (assert "sql select 4" (feq (vector-ref (cadr q) 3) 1.1))) + +(db-exec db "update unittest set name=? where id = ?" "bob" id) + +(let ((q (db-select db "select * from unittest where id = ?" id))) + (asserteq "sql update" (vector-ref (cadr q) 1) "bob")) + +(db-exec db "update unittest set name=? where id = ?" "Robert'); DROP TABLE unittest;--" id) + +(let ((q (db-select db "select * from unittest where id = ?" id))) + (asserteq "bobby tables sql injection" (vector-ref (cadr q) 1) "Robert'); DROP TABLE unittest;--")) + +;; test the entity attribute value system +(define table "eavunittest") +(setup db table) + +(asserteq "ktv one" (stringify-value (ktv "one" "varchar" "two")) "'two'") +(asserteq "ktv 2" (stringify-value (ktv "one" "int" 3)) "3") +(asserteq "ktv 3" (stringify-value-url (ktv "one" "varchar" "two")) "two") +(asserteq "ktv 4" (stringify-value-url (ktv "one" "int" 3)) "3") + +(asserteq "select first" (select-first db "select name from unittest where id = ?" (+ id 1)) + "hello2") + +(define e (insert-entity db table "thing" "me" (list (ktv "param1" "varchar" "bob") + (ktv "param2" "int" 30) + (ktv "param3" "real" 3.141)))) + +(asserteq "eav ent type" (get-entity-type db table e) "thing") + +(let ((e (get-entity db table e))) + (asserteq "entity get 1" (ktv-get e "param1") "bob") + (asserteq "entity get 2" (ktv-get e "param2") 30) + (assert "entity get 3" (feq (ktv-get e "param3") 3.141))) + +(update-value db table e (ktv "param1" "varchar" "fred")) + +(let ((e (get-entity db table e))) + (asserteq "update value 1" (ktv-get e "param1") "fred") + (asserteq "update value 2" (ktv-get e "param2") 30)) + +(assert "all-entities" (> (length (all-entities db table "thing")) 0)) + +(update-entity db table e (list (ktv "param1" "varchar" "wotzit") + (ktv "param2" "int" 1))) + +(let ((e (get-entity db table e))) + (asserteq "update-entity 1" (ktv-get e "param1") "wotzit") + (asserteq "update-entity 2" (ktv-get e "param2") 1)) + +(update-entity db table e (list (ktv "param3" "real" 3.3))) + +(let ((e (get-entity db table e))) + (msg e) + (asserteq "update-entity 3" (ktv-get e "param1") "wotzit") + (asserteq "update-entity 4" (ktv-get e "param2") 1) + (assert "update-entity 5" (feq (ktv-get e "param3") 3.3))) + +(define e2 (insert-entity db table "thing" "me" + (list (ktv "param1" "varchar" "bob") + (ktv "param2" "int" 30) + (ktv "param3" "real" 3.141) + (ktv "param4" "int" 0)))) + +(let ((e (get-entity db table e2))) + (msg e) + (asserteq "new entity 1" (ktv-get e "param1") "bob") + (asserteq "new entity 2" (ktv-get e "param2") 30) + (assert "new entity 3" (feq (ktv-get e "param3") 3.141)) + (asserteq "new entity 3" (ktv-get e "param4") 0)) + +;; test the versioning +(asserteq "dirty flag" (get-entity-dirty db table e) 1) +(asserteq "dirty flag2" (get-entity-dirty db table e2) 1) +(let ((uid (get-unique-id db table e2))) + (update-entity-clean db table uid)) +(asserteq "dirty flag post clean" (get-entity-dirty db table e2) 0) +(asserteq "versioning" (get-entity-version db table e) 2) +(asserteq "dirty flag3" (get-entity-dirty db table e) 1) +(assert "dirty" (> (length (dbg (dirty-entities db table))) 0)) + +(for-each + (lambda (e) + (update-entity-clean + db table + (list-ref (car e) 1))) + (dirty-entities db table)) + +(asserteq "cleaning" (length (dirty-entities db table)) 0) + +(msg (csv db table "thing")) + +(msg (db-status db)) +) + +;(unit-tests) diff --git a/web/scripts/eavdb_old.ss b/web/scripts/eavdb_old.ss new file mode 100644 index 0000000000000000000000000000000000000000..c9b8d10a405e437337489d23e0c8d40654b5c138 --- /dev/null +++ b/web/scripts/eavdb_old.ss @@ -0,0 +1,401 @@ +#lang racket + +;; MongooseWeb Copyright (C) 2013 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require (planet jaymccarthy/sqlite:5:1/sqlite)) +(require "utils.ss") +(provide (all-defined-out)) + +;; tinyscheme +;(define db-select db-exec) + +;; racket +(define db-exec exec/ignore) +(define db-select select) +(define db-insert insert) +(define (db-status a) "") +(define (time) (list 0 0)) + +;; create eav tables (add types as required) +(define (setup db table) + (db-exec db (string-append "create table " table "_entity ( entity_id integer primary key autoincrement, entity_type varchar(256), unique_id varchar(256), dirty integer, version integer)")) + (db-exec db (string-append "create table " table "_attribute ( id integer primary key autoincrement, attribute_id varchar(256), entity_type varchar(256), attribute_type varchar(256))")) + (db-exec db (string-append "create table " table "_value_varchar ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer)")) + (db-exec db (string-append "create table " table "_value_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer, dirty integer)")) + (db-exec db (string-append "create table " table "_value_real ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value real, dirty integer)"))) + +(define (sqls str) + ;; todo sanitise str + str) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; + +;; basic key/type/value structure +(define (ktv key type value) (list key type value)) +(define ktv-key car) +(define ktv-type cadr) +(define ktv-value caddr) + +;; stringify based on type (for sql) +(define (stringify-value ktv) + (cond + ((null? (ktv-value ktv)) "NULL") + ((equal? (ktv-type ktv) "varchar") (string-append "'" (ktv-value ktv) "'")) + (else + (if (not (string? (ktv-value ktv))) + (number->string (ktv-value ktv)) + (ktv-value ktv))))) + +;; stringify based on type (for url) +(define (stringify-value-url ktv) + (cond + ((null? (ktv-value ktv)) "NULL") + ((equal? (ktv-type ktv) "varchar") (ktv-value ktv)) + (else + (if (not (string? (ktv-value ktv))) + (number->string (ktv-value ktv)) + (ktv-value ktv))))) + +;; helper to return first instance from a select +(define (select-first db str) + (let ((s (db-select db str))) + (if (or (null? s) (eq? s #t)) + '() + (vector-ref (cadr s) 0)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; putting data in + +;; get the type from the attribute table with an entity/key +(define (get-attribute-type db table entity-type key) + (let ((sql (string-append + "select attribute_type from " table "_attribute where entity_type = '" + (sqls entity-type) + "' and attribute_id = '" + (sqls key) "'"))) + (select-first db sql))) + +;; search for a type and add it if it doesn't exist +(define (find/add-attribute-type db table entity-type key type) + (let ((t (get-attribute-type db table entity-type key))) + ;; add and return passed in type if not exist + (cond + ((null? t) + (msg "adding new attribute for" entity-type " called " key " of type " type) + (db-insert + db (string-append + "insert into " table "_attribute values (null, '" + (sqls key) "', '" (sqls entity-type) "', '" (sqls type) "')")) + type) + (else + (cond + ((equal? type t) t) + (else + (msg "type has changed for" entity-type key "from" t "to" type "???") + ;; wont work + ;; what do we do? + ;; some kind of coercion for existing data??? + type)))))) + +;; low level insert of a ktv +(define (insert-value db table entity-id ktv) + ;; use type to dispatch insert to correct value table + (db-insert db (string-append "insert into " table "_value_" (sqls (ktv-type ktv)) + " values (null, " (number->string entity-id) ", '" (sqls (ktv-key ktv)) "', " + (stringify-value ktv) ", 0)"))) + + +(define (get-unique user) + (let ((t (time))) + (string-append + user "-" (number->string (car t)) ":" (number->string (cadr t))))) + +;; insert an entire entity +(define (insert-entity db table entity-type user ktvlist) + (insert-entity-wholesale db table entity-type (get-unique user) 1 0 ktvlist)) + +;; all the parameters - for syncing purposes +(define (insert-entity-wholesale db table entity-type unique-id dirty version ktvlist) + (msg table entity-type ktvlist) + (let ((id (db-insert + db (string-append + "insert into " table "_entity values (null, '" + (sqls entity-type) "', '" + unique-id "', " + (number->string dirty) ", " + (number->string version) ")")))) + ;; create the attributes if they are new, and validate them if they exist + (for-each + (lambda (ktv) + (find/add-attribute-type db table entity-type (ktv-key ktv) (ktv-type ktv))) + ktvlist) + ;; add all the keys + (for-each + (lambda (ktv) + (msg (ktv-key ktv)) + (insert-value db table id ktv)) + ktvlist))) + +;; update the value given an entity type, a attribute type and it's key (= attriute_id) +(define (update-value db table entity-id ktv) + (msg "update-value" table entity-id ktv) + (db-exec + db (string-append "update " table "_value_" (sqls (ktv-type ktv)) + " set value='" (ktv-value ktv) "'" + " where entity_id = " (number->string entity-id) + " and attribute_id = '" (sqls (ktv-key ktv)) "'")) + (msg (db-status db))) + +(define (update-entity-changed db table entity-id) + (let ((version (car (db-exec db (string-append + "select version from " + table "_entity where entity_id = " (number->string entity-id) ";"))))) + (db-exec + db (string-append "update " table "_entity " + "set dirty='1', " + "version='" (number->string (+ 1 (string->number version))) "'" + " where entity_id = " (number->string entity-id) ";")))) + +(define (update-entity-version db table entity-id version) + (db-exec + db (string-append "update " table "_entity " + "set dirty='1', " + "version='" (number->string version) "'" + " where entity_id = " (number->string entity-id) ";"))) + + +(define (update-entity-clean db table unique-id) + (db-exec + db (string-append "update " table "_entity " + "set dirty='0' " + " where unique_id = '" unique-id "';"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; getting data out + +(define (get-entity-type db table entity-id) + (select-first + db (string-append + "select entity_type from " table "_entity where entity_id = " + (number->string entity-id)))) + +;; get all the (current) attributes for an entity type +(define (get-attribute-ids/types db table entity-type) + (let ((s (db-select + db (string-append + "select * from " table "_attribute where entity_type = '" + (sqls entity-type) "'")))) + (if (null? s) '() + (map + (lambda (row) + (list (vector-ref row 1) ;; id + (vector-ref row 3))) ;; type + (cdr s))))) + +;; get the value given an entity type, a attribute type and it's key (= attriute_id) +(define (get-value db table entity-id kt) + (select-first + db (string-append "select value from " table "_value_" (sqls (ktv-type kt)) + " where entity_id = " (number->string entity-id) + " and attribute_id = '" (sqls (ktv-key kt)) "'"))) + +;; get an entire entity, as a list of key/value pairs +(define (get-entity-plain db table entity-id) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) (msg "entity" entity-id "not found!") '()) + (else + (map + (lambda (kt) + (list (ktv-key kt) (ktv-type kt) (get-value db table entity-id kt))) + (get-attribute-ids/types db table entity-type)))))) + +;; get an entire entity, as a list of key/value pairs (includes entity id) +(define (get-entity db table entity-id) + (let* ((entity-type (get-entity-type db table entity-id)) + (unique-id (get-unique-id db table entity-id))) + (cond + ((null? entity-type) (msg "entity" entity-id "not found!") '()) + (else + (cons + (list "unique_id" "varchar" unique-id) + (map + (lambda (kt) + (list (ktv-key kt) (ktv-type kt) (get-value db table entity-id kt))) + (get-attribute-ids/types db table entity-type))))))) + +(define (get-dirty-stats db table) + (list + (select-first + db (string-append "select count(entity_id) from " table "_entity where dirty=1;")) + (select-first + db (string-append "select count(entity_id) from " table "_entity;")))) + +(define (all-entities db table type) + (let ((s (db-select + db (string-append "select entity_id from " table "_entity where entity_type = '" + (sqls type) "';")))) + (if (null? s) + '() + (map + (lambda (i) + (string->number (vector-ref i 0))) + (cdr s))))) + +(define (validate db) + ;; check attribute for duplicate entity-id/attribute-ids + 0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; helpers + +(define (ktv-get ktv-list key) + (cond + ((null? ktv-list) #f) + ((equal? (ktv-key (car ktv-list)) key) + (ktv-value (car ktv-list))) + (else (ktv-get (cdr ktv-list) key)))) + +(define (db-all db table type) + (map + (lambda (i) + (get-entity db table i)) + (all-entities db table type))) + +(define (db-all-where db table type clause) + (foldl + (lambda (i r) + (let ((e (get-entity db table i))) + (if (equal? (ktv-get e (car clause)) (cadr clause)) + (cons e r) r))) + '() + (all-entities db table type))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; updating data + +;; update an entire entity (version incl), via a (possibly partial) list of key/value pairs +(define (update-to-version db table entity-id version ktvlist) + (msg table entity-id ktvlist) + (_update-entity db table entity-id ktvlist) + (update-entity-version db table entity-id version)) + +;; auto update version +(define (update-entity db table entity-id ktvlist) + (update-entity-changed db table entity-id) + (_update-entity db table entity-id ktvlist)) + +;; update an entity, via a (possibly partial) list of key/value pairs +(define (_update-entity db table entity-id ktvlist) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) (msg "entity" entity-id "not found!") '()) + (else + (for-each + (lambda (ktv) + (msg ktv) + (update-value db table entity-id ktv)) + ktvlist))))) + +;; update or create an entire entity if it doesn't exist +;; will return the new entity id if it's created +(define (update/insert-entity db table entity-type user entity-id ktvlist) + (let* ((entity-type (get-entity-type db table entity-id))) + (cond + ((null? entity-type) + (insert-entity db table entity-type user ktvlist)) + (else + (update-entity db table entity-id ktvlist) + #f)))) + +(define (insert-entity-if-not-exists db table entity-type user entity-id ktvlist) + (let ((found (get-entity-type db table entity-id))) + (if (null? found) + (insert-entity db table entity-type user ktvlist) + #f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; syncing + +(define (stringify-list l) + (foldl + (lambda (i r) + (string-append r " " i)) + "" l)) + +(define (stringify-ktvlist ktvlist) + (foldl + (lambda (i r) + (string-append r " " (ktv-key i) ":" (stringify-value i))) + "" + ktvlist)) + +(define (build-sync-debug db table) + (foldl + (lambda (i r) + (string-append + r "\n" (vector-ref i 0) " " (vector-ref i 1) " " + (stringify-ktvlist (get-entity db table (string->number (vector-ref i 0)))))) + "" + (cdr (db-select + db (string-append "select * from " table "_entity where dirty=1;"))))) + + +(define (build-sync db table) + (map + (lambda (i) + (list + (vector->list i) + (get-entity db table (string->number (vector-ref i 0))))) + (cdr (db-select + db (string-append "select * from " table "_entity where dirty=1;"))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; doing things with unique ids + +(define (entity-id-from-unique db table unique-id) + (select-first + db (string-append "select entity_id from " table "_entity where unique_id = '" + unique-id "';"))) + +(define (entity-version-from-unique db table unique-id) + (select-first + db (string-append "select version from " table "_entity where unique_id = '" + unique-id "';"))) + +(define (dirty-entities db table) + (map + (lambda (i) + (list + ;; build according to url ([table] entity-type unique-id dirty version) + (cdr (vector->list i)) + ;; data entries (todo - only dirty values!) + (get-entity-plain db table (string->number (vector-ref i 0))))) + (cdr (db-select + db (string-append "select entity_id, entity_type, unique_id, dirty, version from " table "_entity where dirty=1;"))))) + +(define (get-unique-id db table entity-id) + (select-first db (string-append "select unique_id from " table "_entity where entity_id = '" (number->string entity-id) "';"))) + +(define (get-entity-id db table unique-id) + (select-first db (string-append "select entity_id from " table "_entity where unique_id = '" unique-id "';"))) + +(define (get-entity-version db table unique-id) + (select-first db (string-append "select version from " table "_entity where unique_id = '" unique-id "';"))) + +(define (entity-exists? db table unique-id) + (not (null? (select-first db (string-append "select * from " table "_entity where unique_id = '" unique-id "';"))))) diff --git a/web/scripts/filter-string.ss b/web/scripts/filter-string.ss new file mode 100644 index 0000000000000000000000000000000000000000..63cb38388861ee3a14cd0d252789312afe69f3ad --- /dev/null +++ b/web/scripts/filter-string.ss @@ -0,0 +1,43 @@ +;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +; filter out dodgy characters from a string + +#lang scheme +(require "list.ss") +(provide (all-defined-out)) + +(define white-list (string->list "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890 .,'!?-#:@")) + +; start slow and stupid +(define (filter-string s) + (foldl + (lambda (c r) + (if (list-contains? white-list c) + (string-append r (string c)) + r)) + "" + (string->list s))) + +(define (unit-test) + (when (not (string=? (filter-string "should Be ok123") "should Be ok123")) + (error "oops")) + (when (not (string=? (filter-string " b&a_r") "foo bar")) + (error "oops"))) + + +(printf "unit testing filter-string.ss~n") +(unit-test) + diff --git a/web/scripts/input.ss b/web/scripts/input.ss new file mode 100644 index 0000000000000000000000000000000000000000..7ade541530b5b2b8a0755b95fb1721269d324242 --- /dev/null +++ b/web/scripts/input.ss @@ -0,0 +1,78 @@ +#lang racket + +;; MongooseWeb Copyright (C) 2013 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require (planet jaymccarthy/sqlite:5:1/sqlite)) +(require "utils.ss") +(require "eavdb.ss") +(provide (all-defined-out)) +(require (planet neil/csv:1:=7) net/url) + +(define make-mongoose-csv-reader + (make-csv-reader-maker + '((separator-chars #\tab) + (strip-leading-whitespace? . #t) + (strip-trailing-whitespace? . #t)))) + +(define (all-rows url make-reader) + (define next-row (make-reader (open-input-file url))) + (define (loop) + (define row (next-row)) + (if (empty? row) + '() + (cons row (loop)))) + (loop)) + + + +(define (insert-mongooses db table l) + (map + (lambda (i) + (let ((pack (car (db-all-where db table "pack" (list "name" (list-ref i 2))))) + (date (string-split (list-ref i 3) '(#\/)))) + (msg i) + (insert-entity db table "mongoose" "sys" + (list + (ktv "name" "varchar" (list-ref i 0)) + (ktv "gender" "varchar" + (if (equal? (list-ref i 1) "F") "Female" "Male")) + (ktv "pack-id" "varchar" (ktv-get pack "unique_id")) + (ktv "litter-code" "varchar" (if (eq? (length i) 5) (list-ref i 4) "")) + (ktv "chip-code" "varchar" "") + (ktv "dob" "varchar" (string-append + (list-ref date 2) "-" + (list-ref date 1) "-" + (list-ref date 0))) + )))) + l)) + +(define (insert-csv db table path) + (let ((data (cdr (all-rows path make-mongoose-csv-reader)))) + (insert-mongooses db table data))) + +(define (insert-packs db table l) + (map + (lambda (i) + (msg "insert pack" i) + (insert-entity db table "pack" "sys" + (list + (ktv "name" "varchar" i)))) + l)) + + +(define (write-db db table path) + (insert-packs db table (list "11" "14" "15" "17" "18" "1B" "1H" "2" "4B" "4E" "7A")) + (insert-csv db table path)) diff --git a/web/scripts/json.ss b/web/scripts/json.ss new file mode 100644 index 0000000000000000000000000000000000000000..10437919f1a2f90d0dca4feb7341e35dc601fb9d --- /dev/null +++ b/web/scripts/json.ss @@ -0,0 +1,62 @@ +;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +#lang scheme +(provide (all-defined-out)) + +; convert scheme values into equivilent json strings + +(define (scheme->json v) + (cond + ((number? v) (number->string v)) + ((symbol? v) (string-append "\"" (symbol->string v) "\"")) + ((string? v) (string-append "\"" v "\"")) + ((boolean? v) (if v "true" "false")) + ((list? v) + (cond + ((null? v) "null") + (else + ; if it quacks like an assoc list... + (if (and (not (null? v)) (not (list? (car v))) (pair? (car v))) + (assoc->json v) + (list->json v))))) + (else (printf "value->js, unsupported type for ~a~n" v) 0))) + +(define (list->json l) + (define (_ l s) + (cond + ((null? l) s) + (else + (_ (cdr l) + (string-append s + (if (not (string=? s "")) ", " "") + (scheme->json (car l))))))) + (string-append "[" (_ l "") "]")) + +; ((one . 1) (two . "three")) -> { "one": 1, "two": "three } + +(define (assoc->json l) + (define (_ l s) + (cond + ((null? l) s) + (else + (let ((token (scheme->json (car (car l)))) + (value (scheme->json (cdr (car l))))) + (_ (cdr l) (string-append s (if (not (string=? s "")) "," "") + "\n" token ": " value)))))) + (string-append "{" (_ l "") "\n" "}")) + + + diff --git a/web/scripts/list.ss b/web/scripts/list.ss new file mode 100644 index 0000000000000000000000000000000000000000..a43303e16122b38a0b55db1c8aaddf46a69c4c70 --- /dev/null +++ b/web/scripts/list.ss @@ -0,0 +1,95 @@ +;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +#lang scheme +(provide (all-defined-out)) + +;; returns the list with the value removed +(define (list-remove l v) + (define (_ l v o) + (cond + ((null? l) o) + ((eq? (car l) v) + (_ (cdr l) v o)) + (else + (_ (cdr l) v (cons (car l) o))))) + (_ l v '())) + +(define (list-remove-equal l v) + (define (_ l v o) + (cond + ((null? l) o) + ((equal? (car l) v) + (_ (cdr l) v o)) + (else + (_ (cdr l) v (cons (car l) o))))) + (_ l v '())) + +;; does the list contain this value? +(define (list-contains? l v) + (cond + ((null? l) #f) + ((eq? (car l) v) #t) + (else + (list-contains? (cdr l) v)))) + +;; does the list contain this value? +(define (list-contains-equal? l v) + (cond + ((null? l) #f) + ((equal? (car l) v) #t) + (else + (list-contains-equal? (cdr l) v)))) + +;; limit the size of a list and optionally call +;; a procedure if we are over the max size +(define (safe-cons v l max (proc (lambda () 0))) + (cond + ((< (length l) max) (cons v l)) + (else (proc) l))) + +;; (list-replace '(1 2 3 4) 2 100) => '(1 2 100 4) +(define (list-replace l i v) + (cond + ((null? l) l) + ((zero? i) (cons v (list-replace (cdr l) (- i 1) v))) + (else (cons (car l) (list-replace (cdr l) (- i 1) v))))) + +(define (choose l) (list-ref l (random (length l)))) + +(define (set-cons v l) + (if (list-contains? l v) + l + (cons v l))) + +(define (set-cons-equal v l) + (if (list-contains-equal? l v) + l + (cons v l))) + +(define (clip l c) + (cond + ((null? l) l) + ((zero? c) '()) + (else (cons (car l) (clip (cdr l) (- c 1)))))) + +; (1 2 3 4) -> (0 1 2 3) +(define (limit-cons v l max) + (clip (cons v l) max)) + +(define (set-cons-equal-limit v l max) + (if (list-contains-equal? l v) + l + (limit-cons v l max))) diff --git a/web/scripts/logger.ss b/web/scripts/logger.ss new file mode 100644 index 0000000000000000000000000000000000000000..d93e4ef3517c981fac0d5bd9da02d37941c5215a --- /dev/null +++ b/web/scripts/logger.ss @@ -0,0 +1,48 @@ +;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +; record activities to a file for later examination + +#lang scheme +(require scheme/date) + +(provide (all-defined-out)) + +(define log-filename "") + +(define (open-log filename) + (printf "opened log: ~a~n" filename) + (set! log-filename filename) + (log "Started server at: " + (date->string (seconds->date (current-seconds))))) + +(define (log . args) + (when (not (equal? log-filename "")) + (_log (foldl + (lambda (txt r) + (cond + ((string? txt) (string-append r txt)) + ((number? txt) (string-append r (number->string txt))))) + "" + args)))) + +(define (_log txt) + (printf "~a~n" txt) + (let ((f (open-output-file log-filename #:exists 'append))) + (display (string-append (date->string + (seconds->date (current-seconds)) #t) + " " txt) f) + (newline f) + (close-output-port f))) diff --git a/web/scripts/request.ss b/web/scripts/request.ss new file mode 100644 index 0000000000000000000000000000000000000000..0ac3efdf8f63e2628f8417a87b9f511a01c3a93b --- /dev/null +++ b/web/scripts/request.ss @@ -0,0 +1,80 @@ +;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +;; A server request interface +;; We only want to ever call commands in the registered requests, +;; and generally need to be careful - never executing data from +;; external sources directly... + +#lang scheme + +(provide (all-defined-out)) +(require web-server/http/response-structs "filter-string.ss" "list.ss" "utils.ss") + +(define (pluto-response txt) + ;;txt + (response/full + 200 ; code + #"Okay" ; message + (current-seconds) ; seconds + #"text/javascript" ; mime type + '() ; headers + (list (string->bytes/utf-8 txt)))) ; body + +;; a request is a name and a list of arguments +(define (req name args) (list name args)) +(define (req-name r) (list-ref r 0)) +(define (req-args r) (list-ref r 1)) + +;; get the argument by name from the request +(define (req-arg r n) + (let ((kv (assq n (req-args r)))) + (cond + (kv (cdr kv)) + (else + (printf "unknown arg ~a on request ~a~n" n (req-name r)))))) + +;; check for the existance of an argument +(define (req-has-arg? r n) + (list-contains-equal? (req-args r) n)) + +;; a register is a request and the procedure to call +(define (register req proc) (list req proc)) +(define (register-req r) (list-ref r 0)) +(define (register-proc r) (list-ref r 1)) + +; builds the argument list from the registered requests +(define (request-run reg req) + (apply (register-proc reg) + (map + (lambda (arg) + ;; if it's registered as an argument + (if (req-has-arg? (register-req reg) (car arg)) + ;; send it through plain + (filter-string (cdr arg)) + ;; send it with the argument name + (cons (string->symbol (filter-string (symbol->string (car arg)))) + (filter-string (cdr arg))))) + (req-args req)))) + +;; look up this request in the registry and run it +(define (request-dispatch reg req) + (cond + ((null? reg) (printf "unknown command ~a~n" (req-name req)) + (pluto-response (string-append "unknown command " (symbol->string (req-name req))))) + ((equal? (req-name (register-req (car reg))) (req-name req)) + (request-run (car reg) req)) + (else + (request-dispatch (cdr reg) req)))) diff --git a/web/scripts/sync.ss b/web/scripts/sync.ss new file mode 100644 index 0000000000000000000000000000000000000000..b275bb22b65f8de7abaebd53fcebae55370c76bd --- /dev/null +++ b/web/scripts/sync.ss @@ -0,0 +1,149 @@ +#lang racket + +;; MongooseWeb Copyright (C) 2013 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require (planet jaymccarthy/sqlite:5:1/sqlite)) +(require "eavdb.ss") +(require "utils.ss") +(provide (all-defined-out)) + + +(define (request-args->ktvlist data) + (map + (lambda (i) + (msg i) + (let ((kv (string-split (symbol->string (car i)) '(#\:)))) + (list + (car kv) (cadr kv) (cdr i)))) + data)) + +(define (sync-update db table entity-type unique-id dirty version data) + (let ((entity-id (entity-id-from-unique db table unique-id)) + (ktvlist (dbg (request-args->ktvlist data)))) + (update-to-version db table entity-id version ktvlist) + (list "updated" unique-id))) + +(define (sync-insert db table entity-type unique-id dirty version data) + (let ((ktvlist (dbg (request-args->ktvlist data)))) + (insert-entity-wholesale db table entity-type unique-id dirty version ktvlist) + (list "inserted" unique-id))) + +(define (send-version db table entity-type unique-id current-version) + (let ((entity-id (entity-id-from-unique db table unique-id))) + (list + "new version" + (list table entity-type entity-id unique-id current-version) + (get-entity db table entity-id)))) + +(define (check-for-sync db table entity-type unique-id dirty version data) + (let ((current-version (entity-version-from-unique db table unique-id))) + (if (not (null? current-version)) + ;; if it exists + (cond + ;; everything matches - no change + ((and (eq? dirty 0) (eq? version current-version)) + (list "no change" unique-id)) + + ;; dirty but matches, should be ok (timeout causes this) + ((and (eq? dirty 1) (eq? version current-version)) + (list "match" unique-id)) + + ;; need to update existing data, newer version from android + ((and (eq? dirty 1) (> version current-version) ) + (sync-update db table entity-type unique-id dirty version data)) + + ;; need to send update + ((and (eq? dirty 0) (< version current-version)) + (send-version db table entity-type unique-id current-version)) + + ;; it's changed, but has an old or same version = conflict!!?? + ((and (eq? dirty 1) (<= version current-version)) + (list "CONFLICT" unique-id)) + + ;; android version is newer but not changed?? + ((and (eq? dirty 0) (> version current-version)) + (list "MISMATCH" unique-id)) + + (else + (list "WAT?" unique-id))) + + ;; doesnt exist yet, so insert it + (sync-insert db table entity-type unique-id dirty version data)))) + +(define (entity-versions db table) + (map + (lambda (i) + (list (vector-ref i 0) (vector-ref i 1))) + (cdr (db-select + db (string-append "select unique_id, version from " table "_entity;"))))) + +(define (send-entity db table unique-id) + (let* ((entity-id (entity-id-from-unique db table unique-id)) + (entity (db-select + db (string-append "select entity_type, unique_id, version from " + table "_entity where entity_id = ?") + entity-id))) + (if (not (null? entity)) + (list + (vector->list (cadr entity)) + (get-entity-plain db table entity-id)) + (list "entity not found" unique-id)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;(define db (open-db "test.db")) + +;;(add-entity +;; db "mongoose" +;; (list +;; (ktv "code" "varchar" "brendon") +;; (ktv "gender" "varchar" "male") +;; (ktv "pack-id" "int" 1) +;; (ktv "weight" "real" 10.4))) + +(define (choose l) (list-ref l (random (length l)))) + +(define (random-string len) + (if (zero? len) + "" (string-append (choose (list "g" "t" "a" "c")) + (random-string (- len 1))))) + +(define (random-ktv) + (ktv (random-string 2) "varchar" (random-string 4096))) + +(define (random-entity size) + (if (zero? size) + '() (cons (random-ktv) (random-entity (- size 1))))) + +(define (insert-random-entity db) + (msg "building") + (let ((e (random-entity 40))) + (msg "inserting") + (insert-entity + db (random-string 2) e))) + +(define (build db n) + (when (not (zero? n)) + (msg "adding entity" n) + (insert-random-entity db) + (build db (- n 1)))) + +(define (test) + (let ((db (db-open "unit.db"))) + (build db 99999999) + )) + +;(test) diff --git a/web/scripts/txt.ss b/web/scripts/txt.ss new file mode 100644 index 0000000000000000000000000000000000000000..b05c5e93bf6ce26d3359f05b2a699c071673600d --- /dev/null +++ b/web/scripts/txt.ss @@ -0,0 +1,44 @@ +;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +#lang scheme +(provide (all-defined-out)) + +;; this is bonkers - what am I missing here? + +(define (scheme->txt v) + (cond + ((number? v) (number->string v)) + ((symbol? v) (string-append "'" (symbol->string v))) + ((string? v) (string-append "\"" v "\"")) + ((boolean? v) (if v "#t" "#f")) + ((list? v) + (cond + ((null? v) "'()") + (else + (list->txt v)))) + (else (printf "scheme->txt, unsupported type for ~a~n" v) 0))) + +(define (list->txt l) + (define (_ l s) + (cond + ((null? l) s) + (else + (_ (cdr l) + (string-append + s + (if (not (string=? s "")) " " "") + (scheme->txt (car l))))))) + (string-append "(" (_ l "") ")")) diff --git a/web/scripts/utils.ss b/web/scripts/utils.ss new file mode 100644 index 0000000000000000000000000000000000000000..9e66747c4ba30ff1ca40fcbfb6dd3587199b0ab9 --- /dev/null +++ b/web/scripts/utils.ss @@ -0,0 +1,138 @@ +#lang racket + +;; MongooseWeb Copyright (C) 2013 Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(provide (all-defined-out)) + +(define (msg . args) + (for-each + (lambda (i) (display i)(display " ")) + args) + (newline)) + +(define (dbg i) (msg i) i) + +(define (assert msg v) + (display (string-append "testing " msg))(newline) + (when (not v) + (error "unit " msg))) + +(define (asserteq msg a b) + (display (string-append "testing " msg))(newline) + (when (not (equal? a b)) + (error "unit " msg a b))) + + +; +; -- procedure+: string-split STRING +; -- procedure+: string-split STRING '() +; -- procedure+: string-split STRING '() MAXSPLIT +; +; Returns a list of whitespace delimited words in STRING. +; If STRING is empty or contains only whitespace, then the empty list +; is returned. Leading and trailing whitespaces are trimmed. +; If MAXSPLIT is specified and positive, the resulting list will +; contain at most MAXSPLIT elements, the last of which is the string +; remaining after (MAXSPLIT - 1) splits. If MAXSPLIT is specified and +; non-positive, the empty list is returned. "In time critical +; applications it behooves you not to split into more fields than you +; really need." +; +; -- procedure+: string-split STRING CHARSET +; -- procedure+: string-split STRING CHARSET MAXSPLIT +; +; Returns a list of words delimited by the characters in CHARSET in +; STRING. CHARSET is a list of characters that are treated as delimiters. +; Leading or trailing delimeters are NOT trimmed. That is, the resulting +; list will have as many initial empty string elements as there are +; leading delimiters in STRING. +; +; If MAXSPLIT is specified and positive, the resulting list will +; contain at most MAXSPLIT elements, the last of which is the string +; remaining after (MAXSPLIT - 1) splits. If MAXSPLIT is specified and +; non-positive, the empty list is returned. "In time critical +; applications it behooves you not to split into more fields than you +; really need." +; +; This is based on the split function in Python/Perl +; +; (string-split " abc d e f ") ==> ("abc" "d" "e" "f") +; (string-split " abc d e f " '() 1) ==> ("abc d e f ") +; (string-split " abc d e f " '() 0) ==> () +; (string-split ":abc:d:e::f:" '(#\:)) ==> ("" "abc" "d" "e" "" "f" "") +; (string-split ":" '(#\:)) ==> ("" "") +; (string-split "root:x:0:0:Lord" '(#\:) 2) ==> ("root" "x:0:0:Lord") +; (string-split "/usr/local/bin:/usr/bin:/usr/ucb/bin" '(#\:)) +; ==> ("/usr/local/bin" "/usr/bin" "/usr/ucb/bin") +; (string-split "/usr/local/bin" '(#\/)) ==> ("" "usr" "local" "bin") + +(define (string-split str . rest) + ; maxsplit is a positive number + (define (split-by-whitespace str maxsplit) + (define (skip-ws i yet-to-split-count) + (cond + ((>= i (string-length str)) '()) + ((char-whitespace? (string-ref str i)) + (skip-ws (add1 i) yet-to-split-count)) + (else (scan-beg-word (add1 i) i yet-to-split-count)))) + (define (scan-beg-word i from yet-to-split-count) + (cond + ((zero? yet-to-split-count) + (cons (substring str from (string-length str)) '())) + (else (scan-word i from yet-to-split-count)))) + (define (scan-word i from yet-to-split-count) + (cond + ((>= i (string-length str)) + (cons (substring str from i) '())) + ((char-whitespace? (string-ref str i)) + (cons (substring str from i) + (skip-ws (add1 i) (- yet-to-split-count 1)))) + (else (scan-word (add1 i) from yet-to-split-count)))) + (skip-ws 0 (- maxsplit 1))) + + ;; maxsplit is a positive number + ;; str is not empty + (define (split-by-charset str delimeters maxsplit) + (define (scan-beg-word from yet-to-split-count) + (cond + ((>= from (string-length str)) '("")) + ((zero? yet-to-split-count) + (cons (substring str from (string-length str)) '())) + (else (scan-word from from yet-to-split-count)))) + (define (scan-word i from yet-to-split-count) + (cond + ((>= i (string-length str)) + (cons (substring str from i) '())) + ((memq (string-ref str i) delimeters) + (cons (substring str from i) + (scan-beg-word (add1 i) (- yet-to-split-count 1)))) + (else (scan-word (add1 i) from yet-to-split-count)))) + (scan-beg-word 0 (- maxsplit 1))) + + ;; resolver of overloading... + ;; if omitted, maxsplit defaults to + ;; (inc (string-length str)) + (if (eq? (string-length str) 0) '() + (if (null? rest) + (split-by-whitespace str (add1 (string-length str))) + (let ((charset (car rest)) + (maxsplit + (if (pair? (cdr rest)) (cadr rest) (add1 (string-length str))))) + (cond + ((not (positive? maxsplit)) '()) + ((null? charset) (split-by-whitespace str maxsplit)) + (else (split-by-charset str charset maxsplit)))))) +) diff --git a/web/server.scm b/web/server.scm new file mode 100755 index 0000000000000000000000000000000000000000..61448eefd63a7007b43a429d15d550d623538990 --- /dev/null +++ b/web/server.scm @@ -0,0 +1,135 @@ +#!/usr//bin/env mzscheme +#lang scheme/base +;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths +;; +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. +;; +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see . + +(require scheme/system + scheme/foreign + scheme/cmdline + web-server/servlet + web-server/servlet-env + web-server/http/response-structs + "scripts/request.ss" + "scripts/logger.ss" + "scripts/json.ss" + "scripts/sync.ss" + "scripts/utils.ss" + "scripts/eavdb.ss" + "scripts/txt.ss" +; "scripts/input.ss" + ) + +; a utility to change the process owner, +; assuming mzscheme is called by root. +;;(unsafe!) +;;(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int))) + +(define db-name "client/htdocs/mongoose.db") +(define db (db-open db-name)) +(open-log "log.txt") + +;(write-db db "sync" "/home/dave/code/mongoose-web/web/input.csv") + +(define registered-requests + (list + + (register + (req 'ping '()) + (lambda () + (pluto-response (scheme->txt '("hello"))))) + + ;; http://localhost:8888/mongoose?fn=sync&table=sync&entity-type=mongoose&unique-id=dave1234&dirty=1&version=0&next:varchar=%22foo%22&blah:int=20 + + (register + (req 'sync '(table entity-type unique-id dirty version)) + (lambda (table entity-type unique-id dirty version . data) + (pluto-response + (scheme->txt + (check-for-sync + db + table + entity-type + unique-id + (string->number dirty) + (string->number version) data))))) + + (register + (req 'entity-versions '(table)) + (lambda (table) + (pluto-response + (scheme->txt + (entity-versions db table))))) + + (register + (req 'entity '(table unique-id)) + (lambda (table unique-id) + (pluto-response + (scheme->txt + (send-entity db table unique-id))))) + + (register + (req 'entity-types '(table)) + (lambda (table) + (pluto-response + (scheme->txt + (get-all-entity-types db table))))) + + (register + (req 'entity-csv '(table type)) + (lambda (table type) + (let ((r (csv db table type))) + (msg "--------------------------------------- csv request for" type "[" r "]") + (pluto-response + r)))) + + )) + +(define (start request) + (let ((values (url-query (request-uri request)))) + (msg "got a request" request) + (if (not (null? values)) ; do we have some parameters? + (let ((name (assq 'fn values))) + (if name ; is this a well formed request? + (request-dispatch + registered-requests + (req (string->symbol (cdr name)) + (filter + (lambda (v) + (not (eq? (car v) 'fn))) + values))) + (pluto-response "could't find a function name"))) + (pluto-response "malformed thingy")))) + +(printf "server is running...~n") + +; Here we become the user 'nobody'. +; This is a security rule that *only works* if nobody owns no other processes +; than mzscheme. Otherwise better create another dedicated unprivileged user. +; Note: 'nobody' must own the state directory and its files. + +;(setuid 65534) + +;; + +(serve/servlet + start + ;; port number is read from command line as argument + ;; ie: ./server.scm 8080 + #:listen-ip "192.168.2.1" + #:port (string->number (command-line #:args (port) port)) + #:command-line? #t + #:servlet-path "/mongoose" + #:server-root-path + (build-path "client"))