Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
nebogeo
symbai
Commits
802cccb8
Commit
802cccb8
authored
Mar 04, 2014
by
Dave Griffiths
Browse files
running and partly pruned
parent
73b54d22
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
292 additions
and
142 deletions
+292
-142
android/assets/dbsync.scm
android/assets/dbsync.scm
+280
-0
android/assets/eavdb.scm
android/assets/eavdb.scm
+1
-1
android/assets/lib.scm
android/assets/lib.scm
+7
-2
android/assets/starwisp.scm
android/assets/starwisp.scm
+3
-138
android/res/values/strings.xml
android/res/values/strings.xml
+1
-1
No files found.
android/assets/dbsync.scm
0 → 100644
View file @
802cccb8
;; 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
View file @
802cccb8
...
...
@@ -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
View file @
802cccb8
...
...
@@ -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
View file @
802cccb8
...
...
@@ -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/s
ymbai
/local-symbai.db"
)
(
define
db
"/sdcard/s
tarwisp
/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
View file @
802cccb8
<?xml version="1.0" encoding="utf-8"?>
<resources>
<string
name=
"app_name"
>
Open Sauces Notebook
</string>
<string
name=
"app_name"
>
Symbai
</string>
</resources>
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment