Commit 598d9cc2 authored by Dave Griffiths's avatar Dave Griffiths
Browse files

image sync functional

parent 33e722e9
...@@ -185,14 +185,18 @@ ...@@ -185,14 +185,18 @@
;; todo fix all hardcoded paths here ;; todo fix all hardcoded paths here
(define (send-files ktvlist) (define (send-files ktvlist)
(msg "send-files" ktvlist)
(foldl (foldl
(lambda (ktv r) (lambda (ktv r)
(msg (ktv-type ktv))
(if (equal? (ktv-type ktv) "file") (if (equal? (ktv-type ktv) "file")
(cons (http-upload (begin
(string-append "upload-" (ktv-value ktv)) (msg "sending" (ktv-value ktv))
"http://192.168.2.1:8889/symbai?fn=upload" (cons (http-upload
(string-append "/sdcard/symbai/files/" (ktv-value ktv))) (string-append "upload-" (ktv-value ktv))
r) "http://192.168.2.1:8889/symbai?fn=upload"
(string-append "/sdcard/symbai/files/" (ktv-value ktv)))
r))
r)) r))
'() ktvlist)) '() ktvlist))
...@@ -210,62 +214,69 @@ ...@@ -210,62 +214,69 @@
(string-append "req-" (list-ref (car e) 1)) (string-append "req-" (list-ref (car e) 1))
(build-url-from-entity table e) (build-url-from-entity table e)
(lambda (v) (lambda (v)
(msg "in spit..." v)
(cond (cond
((or (equal? (car v) "inserted") (equal? (car v) "match")) ((or (equal? (car v) "inserted") (equal? (car v) "match"))
(update-entity-clean db table (cadr v)) (update-entity-clean db table (cadr v))
(append (debug! (string-append "Uploaded " (car (car e)))))
(send-files e)
(debug! (string-append "Uploaded " (car (car e))))))
((equal? (car v) "no change") ((equal? (car v) "no change")
(debug! (string-append "No change for " (car (car e))))) (debug! (string-append "No change for " (car (car e)))))
((equal? (car v) "updated") ((equal? (car v) "updated")
;; send new files hereish
(update-entity-clean db table (cadr v)) (update-entity-clean db table (cadr v))
(append (debug! (string-append "Updated changed " (car (car e)))))
(send-files e)
(debug! (string-append "Updated changed " (car (car e))))))
(else (else
(debug! (string-append (debug! (string-append
"Problem uploading " "Problem uploading "
(car (car e)) " : " (car v))))) (car (car e)) " : " (car v)))))
(list (append
(update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db)))))) ;; 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)) r))
'() '()
entities)) entities))
(msg "request files")
;; todo fix all hardcoded paths here ;; todo fix all hardcoded paths here
(define (request-files ktvlist) (define (request-files ktvlist)
(msg "request-files")
(foldl (foldl
(lambda (ktv r) (lambda (ktv r)
(if (equal? (ktv-type ktv) "file") (if (equal? (ktv-type ktv) "file")
(cons (http-download (begin
(string-append "download-" (ktv-value ktv)) (msg "requesting" (ktv-value ktv))
(string-append "http://192.168.2.1:8889/files/" (ktv-value ktv)) (cons (http-download
(string-append "/sdcard/symbai/files/" (ktv-value ktv))) (string-append "download-" (ktv-value ktv))
r) (string-append "http://192.168.2.1:8889/files/" (ktv-value ktv))
(string-append "/sdcard/symbai/files/" (ktv-value ktv)))
r))
r)) r))
'() ktvlist)) '() ktvlist))
(msg "suck ent") (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 ;; ask for the current version
(http-request (http-request
(string-append unique-id "-update-new") (string-append unique-id "-update-new")
(string-append url "fn=entity&table=" table "&unique-id=" unique-id) (string-append url "fn=entity&table=" table "&unique-id=" unique-id)
(lambda (data) (lambda (data)
;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity' ;; check "sync-insert" in sync.ss raspberry pi-side for the contents of 'entity'
(let ((entity (list-ref data 0)) (let* ((entity (list-ref data 0))
(ktvlist (list-ref data 1))) (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) (if (not exists)
(insert-entity-wholesale (insert-entity-wholesale
db table db table
(list-ref entity 0) ;; entity-type (list-ref entity 0) ;; entity-type
(list-ref entity 1) ;; unique-id unique-id
0 ;; dirty 0 ;; dirty
(list-ref entity 2) ;; version (list-ref entity 2) ;; version
ktvlist) ktvlist)
...@@ -273,12 +284,14 @@ ...@@ -273,12 +284,14 @@
db table (get-entity-id db table unique-id) db table (get-entity-id db table unique-id)
(list-ref entity 2) ktvlist)) (list-ref entity 2) ktvlist))
(debug! (string-append (if exists "Got new: " "Updated: ") (ktv-get ktvlist "name"))) (debug! (string-append (if exists "Got new: " "Updated: ") (ktv-get ktvlist "name")))
(list (cons
(request-files ktvlist) (update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db))
(update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db))))))) (request-files ktvlist))))))
;; repeatedly read version and request updates ;; repeatedly read version and request updates
(define (suck-new db table) (define (suck-new db table)
(msg "suck-new")
(debug! "Requesting new entities") (debug! "Requesting new entities")
(list (list
(http-request (http-request
...@@ -298,7 +311,7 @@ ...@@ -298,7 +311,7 @@
#f))) #f)))
;; if we don't have this entity or the version on the server is newer ;; if we don't have this entity or the version on the server is newer
(if (or (not exists) old) (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))) r)))
'() '()
data))) data)))
...@@ -329,6 +342,7 @@ ...@@ -329,6 +342,7 @@
"Stream data: " (number->string (car stream)) "/" (number->string (cadr stream))))) "Stream data: " (number->string (car stream)) "/" (number->string (cadr stream)))))
(define (upload-dirty db) (define (upload-dirty db)
(msg "upload-dirty")
(let ((r (append (let ((r (append
(spit db "sync" (dirty-entities db "sync")) (spit db "sync" (dirty-entities db "sync"))
(spit db "stream" (dirty-entities db "stream"))))) (spit db "stream" (dirty-entities db "stream")))))
......
...@@ -38,7 +38,7 @@ ...@@ -38,7 +38,7 @@
(list (list
(ktv "user-id" "varchar" "No name yet..."))) (ktv "user-id" "varchar" "No name yet...")))
(define entity-types '()) (define entity-types (list "village"))
;;(display (db-all db "local" "app-settings"))(newline) ;;(display (db-all db "local" "app-settings"))(newline)
...@@ -395,13 +395,14 @@ ...@@ -395,13 +395,14 @@
(set-current! 'download 0) (set-current! 'download 0)
(connect-to-net (connect-to-net
(lambda () (lambda ()
(msg "connected, going in...")
(append (append
(list (toast "sync-cb")) (list (toast "sync-cb"))
(upload-dirty db) (upload-dirty db)
(suck-new db "sync"))))) (suck-new db "sync")))))
(else '())) (else '()))
(list (list
(delayed "debug-timer" (+ 5000 (random 5000)) debug-timer-cb) (delayed "debug-timer" (+ 10000 (random 5000)) debug-timer-cb)
(update-debug)))) (update-debug))))
...@@ -1026,7 +1027,7 @@ ...@@ -1026,7 +1027,7 @@
(text-view (make-id "sync-title") "Sync database" 40 fillwrap) (text-view (make-id "sync-title") "Sync database" 40 fillwrap)
(mtext 'sync-dirty "...") (mtext 'sync-dirty "...")
(horiz (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 (mbutton-scale 'sync-syncall
(lambda () (lambda ()
(let ((r (append (let ((r (append
......
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