Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Open sidebar
citizen-science
symbai
Commits
598d9cc2
Commit
598d9cc2
authored
Mar 27, 2014
by
Dave Griffiths
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
image sync functional
parent
33e722e9
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
47 additions
and
32 deletions
+47
-32
android/assets/dbsync.scm
android/assets/dbsync.scm
+43
-29
android/assets/starwisp.scm
android/assets/starwisp.scm
+4
-3
No files found.
android/assets/dbsync.scm
View file @
598d9cc2
...
...
@@ -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/starwisp.scm
View file @
598d9cc2
...
...
@@ -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)
...
...
@@ -395,13 +395,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
))))
...
...
@@ -1026,7 +1027,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