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

Merge branch 'master' of

parents 4476095c cf2a1dd5
......@@ -185,14 +185,18 @@
;; todo fix all hardcoded paths here
(define (send-files ktvlist)
(msg "send-files" ktvlist)
(lambda (ktv r)
(msg (ktv-type ktv))
(if (equal? (ktv-type ktv) "file")
(msg "sending" (ktv-value ktv))
(cons (http-upload
(string-append "upload-" (ktv-value ktv))
(string-append "/sdcard/symbai/files/" (ktv-value ktv)))
'() ktvlist))
......@@ -210,62 +214,69 @@
(string-append "req-" (list-ref (car e) 1))
(build-url-from-entity table e)
(lambda (v)
(msg "in spit..." v)
((or (equal? (car v) "inserted") (equal? (car v) "match"))
(update-entity-clean db table (cadr v))
(send-files e)
(debug! (string-append "Uploaded " (car (car e))))))
(debug! (string-append "Uploaded " (car (car e)))))
((equal? (car v) "no change")
(debug! (string-append "No change for " (car (car e)))))
((equal? (car v) "updated")
;; send new files hereish
(update-entity-clean db table (cadr v))
(send-files e)
(debug! (string-append "Updated changed " (car (car e))))))
(debug! (string-append "Updated changed " (car (car e)))))
(debug! (string-append
"Problem uploading "
(car (car e)) " : " (car v)))))
;; 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
(update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db))))))
(update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db)))))))
(msg "request files")
;; todo fix all hardcoded paths here
(define (request-files ktvlist)
(msg "request-files")
(lambda (ktv r)
(if (equal? (ktv-type ktv) "file")
(msg "requesting" (ktv-value ktv))
(cons (http-download
(string-append "download-" (ktv-value ktv))
(string-append "" (ktv-value ktv))
(string-append "/sdcard/symbai/files/" (ktv-value ktv)))
'() ktvlist))
(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
(string-append unique-id "-update-new")
(string-append url "fn=entity&table=" table "&unique-id=" unique-id)
(lambda (data)
;; check "sync-insert" in raspberry pi-side for the contents of 'entity'
(let ((entity (list-ref data 0))
(ktvlist (list-ref data 1)))
(let* ((entity (list-ref data 0))
(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)
db table
(list-ref entity 0) ;; entity-type
(list-ref entity 1) ;; unique-id
0 ;; dirty
(list-ref entity 2) ;; version
......@@ -273,12 +284,14 @@
db table (get-entity-id db table unique-id)
(list-ref entity 2) ktvlist))
(debug! (string-append (if exists "Got new: " "Updated: ") (ktv-get ktvlist "name")))
(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
(define (suck-new db table)
(msg "suck-new")
(debug! "Requesting new entities")
......@@ -298,7 +311,7 @@
;; if we don't have this entity or the version on the server is newer
(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)
......@@ -329,6 +342,7 @@
"Stream data: " (number->string (car stream)) "/" (number->string (cadr stream)))))
(define (upload-dirty db)
(msg "upload-dirty")
(let ((r (append
(spit db "sync" (dirty-entities db "sync"))
(spit db "stream" (dirty-entities db "stream")))))
......@@ -233,6 +233,30 @@
(vector-ref i 0))
(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)
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(define (validate db)
;; check attribute for duplicate entity-id/attribute-ids
......@@ -262,13 +286,17 @@
(else (cons (car ktv-list) (ktv-set (cdr ktv-list) ktv)))))
(define (db-all db table type)
(prof-start "db-all")
(let ((r (map
(lambda (i)
(get-entity db table i))
(all-entities db table type)))
(define (db-with-parent db table type parent)
(lambda (i)
(get-entity db table i))
(all-entities db table type))))
(prof-end "db-all")
(all-entities-with-parent db table type parent)))
;; updating data
......@@ -38,7 +38,7 @@
(ktv "user-id" "varchar" "No name yet...")))
(define entity-types '())
(define entity-types (list "village"))
;;(display (db-all db "local" "app-settings"))(newline)
......@@ -59,7 +59,9 @@
(list 'three (list "three"))
(list 'village (list "Village"))
(list 'household (list "Household"))
(list 'households (list "Households"))
(list 'individual (list "Individual"))
(list 'individuals (list "Individuals"))
(list 'add-item (list "+"))
(list 'default-village-name (list "New village"))
......@@ -112,6 +114,8 @@
(list 'market (list "Market"))
;; household
(list 'household-name (list "Household name"))
(list 'default-household-name (list "A household"))
(list 'location (list "House location"))
(list 'elevation (list "Elevation"))
(list 'toilet-location (list "Toilet location"))
......@@ -123,6 +127,9 @@
(list 'add-individual (list "Add 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 'family (list "Family"))
(list 'migration (list "Migration"))
......@@ -348,7 +355,7 @@
;; dispatches based on widget type
(define (mupdate widget-type id-symbol key)
((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
(entity-get-value key)))
((eq? widget-type 'toggle-button)
......@@ -395,13 +402,14 @@
(set-current! 'download 0)
(lambda ()
(msg "connected, going in...")
(list (toast "sync-cb"))
(upload-dirty db)
(suck-new db "sync")))))
(else '()))
(delayed "debug-timer" (+ 5000 (random 5000)) debug-timer-cb)
(delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
......@@ -539,17 +547,20 @@
;; a standard builder for list widgets of entities and a
;; 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)
(mtitle-scale 'villages)
(mtitle-scale title)
(make-id (string-append (symbol->string title) "-add"))
(mtext-lookup title)
40 (layout 'fill-parent 'wrap-content 1 'centre 5)
(lambda ()
(entity-init! db table entity-type ktv-default)
(entity-add-value! "parent" "varchar" (parent-fn))
(list (update-list-widget db table entity-type edit-activity)))))
(list (update-list-widget db table entity-type edit-activity (parent-fn))))))
(make-id (string-append entity-type "-list"))
......@@ -558,8 +569,11 @@
;; pull db data into list of button widgets
(define (update-list-widget db table entity-type edit-activity)
(let ((search-results (db-all db table entity-type)))
(define (update-list-widget db table entity-type edit-activity parent)
(let ((search-results
(if parent
(db-with-parent db table entity-type parent)
(db-all db table entity-type))))
(get-id (string-append entity-type "-list"))
......@@ -626,7 +640,7 @@
db "sync" "village" "village"
db "sync" 'villages "village" "village" (lambda () #f)
(ktv "name" "varchar" (mtext-lookup 'default-village-name))
(ktv "block" "varchar" "")
......@@ -638,7 +652,7 @@
(set-current! 'activity-title "Main screen")
(activity-layout activity))
(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) '())
......@@ -684,9 +698,11 @@
(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)
(place-widgets 'school #t)
(place-widgets 'hospital #f)
......@@ -702,17 +718,14 @@
(set-current! 'activity-title "Village")
(activity-layout activity))
(lambda (activity arg)
(msg "on start")
(msg "activity start - entity init")
(entity-init! db "sync" "village" (get-entity-by-unique db "sync" arg))
(msg "activity start - entity init done")
(set-current! 'village arg)
(mupdate 'edit-text 'village-name "name")
(mupdate 'edit-text 'block "block")
(mupdate 'edit-text 'district "district")
(mupdate 'toggle-button 'car "car")
(mupdate 'image-view 'photo "photo")
(toast arg)))
(mupdate 'image-view 'photo "photo")))
(lambda (activity) '())
(lambda (activity) '())
(lambda (activity) '())
......@@ -735,16 +748,22 @@
(mbutton 'household (lambda () (list (start-activity "household" 0 ""))))
(mbutton 'household (lambda () (list (start-activity "household" 0 ""))))
(mbutton 'household (lambda () (list (start-activity "household" 0 ""))))
(mbutton 'household (lambda () (list (start-activity "household" 0 ""))))
(mbutton 'household (lambda () (list (start-activity "household" 0 ""))))
db "sync" 'households "household" "household" (lambda () (get-current 'village #f))
(ktv "name" "varchar" (mtext-lookup 'default-household-name))
(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)
(set-current! 'activity-title "Household List")
(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) '())
......@@ -754,6 +773,9 @@
(medit-text 'household-name "normal" (lambda (v) '()))
(medit-text 'num-pots "numeric" (lambda (v) '())))
(mtext 'location)
......@@ -768,26 +790,24 @@
(mtext-small 'test-num)
(mtext-small 'test-num))
(medit-text 'elevation "numeric" (lambda (v) '())))
(medit-text 'num-pots "numeric" (lambda (v) '()))
(mtext 'children)
(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 ""))))
db "sync" 'individuals "individual" "individual" (lambda () (get-current 'household #f))
(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)
(set-current! 'activity-title "Household")
(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)
(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) '())
......@@ -803,6 +823,7 @@
(mtext 'name)
(mtext 'family)
(mtext 'photo-id)))
(mbutton 'agreement (lambda () (list (start-activity "agreement" 0 ""))))
(mbutton-scale 'details (lambda () (list (start-activity "details" 0 ""))))
(mbutton-scale 'family (lambda () (list (start-activity "family" 0 "")))))
......@@ -811,13 +832,18 @@
(mbutton-scale 'income (lambda () (list (start-activity "income" 0 "")))))
(mbutton-scale 'geneaology (lambda () (list (start-activity "geneaology" 0 ""))))
(mbutton-scale 'social (lambda () (list (start-activity "social" 0 "")))))
(mbutton 'agreement (lambda () (list (start-activity "agreement" 0 "")))))
(mbutton-scale 'social (lambda () (list (start-activity "social" 0 ""))))))
(lambda (activity arg)
(set-current! 'activity-title "Individual")
(activity-layout activity))
(lambda (activity arg) '())
(lambda (activity arg)
(entity-init! db "sync" "individual" (get-entity-by-unique db "sync" arg))
(set-current! 'individual arg)
(mupdate 'text-view 'name "name")
(mupdate 'text-view 'family "family")
(mupdate 'text-view 'photo-id "photo-id")))
(lambda (activity) '())
(lambda (activity) '())
(lambda (activity) '())
......@@ -1026,7 +1052,7 @@
(text-view (make-id "sync-title") "Sync database" 40 fillwrap)
(mtext 'sync-dirty "...")
(mtoggle-button-scale 'sync-all (lambda (v) (set-current! 'sync-on v)))
(mtoggle-button-scale 'sync-all (lambda (v) (set-current! 'sync-on v) '()))
(mbutton-scale 'sync-syncall
(lambda ()
(let ((r (append
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