Skip to content

GitLab

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

database stuff, unique ids and dirty flags preparing for syncing

parent b4b9389a
Hide whitespace changes
Inline Side-by-side
Showing with 217 additions and 125 deletions
android/assets/eavdb.scm
View file @ 8f9f1217
......@@ -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)
android/assets/lib.scm
View file @ 8f9f1217
......@@ -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))
......
android/assets/starwisp.scm
View file @ 8f9f1217
......@@ -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)
......
android/jni/main.cpp
View file @ 8f9f1217
......@@ -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;
}
android/jni/scheme/opdefines.h
View file @ 8f9f1217
......@@ -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
android/jni/scheme/scheme.cpp
View file @ 8f9f1217
......@@ -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);
......
android/jni/scheme/scheme.h
View file @ 8f9f1217
......@@ -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