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
0e50d863
Commit
0e50d863
authored
Mar 27, 2014
by
dave griffiths
Browse files
Merge branch 'master' of github.com:nebogeo/symbai
parents
4476095c
cf2a1dd5
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
148 additions
and
80 deletions
+148
-80
android/assets/dbsync.scm
android/assets/dbsync.scm
+43
-29
android/assets/eavdb.scm
android/assets/eavdb.scm
+33
-5
android/assets/starwisp.scm
android/assets/starwisp.scm
+72
-46
No files found.
android/assets/dbsync.scm
View file @
0e50d863
...
...
@@ -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
View file @
0e50d863
...
...
@@ -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
View file @
0e50d863
...
...
@@ -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"
(
+
5
000
(
random
5000
))
debug-timer-cb
)
(
delayed
"debug-timer"
(
+
10
000
(
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
...
...
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