Commit 802cccb8 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

running and partly pruned

parent 73b54d22
;; 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)
))))))
......@@ -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)))))
......
......@@ -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")
......@@ -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) '()))
)
<?xml version="1.0" encoding="utf-8"?>
<resources>
<string name="app_name">Open Sauces Notebook</string>
<string name="app_name">Symbai</string>
</resources>
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