Commit aff06023 authored by Dave Griffiths's avatar Dave Griffiths

added admin app

parent a3ebe991
Open Sauces Notebook
A structured notebook for recipes
Symbai android app
<?xml version="1.0" encoding="utf-8"?>
<manifest xmlns:android=""
<application android:label="@string/app_name"
<activity android:name="foam.symbaidb.starwisp"
<action android:name="android.intent.action.MAIN" />
<category android:name="android.intent.category.LAUNCHER" />
<activity android:name="MainActivity" android:configChanges="orientation"></activity>
<activity android:name="ReviewItemActivity" android:configChanges="orientation"></activity>
<uses-permission android:name="android.permission.WRITE_EXTERNAL_STORAGE" />
<uses-sdk android:minSdkVersion="8" />
<uses-feature android:name="" android:required="true" />
android:anyDensity="true" />
Admin SQLite eavdb editor
# Set the keystore properties for signing the application.
\ No newline at end of file
;; 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
;; 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 <>.
;; abstractions for synced databased
(msg "dbsync.scm")
(define unset-int 2147483647)
;; stuff in memory
(define (store-set store key value)
((null? store) (list (list key value)))
((eq? key (car (car store)))
(cons (list key value) (cdr store)))
(cons (car store) (store-set (cdr store) key value)))))
(define (store-get store key default)
((null? store) default)
((eq? key (car (car store)))
(cadr (car store)))
(store-get (cdr store) key default))))
(define (store-exists? store key)
((null? store) #f)
((eq? key (car (car store)))
(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
(define (entity-init! db table entity-type ktv-list)
(entity-set! ktv-list)
(set-current! 'db db)
(set-current! 'table table)
(set-current! 'entity-type entity-type))
;; 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-add-value-create! key type value)
(msg "entity-add-value-create!" key type value)
(get-current 'entity-values '())
(ktv key type value))))
(define (entity-set! ktv-list)
(set-current! 'entity-values ktv-list))
(define (entity-get-value key)
(ktv-get (get-current 'entity-values '()) key))
(define (check-type type value)
((equal? type "varchar")
(string? value))
((equal? type "file")
(string? value))
((equal? type "int")
(number? value))
((equal? type "real")
(number? value))))
;; version to check the entity has the key
(define (entity-set-value! key type value)
(when (not (check-type type value))
(msg "INCORRECT TYPE FOR" key ":" type ":" value))
(let ((existing-type (ktv-get-type (get-current 'entity-values '()) key)))
((equal? existing-type type)
;; save straight to local db every time (checks for modification)
(entity-update-single-value! (list key type value))
;; then save to memory
(get-current 'entity-values '())
(ktv key type value))))
(msg "entity-set-value! - adding new " key "of type" type "to entity")
(entity-add-value-create! key type value))
;; version to check the entity has the key
(define (entity-set-value-mem! key type value)
(when (not (check-type type value))
(msg "INCORRECT TYPE FOR" key ":" type ":" value))
;; then save to memory
(get-current 'entity-values '())
(ktv key type value))))
(define (date-time->string dt)
(number->string (list-ref dt 0)) "-"
(substring (number->string (+ (list-ref dt 1) 100)) 1 3) "-"
(substring (number->string (+ (list-ref dt 2) 100)) 1 3) " "
(substring (number->string (+ (list-ref dt 3) 100)) 1 3) ":"
(substring (number->string (+ (list-ref dt 4) 100)) 1 3) ":"
(substring (number->string (+ (list-ref dt 5) 100)) 1 3)))
;; build entity from all ktvs, insert to db, return unique_id
(define (entity-record-values!)
(let ((db (get-current 'db #f))
(table (get-current 'table #f))
(type (get-current 'entity-type #f)))
;; standard bits
(let ((r (entity-create! db table type (get-current 'entity-values '()))))
(entity-reset!) r)))
(define (entity-create! db table entity-type ktv-list)
;;(msg "creating:" entity-type ktv-list)
(let ((values
(ktv "user" "varchar" (get-current 'user-id "none"))
(ktv "time" "varchar" (date-time->string (date-time)))
(ktv "lat" "real" (car (get-current 'location '(0 0))))
(ktv "lon" "real" (cadr (get-current 'location '(0 0))))
(ktv "deleted" "int" 0))
(let ((r (insert-entity/get-unique
db table entity-type (get-current 'user-id "no id")
(msg "entity-create: " entity-type)
(define (entity-update-values!)
(let ((db (get-current 'db #f))
(table (get-current 'table #f)))
;; standard bits
(let ((values (get-current 'entity-values '()))
(unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
((and unique-id (not (null? values)))
(update-entity db table (entity-id-from-unique db table unique-id) values)
;; removed due to save button no longer exiting activity - need to keep!
(msg "no values or no id to update as entity:" unique-id "values:" values))))))
(define (entity-update-single-value! ktv)
(let ((db (get-current 'db #f))
(table (get-current 'table #f))
(unique-id (ktv-get (get-current 'entity-values '()) "unique_id")))
((ktv-eq? (ktv-get-whole (get-current 'entity-values '()) (ktv-key ktv)) ktv)
(msg "eusv: no change for" (ktv-key ktv)))
(update-entity db table (entity-id-from-unique db table unique-id) (list ktv)))
(msg "no values or no id to update as entity:" unique-id "values:" values)))))
(define (entity-reset!)
(set-current! 'entity-values '())
(set-current! 'db "reset")
(set-current! 'table "reset")
(set-current! 'entity-type "reset"))
(define (assemble-array entities)
(lambda (i r)
(if (equal? r "") (ktv-get i "unique_id")
(string-append r "," (ktv-get i "unique_id"))))
;; syncing code
;; todo - separate logic from gui and stick this in common code
;; then we can unit test this stuff...
(define url "")
(define (build-url-from-ktv ktv)
(string-append "&" (ktv-key ktv) ":" (ktv-type ktv) "=" (stringify-value-url ktv)))
(define (build-url-from-ktvlist ktvlist)
(lambda (ktv r)
(string-append r (build-url-from-ktv ktv)))
"" ktvlist))
(define (build-url-from-entity table e)
"&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))))
;; todo fix all hardcoded paths here
(define (send-files ktvlist)
(lambda (ktv r)
(if (equal? (ktv-type ktv) "file")
(cons (http-upload
(string-append "upload-" (ktv-value ktv))
(string-append "/sdcard/symbai/files/" (ktv-value ktv)))
'() ktvlist))
;; redundant second pass to syncronise files - independant of the
;; rest of the syncing system
(define (sync-files server-list)
(let ((local-list (dir-list "/sdcard/symbai/files/")))
;; search for all local files in server list
(lambda (file r)
;; send files not present
(if (or
(eqv? (string-ref file 0) #\.)
(in-list? file server-list))
r (cons
(string-append "upload-" file)
(string-append "/sdcard/symbai/files/" file)) r)))
;; search for all server files in local list
(lambda (file r)
;; request files not present
(if (in-list? file local-list)
r (cons
(string-append "download-" file)
(string-append "" file)
(string-append "/sdcard/symbai/files/" file)) r)))
;; restrict the number of uploads each time round
(define (start-sync-files)
(string-append "file-list")
(string-append url "fn=file-list")
(lambda (file-list)
(let ((r (sync-files file-list)))
(when (not (null? r))
(set-current! 'upload 0)
(debug! "Found a mismatch with files on raspberry pi - fixing..."))
;; spit all dirty entities to server
(define (spit db table entities)
(lambda (e r)
;;(msg (car (car e)))
(debug! (string-append "Sending a " (car (car e)) " to Raspberry Pi"))
(string-append "req-" (list-ref (car e) 1))
(build-url-from-entity table e)
(lambda (v)
(msg "in spit..." v)
((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)))))
(debug! (string-append
"Problem uploading "
(car (car e)) " : " (car v)))))
;; 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
(update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db)))))))
;; todo fix all hardcoded paths here
(define (request-files ktvlist)
(lambda (ktv r)
(if (equal? (ktv-type ktv) "file")
(cons (http-download
(string-append "download-" (ktv-value ktv))
(string-append "" (ktv-value ktv))
(string-append "/sdcard/symbai/files/" (ktv-value ktv)))
'() ktvlist))
(msg "suck ent")
(define (suck-entity-from-server db table unique-id)
;; ask for the current version
(string-append unique-id "-update-new")
(string-append url "fn=entity&table=" table "&unique-id=" unique-id)
(lambda (data)
;; check "sync-insert" in raspberry pi-side for the contents of 'entity'
(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)
db table
(list-ref entity 0) ;; entity-type
0 ;; dirty
(list-ref entity 2) ;; 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")))
(update-widget 'text-view (get-id "sync-dirty") 'text (build-dirty db))
(request-files ktvlist))))))
(define (build-entity-requests db table version-data)
(lambda (i r)
(let* ((unique-id (car i))
(version (cadr i))
(exists (entity-exists? db table unique-id))
(if exists
(> version (get-entity-version
db table
(get-entity-id db table unique-id)))
;; if we don't have this entity or the version on the server is newer
(if (and (or (not exists) old)
;; limit this to 5 a time
(< (length r) 5))
(cons (suck-entity-from-server db table unique-id) r)
(define (mark-unlisted-entities-dirty! db table version-data)
(msg "mark-unlisted...")
;; load all local entities
(let ((ids (all-unique-ids db table))
(server-ids (map car version-data)))
;; look for each one in data
(lambda (id)
(when (not (in-list? id server-ids))
(msg "can't find " id " in server data, marking dirty")
(debug! "Have an entity here not on raspberry pi - marking for upload...")
;; mark those not present as dirty for next spit cycle
(update-entity-dirtify db table id)))
;; repeatedly read version and request updates
(define (suck-new db table)
(debug! "Requesting new entities")
(string-append url "fn=entity-versions&table=" table)
(lambda (data)
(let ((new-entity-requests (build-entity-requests db table data)))
(alog "suck-new: marking dirty")
(mark-unlisted-entities-dirty! db table data)
(alog "suck-new: done marking dirty")
((null? new-entity-requests)
(debug! "No new data to download")
(set-current! 'download 1)
(if (eqv? (get-current 'upload 0) 1)
(list (play-sound "ping")) '())
(toast "No new data to download"))))
(debug! (string-append
"Requesting "
(number->string (length new-entity-requests)) " entities"))
(play-sound "active")
(msg "build-dirty defined...")
(define (build-dirty db)
(let ((sync (get-dirty-stats db "sync"))
(stream (get-dirty-stats db "stream")))
"Sync data: " (number->string (car sync)) "/" (number->string (cadr sync)) " "
"Stream 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..."))
(toast "Uploading data...")
(play-sound "active")))
(debug! "No data changed to upload")
(set-current! 'upload 1)
(if (eqv? (get-current 'download 0) 1)
(list (play-sound "ping")) '())
(toast "No data changed to upload"))))) r)))
(define (connect-to-net fn)
(lambda (state)
(debug! (string-append "Raspberry Pi connection state now: " state))
(if (equal? state "Connected") (fn) '())
;;(update-widget 'text-view (get-id "sync-connect") 'text state)
(define i18n-lang 0)
(define i18n-text
(define (mtext-lookup id)
(define (_ l)
((null? l) (string-append (symbol->string id) " not translated"))
((eq? (car (car l)) id)
(let ((translations (cadr (car l))))
(if (<= (length translations) i18n-lang)
(string-append (symbol->string id) " not translated")
(let ((r (list-ref translations i18n-lang)))
(if (or (equal? r "") (equal? r " "))
(list-ref translations 0) r)))))
(else (_ (cdr l)))))
(_ i18n-text))
(define (symbol->id id)
(when (not (symbol? id))
(msg "symbol->id: [" id "] is not a symbol"))
(make-id (symbol->string id)))
(define (get-symbol-id id)
(when (not (symbol? id))
(msg "symbol->id: [" id "] is not a symbol"))
(get-id (symbol->string id)))
(define (mbutton id fn)
(button (symbol->id id)
(mtext-lookup id)
40 (layout 'fill-parent 'wrap-content -1 'centre 5) fn))
(define (mbutton-scale id fn)
(button (symbol->id id)
(mtext-lookup id)
40 (layout 'fill-parent 'wrap-content 1 'centre 5) fn))
(define (mtoggle-button id fn)
(toggle-button (symbol->id id)
(mtext-lookup id)
30 (layout 'fill-parent 'wrap-content -1 'centre 0) "fancy"
;; convert to 0/1 for easier db storage
(lambda (v) (fn (if v 1 0)))))
(define (mtoggle-button-scale id fn)
(toggle-button (symbol->id id)
(mtext-lookup id)
30 (layout 'fill-parent 'wrap-content 1 'centre 0) "fancy"
(lambda (