Commit 0e50d863 authored by dave griffiths's avatar dave griffiths
Browse files

Merge branch 'master' of github.com:nebogeo/symbai

parents 4476095c cf2a1dd5
...@@ -185,14 +185,18 @@ ...@@ -185,14 +185,18 @@
;; todo fix all hardcoded paths here ;; todo fix all hardcoded paths here
(define (send-files ktvlist) (define (send-files ktvlist)
(msg "send-files" ktvlist)
(foldl (foldl
(lambda (ktv r) (lambda (ktv r)
(msg (ktv-type ktv))
(if (equal? (ktv-type ktv) "file") (if (equal? (ktv-type ktv) "file")
(cons (http-upload (begin
(string-append "upload-" (ktv-value ktv)) (msg "sending" (ktv-value ktv))
"http://192.168.2.1:8889/symbai?fn=upload" (cons (http-upload
(string-append "/sdcard/symbai/files/" (ktv-value ktv))) (string-append "upload-" (ktv-value ktv))
r) "http://192.168.2.1:8889/symbai?fn=upload"
(string-append "/sdcard/symbai/files/" (ktv-value ktv)))
r))
r)) r))
'() ktvlist)) '() ktvlist))
...@@ -210,62 +214,69 @@ ...@@ -210,62 +214,69 @@
(string-append "req-" (list-ref (car e) 1)) (string-append "req-" (list-ref (car e) 1))
(build-url-from-entity table e) (build-url-from-entity table e)
(lambda (v) (lambda (v)
(msg "in spit..." v)
(cond (cond
((or (equal? (car v) "inserted") (equal? (car v) "match")) ((or (equal? (car v) "inserted") (equal? (car v) "match"))
(update-entity-clean db table (cadr v)) (update-entity-clean db table (cadr v))
(append (debug! (string-append "Uploaded " (car (car e)))))
(send-files e)
(debug! (string-append "Uploaded " (car (car e))))))
((equal? (car v) "no change") ((equal? (car v) "no change")
(debug! (string-append "No change for " (car (car e))))) (debug! (string-append "No change for " (car (car e)))))
((equal? (car v) "updated") ((equal? (car v) "updated")
;; send new files hereish
(update-entity-clean db table (cadr v)) (update-entity-clean db table (cadr v))
(append (debug! (string-append "Updated changed " (car (car e)))))
(send-files e)
(debug! (string-append "Updated changed " (car (car e))))))
(else (else
(debug! (string-append (debug! (string-append
"Problem uploading " "Problem uploading "
(car (car e)) " : " (car v))))) (car (car e)) " : " (car v)))))
(list (append
(update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db)))))) ;; check for file uploads
(if (or (equal? (car v) "updated")
(equal? (car v) "inserted")
(equal? (car v) "match"))
(send-files (cadr e)) ;; takes a ktvlist
'())
(list
(update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db)))))))
r)) r))
'() '()
entities)) entities))
(msg "request files")
;; todo fix all hardcoded paths here ;; todo fix all hardcoded paths here
(define (request-files ktvlist) (define (request-files ktvlist)
(msg "request-files")
(foldl (foldl
(lambda (ktv r) (lambda (ktv r)
(if (equal? (ktv-type ktv) "file") (if (equal? (ktv-type ktv) "file")
(cons (http-download (begin
(string-append "download-" (ktv-value ktv)) (msg "requesting" (ktv-value ktv))
(string-append "http://192.168.2.1:8889/files/" (ktv-value ktv)) (cons (http-download
(string-append "/sdcard/symbai/files/" (ktv-value ktv))) (string-append "download-" (ktv-value ktv))
r) (string-append "http://192.168.2.1:8889/files/" (ktv-value ktv))
(string-append "/sdcard/symbai/files/" (ktv-value ktv)))
r))
r)) r))
'() ktvlist)) '() ktvlist))
(msg "suck ent") (msg "suck ent")
(define (suck-entity-from-server db table unique-id exists) (define (suck-entity-from-server db table unique-id)
;; ask for the current version ;; ask for the current version
(http-request (http-request
(string-append unique-id "-update-new") (string-append unique-id "-update-new")
(string-append url "fn=entity&table=" table "&unique-id=" unique-id) (string-append url "fn=entity&table=" table "&unique-id=" unique-id)
(lambda (data) (lambda (data)
;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity' ;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity'
(let ((entity (list-ref data 0)) (let* ((entity (list-ref data 0))
(ktvlist (list-ref data 1))) (ktvlist (list-ref data 1))
(unique-id (list-ref entity 1))
(exists (entity-exists? db table unique-id)))
;; need to check exists again here, due to delays back and forth
(if (not exists) (if (not exists)
(insert-entity-wholesale (insert-entity-wholesale
db table db table
(list-ref entity 0) ;; entity-type (list-ref entity 0) ;; entity-type
(list-ref entity 1) ;; unique-id unique-id
0 ;; dirty 0 ;; dirty
(list-ref entity 2) ;; version (list-ref entity 2) ;; version
ktvlist) ktvlist)
...@@ -273,12 +284,14 @@ ...@@ -273,12 +284,14 @@
db table (get-entity-id db table unique-id) db table (get-entity-id db table unique-id)
(list-ref entity 2) ktvlist)) (list-ref entity 2) ktvlist))
(debug! (string-append (if exists "Got new: " "Updated: ") (ktv-get ktvlist "name"))) (debug! (string-append (if exists "Got new: " "Updated: ") (ktv-get ktvlist "name")))
(list (cons
(request-files ktvlist) (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db))
(update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db))))))) (request-files ktvlist))))))
;; repeatedly read version and request updates ;; repeatedly read version and request updates
(define (suck-new db table) (define (suck-new db table)
(msg "suck-new")
(debug! "Requesting new entities") (debug! "Requesting new entities")
(list (list
(http-request (http-request
...@@ -298,7 +311,7 @@ ...@@ -298,7 +311,7 @@
#f))) #f)))
;; if we don't have this entity or the version on the server is newer ;; if we don't have this entity or the version on the server is newer
(if (or (not exists) old) (if (or (not exists) old)
(cons (suck-entity-from-server db table unique-id exists) r) (cons (suck-entity-from-server db table unique-id) r)
r))) r)))
'() '()
data))) data)))
...@@ -329,6 +342,7 @@ ...@@ -329,6 +342,7 @@
"Stream data: " (number->string (car stream)) "/" (number->string (cadr stream))))) "Stream data: " (number->string (car stream)) "/" (number->string (cadr stream)))))
(define (upload-dirty db) (define (upload-dirty db)
(msg "upload-dirty")
(let ((r (append (let ((r (append
(spit db "sync" (dirty-entities db "sync")) (spit db "sync" (dirty-entities db "sync"))
(spit db "stream" (dirty-entities db "stream"))))) (spit db "stream" (dirty-entities db "stream")))))
......
...@@ -233,6 +233,30 @@ ...@@ -233,6 +233,30 @@
(vector-ref i 0)) (vector-ref i 0))
(cdr s))))) (cdr s)))))
(define (all-entities-with-parent db table type parent)
(let ((s (db-select
db (string-append "select e.entity_id from " table "_entity as e "
"join " table "_value_varchar "
" as n on n.entity_id = e.entity_id and n.attribute_id = ?"
"join " table "_value_varchar "
" as p on p.entity_id = e.entity_id and p.attribute_id = ?"
"left join " table "_value_int "
"as d on d.entity_id = e.entity_id and d.attribute_id = ? "
"where e.entity_type = ? and "
"p.value = ? and "
"(d.value='NULL' or d.value is NULL or d.value = 0) "
"order by n.value")
"name" "parent" "deleted" type parent)))
(msg (db-status db))
(if (null? s)
'()
(map
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(define (validate db) (define (validate db)
;; check attribute for duplicate entity-id/attribute-ids ;; check attribute for duplicate entity-id/attribute-ids
0) 0)
...@@ -262,13 +286,17 @@ ...@@ -262,13 +286,17 @@
(else (cons (car ktv-list) (ktv-set (cdr ktv-list) ktv))))) (else (cons (car ktv-list) (ktv-set (cdr ktv-list) ktv)))))
(define (db-all db table type) (define (db-all db table type)
(prof-start "db-all") (map
(let ((r (map (lambda (i)
(get-entity db table i))
(all-entities db table type)))
(define (db-with-parent db table type parent)
(map
(lambda (i) (lambda (i)
(get-entity db table i)) (get-entity db table i))
(all-entities db table type)))) (all-entities-with-parent db table type parent)))
(prof-end "db-all")
r))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; updating data ;; updating data
......
...@@ -38,7 +38,7 @@ ...@@ -38,7 +38,7 @@
(list (list
(ktv "user-id" "varchar" "No name yet..."))) (ktv "user-id" "varchar" "No name yet...")))
(define entity-types '()) (define entity-types (list "village"))
;;(display (db-all db "local" "app-settings"))(newline) ;;(display (db-all db "local" "app-settings"))(newline)
...@@ -59,7 +59,9 @@ ...@@ -59,7 +59,9 @@
(list 'three (list "three")) (list 'three (list "three"))
(list 'village (list "Village")) (list 'village (list "Village"))
(list 'household (list "Household")) (list 'household (list "Household"))
(list 'households (list "Households"))
(list 'individual (list "Individual")) (list 'individual (list "Individual"))
(list 'individuals (list "Individuals"))
(list 'add-item (list "+")) (list 'add-item (list "+"))
(list 'default-village-name (list "New village")) (list 'default-village-name (list "New village"))
...@@ -112,6 +114,8 @@ ...@@ -112,6 +114,8 @@
(list 'market (list "Market")) (list 'market (list "Market"))
;; household ;; household
(list 'household-name (list "Household name"))
(list 'default-household-name (list "A household"))
(list 'location (list "House location")) (list 'location (list "House location"))
(list 'elevation (list "Elevation")) (list 'elevation (list "Elevation"))
(list 'toilet-location (list "Toilet location")) (list 'toilet-location (list "Toilet location"))
...@@ -123,6 +127,9 @@ ...@@ -123,6 +127,9 @@
(list 'add-individual (list "Add individual")) (list 'add-individual (list "Add individual"))
;; individual ;; individual
(list 'default-individual-name (list "A person"))
(list 'default-family-name (list "A family"))
(list 'default-photo-id (list "???"))
(list 'details (list "Details")) (list 'details (list "Details"))
(list 'family (list "Family")) (list 'family (list "Family"))
(list 'migration (list "Migration")) (list 'migration (list "Migration"))
...@@ -348,7 +355,7 @@ ...@@ -348,7 +355,7 @@
;; dispatches based on widget type ;; dispatches based on widget type
(define (mupdate widget-type id-symbol key) (define (mupdate widget-type id-symbol key)
(cond (cond
((eq? widget-type 'edit-text) ((or (eq? widget-type 'edit-text) (eq? widget-type 'text-view))
(update-widget widget-type (get-symbol-id id-symbol) 'text (update-widget widget-type (get-symbol-id id-symbol) 'text
(entity-get-value key))) (entity-get-value key)))
((eq? widget-type 'toggle-button) ((eq? widget-type 'toggle-button)
...@@ -395,13 +402,14 @@ ...@@ -395,13 +402,14 @@
(set-current! 'download 0) (set-current! 'download 0)
(connect-to-net (connect-to-net
(lambda () (lambda ()
(msg "connected, going in...")
(append (append
(list (toast "sync-cb")) (list (toast "sync-cb"))
(upload-dirty db) (upload-dirty db)
(suck-new db "sync"))))) (suck-new db "sync")))))
(else '())) (else '()))
(list (list
(delayed "debug-timer" (+ 5000 (random 5000)) debug-timer-cb) (delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
(update-debug)))) (update-debug))))
...@@ -539,17 +547,20 @@ ...@@ -539,17 +547,20 @@
;; a standard builder for list widgets of entities and a ;; a standard builder for list widgets of entities and a
;; make new button, to add defaults to the list ;; make new button, to add defaults to the list
(define (build-list-widget db table entity-type edit-activity ktv-default) (define (build-list-widget db table title entity-type edit-activity parent-fn ktv-default)
(vert-colour (vert-colour
colour-two colour-two
(horiz (horiz
(mtitle-scale 'villages) (mtitle-scale title)
(mbutton-scale (button
'add-item (make-id (string-append (symbol->string title) "-add"))
(mtext-lookup title)
40 (layout 'fill-parent 'wrap-content 1 'centre 5)
(lambda () (lambda ()
(entity-init! db table entity-type ktv-default) (entity-init! db table entity-type ktv-default)
(entity-add-value! "parent" "varchar" (parent-fn))
(entity-record-values!) (entity-record-values!)
(list (update-list-widget db table entity-type edit-activity))))) (list (update-list-widget db table entity-type edit-activity (parent-fn))))))
(linear-layout (linear-layout
(make-id (string-append entity-type "-list")) (make-id (string-append entity-type "-list"))
'vertical 'vertical
...@@ -558,8 +569,11 @@ ...@@ -558,8 +569,11 @@
(list)))) (list))))
;; pull db data into list of button widgets ;; pull db data into list of button widgets
(define (update-list-widget db table entity-type edit-activity) (define (update-list-widget db table entity-type edit-activity parent)
(let ((search-results (db-all db table entity-type))) (let ((search-results
(if parent
(db-with-parent db table entity-type parent)
(db-all db table entity-type))))
(update-widget (update-widget
'linear-layout 'linear-layout
(get-id (string-append entity-type "-list")) (get-id (string-append entity-type "-list"))
...@@ -626,7 +640,7 @@ ...@@ -626,7 +640,7 @@
'())) '()))
)))) ))))
(build-list-widget (build-list-widget
db "sync" "village" "village" db "sync" 'villages "village" "village" (lambda () #f)
(list (list
(ktv "name" "varchar" (mtext-lookup 'default-village-name)) (ktv "name" "varchar" (mtext-lookup 'default-village-name))
(ktv "block" "varchar" "") (ktv "block" "varchar" "")
...@@ -638,7 +652,7 @@ ...@@ -638,7 +652,7 @@
(set-current! 'activity-title "Main screen") (set-current! 'activity-title "Main screen")
(activity-layout activity)) (activity-layout activity))
(lambda (activity arg) (lambda (activity arg)
(list (update-list-widget db "sync" "village" "village"))) (list (update-list-widget db "sync" "village" "village" #f)))
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
...@@ -684,9 +698,11 @@ ...@@ -684,9 +698,11 @@
(take-photo (string-append dirname "files/" (entity-get-value "unique_id") "-face.jpg") photo-code)) (take-photo (string-append dirname "files/" (entity-get-value "unique_id") "-face.jpg") photo-code))
))) )))
(mbutton 'household-list
(lambda ()
(list (start-activity "household-list" 0
(get-current 'village #f)))))
(mbutton 'household-list (lambda () (list (start-activity "household-list" 0 ""))))
(mtitle 'amenities) (mtitle 'amenities)
(place-widgets 'school #t) (place-widgets 'school #t)
(place-widgets 'hospital #f) (place-widgets 'hospital #f)
...@@ -702,17 +718,14 @@ ...@@ -702,17 +718,14 @@
(set-current! 'activity-title "Village") (set-current! 'activity-title "Village")
(activity-layout activity)) (activity-layout activity))
(lambda (activity arg) (lambda (activity arg)
(msg "on start")
(msg "activity start - entity init")
(entity-init! db "sync" "village" (get-entity-by-unique db "sync" arg)) (entity-init! db "sync" "village" (get-entity-by-unique db "sync" arg))
(msg "activity start - entity init done") (set-current! 'village arg)
(list (list
(mupdate 'edit-text 'village-name "name") (mupdate 'edit-text 'village-name "name")
(mupdate 'edit-text 'block "block") (mupdate 'edit-text 'block "block")
(mupdate 'edit-text 'district "district") (mupdate 'edit-text 'district "district")
(mupdate 'toggle-button 'car "car") (mupdate 'toggle-button 'car "car")
(mupdate 'image-view 'photo "photo") (mupdate 'image-view 'photo "photo")))
(toast arg)))
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
...@@ -735,16 +748,22 @@ ...@@ -735,16 +748,22 @@
(activity (activity
"household-list" "household-list"
(build-activity (build-activity
(mbutton 'household (lambda () (list (start-activity "household" 0 "")))) (build-list-widget
(mbutton 'household (lambda () (list (start-activity "household" 0 "")))) db "sync" 'households "household" "household" (lambda () (get-current 'village #f))
(mbutton 'household (lambda () (list (start-activity "household" 0 "")))) (list
(mbutton 'household (lambda () (list (start-activity "household" 0 "")))) (ktv "name" "varchar" (mtext-lookup 'default-household-name))
(mbutton 'household (lambda () (list (start-activity "household" 0 "")))) (ktv "num-pots" "int" 0)
) (ktv "house-lat" "real" 0) ;; get from current location?
(ktv "house-lon" "real" 0)
(ktv "toilet-lat" "real" 0)
(ktv "toilet-lon" "real" 0))))
(lambda (activity arg) (lambda (activity arg)
(set-current! 'activity-title "Household List") (set-current! 'activity-title "Household List")
(activity-layout activity)) (activity-layout activity))
(lambda (activity arg) '()) (lambda (activity arg)
(msg "rebuilding household list with" arg)
(list (update-list-widget
db "sync" "household" "household" arg)))
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
...@@ -754,6 +773,9 @@ ...@@ -754,6 +773,9 @@
(activity (activity
"household" "household"
(build-activity (build-activity
(horiz
(medit-text 'household-name "normal" (lambda (v) '()))
(medit-text 'num-pots "numeric" (lambda (v) '())))
(horiz (horiz
(mtext 'location) (mtext 'location)
(vert (vert
...@@ -768,26 +790,24 @@ ...@@ -768,26 +790,24 @@
(mtext-small 'test-num) (mtext-small 'test-num)
(mtext-small 'test-num)) (mtext-small 'test-num))
(medit-text 'elevation "numeric" (lambda (v) '()))) (medit-text 'elevation "numeric" (lambda (v) '())))
(horiz
(medit-text 'num-pots "numeric" (lambda (v) '()))
(vert
(mtext 'children)
(horiz
(medit-text 'male "numeric" (lambda (v) '()))
(medit-text 'female "numeric" (lambda (v) '())))))
(mtitle 'adults)
(mbutton 'individual (lambda () (list (start-activity "individual" 0 ""))))
(mbutton 'individual (lambda () (list (start-activity "individual" 0 ""))))
(mbutton 'individual (lambda () (list (start-activity "individual" 0 ""))))
(mbutton 'individual (lambda () (list (start-activity "individual" 0 ""))))
(mbutton 'individual (lambda () (list (start-activity "individual" 0 ""))))
(mbutton 'individual (lambda () (list (start-activity "individual" 0 ""))))
) (build-list-widget
db "sync" 'individuals "individual" "individual" (lambda () (get-current 'household #f))
(list
(ktv "name" "varchar" (mtext-lookup 'default-individual-name))
(ktv "family" "varchar" (mtext-lookup 'default-family-name))
(ktv "photo-id" "varchar" (mtext-lookup 'default-photo-id)))))
(lambda (activity arg) (lambda (activity arg)
(set-current! 'activity-title "Household") (set-current! 'activity-title "Household")
(activity-layout activity)) (activity-layout activity))
(lambda (activity arg) '()) (lambda (activity arg)
(entity-init! db "sync" "household" (get-entity-by-unique db "sync" arg))
(set-current! 'household arg)
(list
(update-list-widget db "sync" "individual" "individual" arg)
(mupdate 'edit-text 'household-name "name")
(mupdate 'edit-text 'num-pots "num-pots")))
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
(lambda (activity) '()) (lambda (activity) '())
...@@ -803,6 +823,7 @@ ...@@ -803,6 +823,7 @@
(mtext 'name) (mtext 'name)
(mtext 'family) (mtext 'family)
(mtext 'photo-id))) (mtext 'photo-id)))
(mbutton 'agreement (lambda () (list (start-activity "agreement" 0 ""))))
(horiz (horiz
(mbutton-scale 'details (lambda () (list (start-activity "details" 0 "")))) (mbutton-scale 'details (lambda () (list (start-activity "details" 0 ""))))
(mbutton-scale 'family (lambda () (list (start-activity "family" 0 ""))))) (mbutton-scale 'family (lambda () (list (start-activity "family" 0 "")))))
...@@ -811,13 +832,18 @@ ...@@ -811,13 +832,18 @@
(mbutton-scale 'income (lambda () (list (start-activity "income" 0 ""))))) (mbutton-scale 'income (lambda () (list (start-activity "income" 0 "")))))
(horiz (horiz
(mbutton-scale 'geneaology (lambda () (list (start-activity "geneaology"