Commit 8f9f1217 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

database stuff, unique ids and dirty flags preparing for syncing

parent b4b9389a
......@@ -20,12 +20,12 @@
(define db-select db-exec)
;; create eav tables (add types as required)
(define (setup db)
(exec/ignore db "create table entity ( entity_id integer primary key autoincrement, entity_type varchar(256))")
(exec/ignore db "create table attribute ( id integer primary key autoincrement, attribute_id varchar(256), entity_type varchar(256), attribute_type varchar(256))")
(exec/ignore db "create table value_varchar ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096))")
(exec/ignore db "create table value_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer)")
(exec/ignore db "create table value_real ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value real)"))
(define (setup db table)
(exec/ignore db (string-append "create table " table "_entity ( entity_id integer primary key autoincrement, entity_type varchar(256), unique_id varchar(256), dirty integer)"))
(exec/ignore db (string-append "create table " table "_attribute ( id integer primary key autoincrement, attribute_id varchar(256), entity_type varchar(256), attribute_type varchar(256))"))
(exec/ignore db (string-append "create table " table "_value_varchar ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096))"))
(exec/ignore db (string-append "create table " table "_value_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer)"))
(exec/ignore db (string-append "create table " table "_value_real ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value real)")))
(define (sqls str)
;; todo sanitise str
......@@ -54,24 +54,24 @@
;; putting data in
;; get the type from the attribute table with an entity/key
(define (get-attribute-type db entity-type key)
(define (get-attribute-type db table entity-type key)
(let ((sql (string-append
"select attribute_type from attribute where entity_type = '"
"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 entity-type key type)
(let ((t (get-attribute-type db entity-type key)))
(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 attribute values (null, '"
"insert into " table "_attribute values (null, '"
(sqls key) "', '" (sqls entity-type) "', '" (sqls type) "')"))
type)
(else
......@@ -85,42 +85,67 @@
type))))))
;; low level insert of a ktv
(define (insert-value db entity-id 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 value_" (sqls (ktv-type ktv))
(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) ")")))
(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 entity-type ktvlist)
(define (insert-entity db table entity-type user ktvlist)
(msg table entity-type ktvlist)
(let ((id (db-insert
db (string-append
"insert into entity values (null, '" (sqls entity-type) "')"))))
"insert into " table "_entity values (null, '" (sqls entity-type) "', '" (get-unique user) "', 1)"))))
;; create the attributes if they are new, and validate them if they exist
(for-each
(lambda (ktv)
(find/add-attribute-type db entity-type (ktv-key ktv) (ktv-type 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 id 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-dirty db table entity-id v)
(db-exec
db (string-append "update " table "_entity "
"set dirty='" (number->string v) "'"
" where entity_id = " (number->string entity-id) ";")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; getting data out
(define (get-entity-type db entity-id)
(define (get-entity-type db table entity-id)
(select-first
db (string-append
"select entity_type from entity where entity_id = " (number->string entity-id))))
"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 entity-type)
(define (get-attribute-ids/types db table entity-type)
(let ((s (db-select
db (string-append
"select * from attribute where entity_type = '" (sqls entity-type) "'"))))
"select * from " table "_attribute where entity_type = '"
(sqls entity-type) "'"))))
(if (null? s) '()
(map
(lambda (row)
......@@ -129,15 +154,15 @@
(cdr s)))))
;; get the value given an entity type, a attribute type and it's key (= attriute_id)
(define (get-value db entity-id kt)
(define (get-value db table entity-id kt)
(select-first
db (string-append "select value from value_" (sqls (ktv-type kt))
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 db entity-id)
(let* ((entity-type (get-entity-type db entity-id)))
(define (get-entity 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
......@@ -145,18 +170,20 @@
(list "entity_id" "int" entity-id)
(map
(lambda (kt)
(list (ktv-key kt) (ktv-type kt) (get-value db entity-id kt)))
(get-attribute-ids/types db entity-type)))))))
(list (ktv-key kt) (ktv-type kt) (get-value db table entity-id kt)))
(get-attribute-ids/types db table entity-type)))))))
(define (all-entities db type)
(map
(lambda (i)
(string->number (vector-ref i 0)))
(cdr
(db-select
db
(string-append "select entity_id from entity where entity_type = '" type "';")))))
(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
......@@ -172,17 +199,54 @@
(ktv-value (car ktv-list)))
(else (ktv-get (cdr ktv-list) key))))
(define (db-all db type)
(define (db-all db table type)
(map
(lambda (i)
(get-entity db i))
(all-entities db type)))
(get-entity db table i))
(all-entities db table type)))
(define (db-all-where db type clause)
(define (db-all-where db table type clause)
(foldl
(lambda (i r)
(let ((e (get-entity db i)))
(let ((e (get-entity db table i)))
(if (equal? (ktv-get e (car clause)) (cadr clause))
(cons e r) r)))
'()
(all-entities db type)))
(all-entities db table type)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; updating data
;; update an entire 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
(update-entity-dirty db table entity-id 1)
(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)))
;; todo
;; update (with partial values)
......@@ -13,6 +13,8 @@
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; debugging and unit tests
(define (msg . args)
(for-each
......@@ -22,6 +24,19 @@
(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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; list stuff
(define (filter fn l)
(foldl
(lambda (i r)
......@@ -35,17 +50,50 @@
(insert (car lst) fn
(sort (cdr lst) fn))))
(define (find n l)
(cond
((null? l) #f)
((equal? n (car (car l))) (car l))
(else (find n (cdr l)))))
(define (build-list fn n)
(define (_ fn n l)
(cond ((zero? n) l)
(else
(_ fn (- n 1) (cons (fn (- n 1)) l)))))
(_ fn n '()))
(define (foldl op initial seq)
(define (iter result rest)
(if (null? rest)
result
(iter (op (car rest) result) (cdr rest))))
(iter initial seq))
(define (insert-to i p l)
(cond
((null? l) (list i))
((zero? p) (cons i l))
(else
(cons (car l) (insert-to i (- p 1) (cdr 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 (error . args)
(display (apply string-append args))(newline))
(define (insert elt fn sorted-lst)
(if (null? sorted-lst)
(list elt)
(if (fn elt (car sorted-lst))
(cons elt sorted-lst)
(cons (car sorted-lst)
(insert elt fn (cdr sorted-lst))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; time
;; just for graph so don't have to be accurate!!!
(define (date->day d)
......@@ -76,66 +124,7 @@
"/"
(number->string (list-ref d 2))))
(define (insert elt fn sorted-lst)
(if (null? sorted-lst)
(list elt)
(if (fn elt (car sorted-lst))
(cons elt sorted-lst)
(cons (car sorted-lst)
(insert elt fn (cdr sorted-lst))))))
;; utils funcs for using lists as sets
(define (set-remove a l)
(if (null? l)
'()
(if (eq? (car l) a)
(set-remove a (cdr l))
(cons (car l) (set-remove a (cdr l))))))
(define (set-add a l)
(if (not (memq a l))
(cons a l)
l))
(define (set-contains a l)
(if (not (memq a l))
#f
#t))
;; missing list stuff
(define (build-list fn n)
(define (_ fn n l)
(cond ((zero? n) l)
(else
(_ fn (- n 1) (cons (fn (- n 1)) l)))))
(_ fn n '()))
(define (foldl op initial seq)
(define (iter result rest)
(if (null? rest)
result
(iter (op (car rest) result) (cdr rest))))
(iter initial seq))
(define (insert-to i p l)
(cond
((null? l) (list i))
((zero? p) (cons i l))
(else
(cons (car l) (insert-to i (- p 1) (cdr 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)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; random
(define random-maker
......@@ -233,7 +222,8 @@
(if (> (vdot n v) 0)
v
(loop (hsrndvec)))))
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; convert scheme values into equivilent json strings
(define (scheme->json v)
......@@ -278,6 +268,7 @@
(string-append "{" (_ l "") "\n" "}"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; android ui
(define (layout width height weight gravity) (list "layout" width height weight gravity))
(define (layout-width l) (list-ref l 1))
......
......@@ -18,8 +18,18 @@
(define db "/sdcard/test.db")
(db-open db)
(setup db)
(display (db-exec db "select * from entity"))(newline)
(setup db "local")
(setup db "sync")
(setup db "stream")
(insert-entity-if-not-exists
db "local" "app-settings" "null" 1
(list
(ktv "user-id" "varchar" "No name yet...")))
(display (db-all db "local" "app-settings"))(newline)
(display (db-status db))(newline)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -50,7 +60,6 @@
(define (get-current key)
(store-get store key))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (mbutton id title fn)
......@@ -86,13 +95,23 @@
(mbutton "main-experiments" "Experiments" (lambda () (list (start-activity "experiments" 2 ""))))
(mbutton "main-manage" "Manage Packs" (lambda () (list (start-activity "manage-packs" 2 ""))))
(mbutton "main-tag" "Tag Location" (lambda () (list (start-activity "tag-location" 2 ""))))
(mtext "foo" "Your ID")
(edit-text (make-id "main-id-text") "" 30 fillwrap
(lambda (v)
(set-current! 'user-id v)
(update-entity
db "local" 1 (list (ktv "user-id" "varchar" v)))))
(mtext "foo" "Database")
(horiz
(mbutton "main-send" "Email" (lambda () (list)))
(mbutton "main-sync" "Sync" (lambda () (list)))))
(lambda (activity arg)
(activity-layout activity))
(lambda (activity arg) (list))
(lambda (activity arg)
(let ((user-id (ktv-get (get-entity db "local" 1) "user-id")))
(set-current! 'user-id user-id)
(list
(update-widget 'edit-text (get-id "main-id-text") 'text user-id))))
(lambda (activity) '())
(lambda (activity) '())
(lambda (activity) '())
......@@ -319,9 +338,11 @@
(button (make-id (string-append "manage-packs-pack-" name))
name 20 fillwrap
(lambda ()
(msg "going to manage individuals")
(msg pack)
(set-current! 'pack pack)
(list (start-activity "manage-individual" 2 ""))))))
(db-all db "pack")))))
(db-all db "sync" "pack")))))
(activity
"manage-packs"
(vert
......@@ -351,15 +372,16 @@
(spacer 10)
(text-view (make-id "new-pack-name-text") "Pack name" 20 fillwrap)
(edit-text (make-id "new-pack-name") "" 30 fillwrap
(lambda (v) (set-current! 'pack-name v) '()))
(lambda (v) (msg "edit callback" v) (set-current! 'pack-name v) '()))
(spacer 10)
(horiz
(button (make-id "new-pack-cancel") "Cancel" 20 fillwrap (lambda () (list (finish-activity 2))))
(button (make-id "new-pack-done") "Done" 20 fillwrap
(lambda ()
(insert-entity
db "pack" (list
(ktv "name" "varchar" (get-current 'pack-name))))
db "sync" "pack" (get-current 'user-id)
(list
(ktv "name" "varchar" (get-current 'pack-name))))
(list (finish-activity 2)))))
)
(lambda (activity arg)
......@@ -373,6 +395,7 @@
(let ((build-individual-buttons
(lambda ()
(msg "building individual buttons")
(map
(lambda (individual)
(let ((name (ktv-get individual "name")))
......@@ -381,7 +404,7 @@
(lambda ()
(list (start-activity "manage-individual" 2 ""))))))
(db-all-where
db "mongoose"
db "sync" "mongoose"
(list "pack-id" (number->string (ktv-get (get-current 'pack) "entity_id"))))
))))
(activity
......@@ -435,13 +458,14 @@
(button (make-id "new-individual-done") "Done" 20 fillwrap
(lambda ()
(insert-entity
db "mongoose" (list
(ktv "name" "varchar" (get-current 'individual-name))
(ktv "gender" "varchar" (get-current 'individual-gender))
(ktv "litter-code" "varchar" (get-current 'individual-litter-code))
(ktv "chip-code" "varchar" (get-current 'individual-chip-code))
(ktv "pack-id" "int" (ktv-get (get-current 'pack) "entity_id"))
))
db "sync" "mongoose" (get-current 'user-id)
(list
(ktv "name" "varchar" (get-current 'individual-name))
(ktv "gender" "varchar" (get-current 'individual-gender))
(ktv "litter-code" "varchar" (get-current 'individual-litter-code))
(ktv "chip-code" "varchar" (get-current 'individual-chip-code))
(ktv "pack-id" "int" (ktv-get (get-current 'pack) "entity_id"))
))
(list (finish-activity 2)))))
)
(lambda (activity arg)
......
......@@ -81,6 +81,8 @@ int main(int argc, char *argv[])
appEval("(display \"loaded eavdb\")(newline)");
appEval((char*)LoadFile("../assets/starwisp.scm").c_str());
appEval("(display \"loaded starwisp\")(newline)");
appEval((char*)LoadFile("../assets/unit-tests.scm").c_str());
appEval("(display \"loaded unit tests\")(newline)");
return 0;
}
......@@ -196,6 +196,7 @@
_OP_DEF(opexe_6, "db-exec", 2, 2, TST_NONE, OP_EXEC_DB )
_OP_DEF(opexe_6, "db-insert", 2, 2, TST_NONE, OP_INSERT_DB )
_OP_DEF(opexe_6, "db-status", 1, 1, TST_NONE, OP_STATUS_DB )
_OP_DEF(opexe_6, "time", 0, 0, TST_NONE, OP_TIME )
#undef _OP_DEF
......@@ -30,6 +30,7 @@
#include <limits.h>
#include <float.h>
#include <ctype.h>
#include <sys/time.h>
#include "core/db_container.h"
db_container the_db_container;
......@@ -4313,6 +4314,15 @@ static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
}
s_return(sc,sc->F);
}
case OP_TIME: {
timeval t;
// stop valgrind complaining
t.tv_sec=0;
t.tv_usec=0;
gettimeofday(&t,NULL);
s_return(sc,cons(sc,mk_integer(sc,t.tv_sec),
cons(sc,mk_integer(sc,t.tv_usec),sc->NIL)));
}
////////////////////
default:
snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
......
......@@ -73,9 +73,9 @@ extern "C" {
# define USE_STRING_PORTS 1
#endif
#ifndef USE_TRACING
//#ifndef USE_TRACING
# define USE_TRACING 1
#endif
//#endif
#ifndef USE_PLIST
# define USE_PLIST 0
......@@ -110,9 +110,9 @@ extern "C" {
# define USE_INTERFACE 0
#endif
#ifndef SHOW_ERROR_LINE /* Show error line in file */
//#ifndef SHOW_ERROR_LINE /* Show error line in file */
# define SHOW_ERROR_LINE 1
#endif
//#endif
typedef struct scheme scheme;
typedef struct cell *pointer;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment