running and partly pruned

android/assets/dbsync.scm

+;; Starwisp Copyright (C) 2013 Dave Griffiths
+;;
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+;;
+;; 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/>.
+
+
+;; abstractions for synced databased
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; stuff in memory
+
+(define (store-set store key value)
+  (cond
+   ((null? store) (list (list key value)))
+   ((eq? key (car (car store)))
+    (cons (list key value) (cdr store)))
+   (else
+    (cons (car store) (store-set (cdr store) key value)))))
+
+(define (store-get store key default)
+  (cond
+   ((null? store) default)
+   ((eq? key (car (car store)))
+    (cadr (car store)))
+   (else
+    (store-get (cdr store) key default))))
+
+(define (store-exists? store key)
+  (cond
+   ((null? store) #f)
+   ((eq? key (car (car store)))
+    #t)
+   (else
+    (store-exists? (cdr store) key))))
+
+(define store '())
+
+(define (set-current! key value)
+  (set! store (store-set store key value)))
+
+(define (get-current key default)
+  (store-get store key default))
+
+(define (current-exists? key)
+  (store-exists? store key))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; db abstraction
+
+;; store a ktv, replaces existing with same key
+(define (entity-add-value! key type value)
+  (set-current!
+   'entity-values
+   (ktv-set
+    (get-current 'entity-values '())
+    (ktv key type value))))
+
+(define (entity-set! ktv-list)
+  (set-current! 'entity-values ktv-list))
+
+(define (date-time->string dt)
+  (string-append
+   (number->string (list-ref dt 0)) "-"
+   (number->string (list-ref dt 1)) "-"
+   (number->string (list-ref dt 2)) " "
+   (number->string (list-ref dt 3)) ":"
+   (number->string (list-ref dt 4)) ":"
+   (substring (number->string (+ 100 (list-ref dt 5))) 1 2)))
+
+;; build entity from all ktvs, insert to db, return unique_id
+(define (entity-record-values db table type)
+  ;; standard bits
+  (entity-add-value! "user" "varchar" (get-current 'user-id "none"))
+  (entity-add-value! "time" "varchar" (date-time->string (date-time)))
+  (entity-add-value! "lat" "real" (car (get-current 'location '(0 0))))
+  (entity-add-value! "lon" "real" (cadr (get-current 'location '(0 0))))
+  (let ((values (get-current 'entity-values '())))
+    (cond
+     ((not (null? values))
+      (let ((r (insert-entity/get-unique
+                db table type (get-current 'user-id "no id")
+                values)))
+        (msg "inserted a " type)
+        (entity-reset!) r))
+     (else
+      (msg "no values to add as entity!") #f))))
+
+(define (entity-update-values db table)
+  ;; standard bits
+  (let ((values (get-current 'entity-values '()))
+        (unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
+    (cond
+     ((and unique-id (not (null? values)))
+      (update-entity db table (entity-id-from-unique db table unique-id) values)
+      (msg "updated " unique-id)
+      (entity-reset!))
+     (else
+      (msg "no values or no id to update as entity:" unique-id "values:" values)))))
+
+(define (entity-reset!)
+  (set-current! 'entity-values '()))
+
+(define (assemble-array entities)
+  (foldl
+   (lambda (i r)
+     (if (equal? r "") (ktv-get i "unique_id")
+         (string-append r "," (ktv-get i "unique_id"))))
+   ""
+   entities))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; syncing code
+
+(define url "http://192.168.2.1:8888/mongoose?")
+
+(define (build-url-from-ktv ktv)
+  (string-append "&" (ktv-key ktv) ":" (ktv-type ktv) "=" (stringify-value-url ktv)))
+
+(define (build-url-from-ktvlist ktvlist)
+  (foldl
+   (lambda (ktv r)
+     (string-append r (build-url-from-ktv ktv)))
+   "" ktvlist))
+
+(define (build-url-from-entity table e)
+  (string-append
+   url
+   "fn=sync"
+   "&table=" table
+   "&entity-type=" (list-ref (car e) 0)
+   "&unique-id=" (list-ref (car e) 1)
+   "&dirty=" (number->string (list-ref (car e) 2))
+   "&version=" (number->string (list-ref (car e) 3))
+   (build-url-from-ktvlist (cadr e))))
+
+;; spit all dirty entities to server
+(define (spit db table entities)
+  (foldl
+   (lambda (e r)
+     (debug! (string-append "Sending a " (car (car e)) " to Raspberry Pi"))
+     (append
+      (list
+       (http-request
+        (string-append "req-" (list-ref (car e) 1))
+        (build-url-from-entity table e)
+        (lambda (v)
+          (cond
+           ((or (equal? (car v) "inserted") (equal? (car v) "match"))
+            (update-entity-clean db table (cadr v))
+            (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")
+            (update-entity-clean db table (cadr v))
+            (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))))))
+      r))
+   '()
+   entities))
+
+(define (suck-entity-from-server db table unique-id exists)
+  ;; 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)))
+       (if (not exists)
+           (insert-entity-wholesale
+            db table
+            (list-ref entity 0) ;; entity-type
+            (list-ref entity 1) ;; unique-id
+            0 ;; dirty
+            (list-ref entity 2) ;; version
+            ktvlist)
+           (update-to-version
+            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
+        (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty)))))))
+
+;; repeatedly read version and request updates
+(define (suck-new db table)
+  (debug! "Requesting new entities")
+  (list
+   (http-request
+    "new-entities-req"
+    (string-append url "fn=entity-versions&table=" table)
+    (lambda (data)
+      (let ((r (foldl
+                (lambda (i r)
+                  (let* ((unique-id (car i))
+                         (version (cadr i))
+                         (exists (entity-exists? db table unique-id))
+                         (old
+                          (if exists
+                              (> version (get-entity-version
+                                          db table
+                                          (get-entity-id db table unique-id)))
+                              #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)
+                        r)))
+                '()
+                data)))
+        (cond
+         ((null? r)
+          (debug! "No new data to download")
+          (set-current! 'download 1)
+          (append
+           (if (eqv? (get-current 'upload 0) 1)
+               (list (play-sound "ping")) '())
+           (list
+            (toast "No new data to download")) r))
+         (else
+          (debug! (string-append
+                   "Requesting "
+                   (number->string (length r)) " entities"))
+          (cons
+           (play-sound "active")
+           r))))))))
+
+(define (build-dirty)
+  (let ((sync (get-dirty-stats db "sync"))
+        (stream (get-dirty-stats db "stream")))
+    (string-append
+     "Pack data: " (number->string (car sync)) "/" (number->string (cadr sync)) " "
+     "Focal data: " (number->string (car stream)) "/" (number->string (cadr stream)))))
+
+(define (upload-dirty db)
+  (let ((r (append
+            (spit db "sync" (dirty-entities db "sync"))
+            (spit db "stream" (dirty-entities db "stream")))))
+    (append (cond
+             ((> (length r) 0)
+              (debug! (string-append "Uploading " (number->string (length r)) " items..."))
+              (list
+               (toast "Uploading data...")
+               (play-sound "active")))
+             (else
+              (debug! "No data changed to upload")
+              (set-current! 'upload 1)
+              (append
+               (if (eqv? (get-current 'download 0) 1)
+                   (list (play-sound "ping")) '())
+               (list
+                (toast "No data changed to upload"))))) r)))
+
+(define (connect-to-net fn)
+  (list
+   (network-connect
+    "network"
+    "mongoose-web"
+    (lambda (state)
+      (debug! (string-append "Raspberry Pi connection state now: " state))
+      (append
+       (if (equal? state "Connected") (fn) '())
+       (list
+        ;;(update-widget 'text-view (get-id "sync-connect") 'text state)
+        ))))))

android/assets/eavdb.scm

@@ -111,7 +111,7 @@
              entity-id (ktv-key ktv) (ktv-value ktv)))
 
 (define (get-unique user)
-  (let ((t (time)))
+  (let ((t (time-of-day)))
     (string-append
      user "-" (number->string (car t)) ":" (number->string (cadr t)))))
 

android/assets/lib.scm

@@ -16,6 +16,8 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; debugging and unit tests
 
+(alog "hello from lib.scm")
+
 (define (msg . args)
   (for-each
    (lambda (i) (display i)(display " "))
@@ -170,10 +172,10 @@
 (define (time->seconds t)
    (+ (car t) (/ (cadr t) 1000000)))
 
-(define start-time (time->seconds (time)))
+(define start-time (time->seconds (time-of-day)))
 
 (define (time-now)
-  (- (time->seconds (time)) start-time))
+  (- (time->seconds (time-of-day)) start-time))
 
 ;; just for graph so don't have to be accurate!!!
 (define (date->day d)
@@ -858,3 +860,6 @@
           (update-dialogs! events)
           (send (scheme->json events))
           (prof-end "widget-callback")))))
+
+
+(alog "lib.scm done")

android/assets/starwisp.scm

@@ -16,62 +16,16 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; strings
 
-(define obs-gc "Group Composition")
-(define obs-pf "Pup Focal")
-(define obs-gp "Group Events")
-
-(define entity-types
-  (list
-   "pup-focal"
-   "pup-focal-nearest"
-   "pup-focal-pupfeed"
-   "pup-focal-pupfind"
-   "pup-focal-pupcare"
-   "pup-focal-pupaggr"
-   "group-interaction"
-   "group-alarm"
-   "group-move"))
 
 ;; colours
 
-(define pf-col (list 255 204 51 255))
-(define gp-col (list 255 102 0 255))
-(define gc-col (list 164 82 9 255))
-
-(define pf-bgcol (list 255 204 51 127))
-(define gp-bgcol (list 255 102 0 127))
-(define gc-bgcol (list 164 82 9 127))
-
-;(define pf-col (list  22  19 178  127))
-;(define gp-col (list 255  97   0  127))
-;(define gc-col (list 255 236   0  127))
-
-
 
 (define trans-col (list 0 0 0 0))
 
-(define (get-fragment-index name frag)
-  (define (_ i l)
-    (cond
-     ((null? l) 0)
-     ((equal? name (cadr (car l))) i)
-     (else (_ (+ i 1) (cdr l)))))
-  (_ 0 frag))
-
-(define gc-fragments
-  (list
-   (list "Start" "gc-start")
-   (list "Weights" "gc-weights")
-   (list "Pregnant" "gc-preg")
-   (list "Pup assoc" "gc-pup-assoc")
-   (list "Oestrus" "gc-oestrus")
-   (list "Babysit" "gc-babysitting")
-   (list "End" "gc-end")))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; persistent database
 
-(define db "/sdcard/symbai/local-symbai.db")
+(define db "/sdcard/starwisp/local-symbai.db")
 (db-open db)
 (setup db "local")
 (setup db "sync")
@@ -82,7 +36,7 @@
  (list
   (ktv "user-id" "varchar" "No name yet...")))
 
-(display (db-all db "local" "app-settings"))(newline)
+;;(display (db-all db "local" "app-settings"))(newline)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; stuff in memory
@@ -526,8 +480,6 @@
    (ktv "pack-id" "varchar" (ktv-get (get-current 'pack '()) "unique_id"))
    (ktv "dob" "varchar" (date->string (date-minus-months (date-time) 6)))))
 
-
-
 (define (tri-state id text key)
   (linear-layout
    (make-id "") 'vertical (layout 'fill-parent 'wrap-content '1 'centre 0) trans-col
@@ -708,7 +660,7 @@
 
 
     (mtext "" "Database")
-    (mbutton "main-sync" "Sync database" (lambda () (list (start-activity "sync" 0 "")))))
+;;    (mbutton "main-sync" "Sync database" (lambda () (list (start-activity "sync" 0 ""))))
 
     )
    (lambda (activity arg)
@@ -725,92 +677,5 @@
 
 
 
-  (activity
-   "sync"
-   (vert
-    (text-view (make-id "sync-title") "Sync database" 40 fillwrap)
-    (mtext "sync-dirty" "...")
-    (horiz
-     (mtoggle-button2 "sync-all" "Sync me" (lambda (v) (set-current! 'sync-on v)))
-     (mbutton2 "sync-syncall" "Push all"
-               (lambda ()
-                 (let ((r (append
-                           (spit db "sync" (dirty-and-all-entities db "sync"))
-                           (spit db "stream" (dirty-and-all-entities db "stream")))))
-                   (cons (toast "Uploading data...") r)))))
-    (mtitle "" "Export data")
-    (horiz
-     (mbutton2 "sync-download" "Download"
-               (lambda ()
-                 (debug! (string-append "Downloading whole db"))
-                 (append
-                 (foldl
-                  (lambda (e r)
-                    (debug! (string-append "Downloading /sdcard/mongoose/" e ".csv"))
-                    (cons
-                     (http-download
-                      (string-append "getting-" e)
-                      (string-append url "fn=entity-csv&table=stream&type=" e)
-                      (string-append "/sdcard/mongoose/" e ".csv"))
-                     r))
-                  (list
-                   (http-download
-                    "getting-db"
-                    "http://192.168.2.1:8888/mongoose.db"
-                    (string-append "/sdcard/mongoose/mongoose.db"))
-                   )
-                  entity-types)
-                 (list))))
-     (mbutton2 "sync-export" "Email"
-               (lambda ()
-                 (debug! "Sending mail")
-                 (list
-                  (send-mail
-                   ""
-                   "From Mongoose2000" "Please find attached your mongoose data"
-                   (cons
-                    "/sdcard/mongoose/mongoose.db"
-                    (map
-                     (lambda (e)
-                       (string-append "/sdcard/mongoose/" e ".csv"))
-                     entity-types))))))
-     (mbutton2 "sync-export" "Email local data"
-               (lambda ()
-                 (debug! "Sending mail")
-                 (list
-                  (send-mail
-                   ""
-                   "From Mongoose2000" "Please find attached your local mongoose data"
-                   (list "/sdcard/mongoose/local-mongoose.db")))))
-     )
-    (spacer 10)
-    (mtitle "" "Debug")
-    (scroll-view-vert
-     0 (layout 'fill-parent 200 1 'left 0)
-     (list
-      (vert
-       (debug-text-view (make-id "sync-debug") "..." 15 (layout 'fill-parent 400 1 'left 0)))))
-    (spacer 10)
-    (horiz
-     (mbutton2 "sync-back" "Back" (lambda () (list (finish-activity 1))))
-     (mbutton2 "sync-send" "[Prof]" (lambda () (prof-print) (list))))
-    )
-
-   (lambda (activity arg)
-     (activity-layout activity))
-   (lambda (activity arg)
-     (set-current! 'sync-on #f)
-     (append
-      (debug-timer-cb)
-      (list
-       (update-widget 'debug-text-view (get-id "sync-debug") 'text (get-current 'debug-text ""))
-       (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty))
-       )))
-   (lambda (activity) '())
-   (lambda (activity) (list (delayed "debug-timer" 1000 (lambda () '()))))
-   (lambda (activity) (list (delayed "debug-timer" 1000 (lambda () '()))))
-   (lambda (activity) '())
-   (lambda (activity requestcode resultcode) '()))
-
 
   )

android/res/values/strings.xml

 <?xml version="1.0" encoding="utf-8"?>
 <resources>
-    <string name="app_name">Open Sauces Notebook</string>
+    <string name="app_name">Symbai</string>
 </resources>