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

android/assets/dbsync.scm

@@ -185,14 +185,18 @@
 
 ;; todo fix all hardcoded paths here
 (define (send-files ktvlist)
+  (msg "send-files" ktvlist)
   (foldl
    (lambda (ktv r)
+     (msg (ktv-type ktv))
      (if (equal? (ktv-type ktv) "file")
-         (cons (http-upload
-                (string-append "upload-" (ktv-value ktv))
-                "http://192.168.2.1:8889/symbai?fn=upload"
-                (string-append "/sdcard/symbai/files/" (ktv-value ktv)))
-               r)
+         (begin
+           (msg "sending" (ktv-value ktv))
+           (cons (http-upload
+                  (string-append "upload-" (ktv-value ktv))
+                  "http://192.168.2.1:8889/symbai?fn=upload"
+                  (string-append "/sdcard/symbai/files/" (ktv-value ktv)))
+                 r))
          r))
    '() 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)
           (cond
            ((or (equal? (car v) "inserted") (equal? (car v) "match"))
             (update-entity-clean db table (cadr v))
-            (append
-             (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))
-            (append
-             (send-files e)
-             (debug! (string-append "Updated changed " (car (car e))))))
+            (debug! (string-append "Updated changed " (car (car e)))))
            (else
             (debug! (string-append
                      "Problem uploading "
                      (car (car e)) " : " (car v)))))
-          (list
-           (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db))))))
+          (append
+           ;; 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))
    '()
    entities))
 
-(msg "request files")
-
 ;; todo fix all hardcoded paths here
 (define (request-files ktvlist)
+  (msg "request-files")
   (foldl
    (lambda (ktv r)
      (if (equal? (ktv-type ktv) "file")
-         (cons (http-download
-                (string-append "download-" (ktv-value ktv))
-                (string-append "http://192.168.2.1:8889/files/" (ktv-value ktv))
-                (string-append "/sdcard/symbai/files/" (ktv-value ktv)))
-               r)
+         (begin
+           (msg "requesting" (ktv-value ktv))
+           (cons (http-download
+                  (string-append "download-" (ktv-value ktv))
+                  (string-append "http://192.168.2.1:8889/files/" (ktv-value ktv))
+                  (string-append "/sdcard/symbai/files/" (ktv-value ktv)))
+                 r))
          r))
    '() 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
   (http-request
    (string-append unique-id "-update-new")
    (string-append url "fn=entity&table=" table "&unique-id=" unique-id)
    (lambda (data)
      ;; check "sync-insert" in sync.ss 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)
            (insert-entity-wholesale
             db table
             (list-ref entity 0) ;; entity-type
-            (list-ref entity 1) ;; unique-id
+            unique-id
             0 ;; dirty
             (list-ref entity 2) ;; version
             ktvlist)
@@ -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")))
-       (list
-        (request-files ktvlist)
-        (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db)))))))
+       (cons
+        (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")
   (list
    (http-request
@@ -298,7 +311,7 @@
                               #f)))
                     ;; 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)
                         r)))
                 '()
                 data)))
@@ -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")))))

android/assets/eavdb.scm

@@ -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)
+        '()
+        (map
+         (lambda (i)
+           (vector-ref i 0))
+         (cdr s)))))
+
+
+
 (define (validate db)
   ;; check attribute for duplicate entity-id/attribute-ids
   0)
@@ -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
+  (map
+   (lambda (i)
+     (get-entity db table i))
+   (all-entities db table type)))
+
+(define (db-with-parent db table type parent)
+  (map
    (lambda (i)
      (get-entity db table i))
-   (all-entities db table type))))
-    (prof-end "db-all")
-    r))
+   (all-entities-with-parent db table type parent)))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; updating data

android/assets/starwisp.scm

@@ -38,7 +38,7 @@
  (list
   (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)
   (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
                    (entity-get-value key)))
    ((eq? widget-type 'toggle-button)
@@ -395,13 +402,14 @@
      (set-current! 'download 0)
      (connect-to-net
       (lambda ()
+        (msg "connected, going in...")
         (append
          (list (toast "sync-cb"))
          (upload-dirty db)
          (suck-new db "sync")))))
     (else '()))
    (list
-    (delayed "debug-timer" (+ 5000 (random 5000)) debug-timer-cb)
+    (delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
     (update-debug))))
 
 
@@ -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)
     (vert-colour
      colour-two
      (horiz
-      (mtitle-scale 'villages)
-      (mbutton-scale
-       'add-item
+      (mtitle-scale title)
+      (button
+       (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))
          (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
       (make-id (string-append entity-type "-list"))
       'vertical
@@ -558,8 +569,11 @@
       (list))))
 
 ;; 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))))
     (update-widget
      'linear-layout
      (get-id (string-append entity-type "-list"))
@@ -626,7 +640,7 @@
                                     '()))
                               ))))
     (build-list-widget
-     db "sync" "village" "village"
+     db "sync" 'villages "village" "village" (lambda () #f)
      (list
       (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)
      (list
       (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 @@
   (activity
    "household-list"
    (build-activity
-    (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 ""))))
-    )
+    (build-list-widget
+     db "sync" 'households "household" "household" (lambda () (get-current 'village #f))
+     (list
+      (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 @@
   (activity
    "household"
    (build-activity
+    (horiz
+     (medit-text 'household-name "normal" (lambda (v) '()))
+     (medit-text 'num-pots "numeric" (lambda (v) '())))
     (horiz
      (mtext 'location)
      (vert
@@ -768,26 +790,24 @@
       (mtext-small 'test-num)
       (mtext-small 'test-num))
      (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)
      (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)
+     (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) '())
@@ -803,6 +823,7 @@
       (mtext 'name)
       (mtext 'family)
       (mtext 'photo-id)))
+    (mbutton 'agreement (lambda () (list (start-activity "agreement" 0 ""))))
     (horiz
      (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 "")))))
     (horiz
      (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)
+     (list
+      (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 "...")
     (horiz
-     (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