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
nebogeo
symbai
Commits
a527726e
Commit
a527726e
authored
Apr 14, 2014
by
dave griffiths
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch 'master' of github.com:nebogeo/symbai
parents
d7ef0456
02979ce5
Changes
7
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
1328 additions
and
505 deletions
+1328
-505
android/AndroidManifest.xml
android/AndroidManifest.xml
+1
-1
android/assets/dbsync.scm
android/assets/dbsync.scm
+377
-27
android/assets/eavdb.scm
android/assets/eavdb.scm
+246
-39
android/assets/lib.scm
android/assets/lib.scm
+24
-0
android/assets/starwisp.scm
android/assets/starwisp.scm
+672
-438
android/res/drawable/logo.png
android/res/drawable/logo.png
+0
-0
android/res/layout/spinner_item.xml
android/res/layout/spinner_item.xml
+8
-0
No files found.
android/AndroidManifest.xml
View file @
a527726e
<?xml version="1.0" encoding="utf-8"?>
<manifest
xmlns:android=
"http://schemas.android.com/apk/res/android"
package=
"foam.symbai"
android:versionCode=
"
2
"
android:versionCode=
"
3
"
android:versionName=
"1.0"
>
<application
android:label=
"@string/app_name"
android:icon=
"@drawable/logo"
...
...
android/assets/dbsync.scm
View file @
a527726e
...
...
@@ -68,12 +68,20 @@
;; store a ktv, replaces existing with same key
(
define
(
entity-add-value!
key
type
value
)
;;(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
)
(
set-current!
'entity-values
(
ktv-set
(
get-current
'entity-values
'
())
(
ktv
key
type
value
))))
(
ktv
-create
key
type
value
))))
(
define
(
entity-set!
ktv-list
)
(
set-current!
'entity-values
ktv-list
))
...
...
@@ -83,7 +91,6 @@
;; version to check the entity has the key
(
define
(
entity-set-value!
key
type
value
)
(
msg
"entity-set-value!"
)
(
let
((
existing-type
(
ktv-get-type
(
get-current
'entity-values
'
())
key
)))
(
if
(
equal?
existing-type
type
)
(
set-current!
...
...
@@ -91,8 +98,11 @@
(
ktv-set
(
get-current
'entity-values
'
())
(
ktv
key
type
value
)))
(
msg
"entity-set-value -"
key
"of type"
type
"doesn't exist on this entity"
))
(
msg
"done entity-set-value!"
)))
;;
(
begin
(
msg
"entity-set-value! - adding new "
key
"of type"
type
"to entity"
)
(
entity-add-value-create!
key
type
value
)))))
(
define
(
date-time->string
dt
)
(
string-append
...
...
@@ -109,23 +119,26 @@
(
table
(
get-current
'table
#f
))
(
type
(
get-current
'entity-type
#f
)))
;; 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
))))
(
entity-add-value!
"deleted"
"int"
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
)))
;; just to be on the safe side
(
entity-reset!
)))
(
let
((
r
(
entity-create!
db
table
type
(
get-current
'entity-values
'
()))))
(
entity-reset!
)
r
)))
(
define
(
entity-create!
db
table
entity-type
ktv-list
)
(
let
((
values
(
append
(
list
(
ktv-create
"user"
"varchar"
(
get-current
'user-id
"none"
))
(
ktv-create
"time"
"varchar"
(
date-time->string
(
date-time
)))
(
ktv-create
"lat"
"real"
(
car
(
get-current
'location
'
(
0
0
))))
(
ktv-create
"lon"
"real"
(
cadr
(
get-current
'location
'
(
0
0
))))
(
ktv-create
"deleted"
"int"
0
))
ktv-list
)))
(
let
((
r
(
insert-entity/get-unique
db
table
entity-type
(
get-current
'user-id
"no id"
)
values
)))
(
msg
"entity-create: "
entity-type
)
r
)))
(
define
(
entity-update-values!
)
(
let
((
db
(
get-current
'db
#f
))
...
...
@@ -138,7 +151,9 @@
(
update-entity
db
table
(
entity-id-from-unique
db
table
unique-id
)
values
)
(
msg
"updated "
unique-id
)
(
msg
values
)
(
entity-reset!
))
;; removed due to save button no longer exiting activity - need to keep!
;;(entity-reset!)
)
(
else
(
msg
"no values or no id to update as entity:"
unique-id
"values:"
values
))))))
...
...
@@ -164,7 +179,7 @@
(
msg
"url"
)
(
define
(
build-url-from-ktv
ktv
)
(
string-append
"&"
(
ktv-key
ktv
)
":"
(
ktv-type
ktv
)
"="
(
stringify-value-url
ktv
)))
(
string-append
"&"
(
ktv-key
ktv
)
":"
(
ktv-type
ktv
)
":"
(
number->string
(
ktv-version
ktv
))
"="
(
stringify-value-url
ktv
)))
(
define
(
build-url-from-ktvlist
ktvlist
)
(
foldl
...
...
@@ -200,13 +215,12 @@
r
))
'
()
ktvlist
))
(
msg
"spit"
)
;; spit all dirty entities to server
(
define
(
spit
db
table
entities
)
(
msg
"running spit"
)
(
foldl
(
lambda
(
e
r
)
;;(msg (car (car e)))
(
debug!
(
string-append
"Sending a "
(
car
(
car
e
))
" to Raspberry Pi"
))
(
append
(
list
...
...
@@ -271,6 +285,8 @@
(
ktvlist
(
list-ref
data
1
))
(
unique-id
(
list-ref
entity
1
))
(
exists
(
entity-exists?
db
table
unique-id
)))
(
msg
"from server...:"
)
(
msg
ktvlist
)
;; need to check exists again here, due to delays back and forth
(
if
(
not
exists
)
(
insert-entity-wholesale
...
...
@@ -298,6 +314,7 @@
"new-entities-req"
(
string-append
url
"fn=entity-versions&table="
table
)
(
lambda
(
data
)
(
msg
"entity-versions:"
data
)
(
let
((
r
(
foldl
(
lambda
(
i
r
)
(
let*
((
unique-id
(
car
i
))
...
...
@@ -309,6 +326,13 @@
db
table
(
get-entity-id
db
table
unique-id
)))
#f
)))
(
msg
"suck check entity old="
old
)
(
msg
"version there"
version
)
(
when
exists
(
msg
"version here"
(
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
(
or
(
not
exists
)
old
)
(
cons
(
suck-entity-from-server
db
table
unique-id
)
r
)
...
...
@@ -373,3 +397,329 @@
(
list
;;(update-widget 'text-view (get-id "sync-connect") 'text state)
))))))
(
define
i18n-lang
0
)
(
define
i18n-text
(
list
))
(
msg
123
)
(
define
(
mtext-lookup
id
)
(
define
(
_
l
)
(
cond
((
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"
)
(
list-ref
translations
i18n-lang
))))
(
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
(
v
)
(
fn
(
if
v
1
0
)))))
(
define
(
mtext
id
)
(
text-view
(
symbol->id
id
)
(
mtext-lookup
id
)
30
(
layout
'wrap-content
'wrap-content
-1
'centre
0
)))
(
define
(
mtext-fixed
w
id
)
(
text-view
(
symbol->id
id
)
(
mtext-lookup
id
)
30
(
layout
w
'wrap-content
-1
'centre
0
)))
(
define
(
mtext-small
id
)
(
text-view
(
symbol->id
id
)
(
mtext-lookup
id
)
20
(
layout
'wrap-content
'wrap-content
-1
'centre
0
)))
(
define
(
mtext-scale
id
)
(
text-view
(
symbol->id
id
)
(
mtext-lookup
id
)
30
(
layout
'wrap-content
'wrap-content
1
'centre
0
)))
(
define
(
mtitle
id
)
(
text-view
(
symbol->id
id
)
(
mtext-lookup
id
)
50
(
layout
'fill-parent
'wrap-content
-1
'centre
5
)))
(
define
(
mtitle-scale
id
)
(
text-view
(
symbol->id
id
)
(
mtext-lookup
id
)
50
(
layout
'fill-parent
'wrap-content
1
'centre
5
)))
(
define
(
medit-text
id
type
fn
)
(
vert
(
text-view
0
(
mtext-lookup
id
)
30
(
layout
'wrap-content
'wrap-content
-1
'centre
0
))
(
edit-text
(
symbol->id
id
)
""
30
type
(
layout
'fill-parent
'wrap-content
-1
'centre
0
)
fn
)))
(
define
(
medit-text-scale
id
type
fn
)
(
vert
(
text-view
0
(
mtext-lookup
id
)
30
(
layout
'wrap-content
'wrap-content
1
'centre
0
))
(
edit-text
(
symbol->id
id
)
""
30
type
(
layout
'fill-parent
'wrap-content
1
'centre
0
)
fn
)))
(
define
(
mspinner
id
types
fn
)
(
vert
(
text-view
(
symbol->id
id
)
(
mtext-lookup
id
)
30
(
layout
'wrap-content
'wrap-content
1
'centre
10
))
(
spinner
(
make-id
(
string-append
(
symbol->string
id
)
"-spinner"
))
(
map
mtext-lookup
types
)
(
layout
'wrap-content
'wrap-content
1
'centre
0
)
(
lambda
(
c
)
(
fn
c
)))))
(
define
(
mspinner-other
id
types
fn
)
(
horiz
(
vert
(
text-view
(
symbol->id
id
)
(
mtext-lookup
id
)
30
(
layout
'wrap-content
'wrap-content
1
'centre
10
))
(
spinner
(
make-id
(
string-append
(
symbol->string
id
)
"-spinner"
))
(
map
mtext-lookup
types
)
(
layout
'wrap-content
'wrap-content
1
'centre
0
)
(
lambda
(
c
)
(
fn
c
))))
(
vert
(
mtext-scale
'other
)
(
edit-text
(
make-id
(
string-append
(
symbol->string
id
)
"-edit-text"
))
""
30
"normal"
(
layout
'fill-parent
'wrap-content
1
'centre
0
)
(
lambda
(
t
)
(
fn
t
))))))
(
define
(
mspinner-other-vert
id
text-id
types
fn
)
(
linear-layout
0
'vertical
(
layout
'fill-parent
'wrap-content
1
'centre
5
)
(
list
0
0
0
0
)
(
list
(
text-view
(
symbol->id
id
)
(
mtext-lookup
text-id
)
30
(
layout
'wrap-content
'wrap-content
1
'centre
5
))
(
spinner
(
make-id
(
string-append
(
symbol->string
id
)
"-spinner"
))
(
map
mtext-lookup
types
)
(
layout
'wrap-content
'wrap-content
1
'centre
0
)
(
lambda
(
c
)
(
fn
c
)))
(
mtext-scale
'other
)
(
edit-text
(
make-id
(
string-append
(
symbol->string
id
)
"-edit-text"
))
""
30
"normal"
(
layout
'fill-parent
'wrap-content
1
'centre
0
)
(
lambda
(
t
)
(
fn
t
))))))
(
define
(
mclear-toggles
id-list
)
(
map
(
lambda
(
id
)
(
update-widget
'toggle-button
(
get-id
id
)
'checked
0
))
id-list
))
(
define
(
mclear-toggles-not-me
me
id-list
)
(
foldl
(
lambda
(
id
r
)
(
if
(
equal?
me
id
)
r
(
cons
(
update-widget
'toggle-button
(
get-id
id
)
'checked
0
)
r
)))
'
()
id-list
))
(
define
(
image-invalid?
image-name
)
(
or
(
null?
image-name
)
(
not
image-name
)
(
equal?
image-name
"none"
)))
;; fill out the widget from the current entity in the memory store
;; dispatches based on widget type
(
define
(
mupdate
widget-type
id-symbol
key
)
(
cond
((
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
)
(
update-widget
widget-type
(
get-symbol-id
id-symbol
)
'checked
(
entity-get-value
key
)))
((
eq?
widget-type
'image-view
)
(
let
((
image-name
(
entity-get-value
key
)))
(
if
(
image-invalid?
image-name
)
(
update-widget
widget-type
(
get-symbol-id
id-symbol
)
'image
"face"
)
(
update-widget
widget-type
(
get-symbol-id
id-symbol
)
'external-image
(
string-append
dirname
"files/"
image-name
)))))
(
else
(
msg
"mupdate-widget unhandled widget type"
widget-type
))))
(
define
(
mupdate-spinner
id-symbol
key
choices
)
(
let*
((
val
(
entity-get-value
key
))
(
index
(
index-find
val
(
map
mtext-lookup
choices
))))
(
if
index
(
update-widget
'spinner
(
get-id
(
string-append
(
symbol->string
id-symbol
)
"-spinner"
))
'selection
index
)
(
begin
(
msg
"spinner item in db "
val
" not found in list of items"
)
(
update-widget
'spinner
(
get-id
(
string-append
(
symbol->string
id-symbol
)
"-spinner"
))
'selection
0
)))))
(
define
(
mupdate-spinner-other
id-symbol
key
choices
)
(
msg
"update spinner other..."
)
(
let*
((
val
(
entity-get-value
key
))
(
index
(
index-find
val
(
map
mtext-lookup
choices
))))
(
if
index
(
update-widget
'spinner
(
get-id
(
string-append
(
symbol->string
id-symbol
)
"-spinner"
))
'selection
index
)
(
update-widget
'edit-text
(
get-id
(
string-append
(
symbol->string
id-symbol
)
"-edit-text"
))
'selection
index
))))
;;;;
;; (y m d h m s)
(
define
(
date-minus-months
d
ms
)
(
let
((
year
(
list-ref
d
0
))
(
month
(
-
(
list-ref
d
1
)
1
)))
(
let
((
new-month
(
-
month
ms
)))
(
list
(
if
(
<
new-month
0
)
(
-
year
1
)
year
)
(
+
(
if
(
<
new-month
0
)
(
+
new-month
12
)
new-month
)
1
)
(
list-ref
d
2
)
(
list-ref
d
3
)
(
list-ref
d
4
)
(
list-ref
d
5
)))))
(
define
(
do-gps
display-id
key-prepend
)
(
let
((
loc
(
get-current
'location
'
(
0
0
))))
(
entity-set-value!
(
string-append
key-prepend
"-lat"
)
"real"
(
car
loc
))
(
entity-set-value!
(
string-append
key-prepend
"-lon"
)
"real"
(
cadr
loc
))
(
list
(
update-widget
'text-view
(
get-id
(
string-append
(
symbol->string
display-id
)
"-lat"
))
'text
(
number->string
(
car
loc
)))
(
update-widget
'text-view
(
get-id
(
string-append
(
symbol->string
display-id
)
"-lon"
))
'text
(
number->string
(
cadr
loc
))))))
(
define
(
mupdate-gps
display-id
key-prepend
)
(
let
((
lat
(
entity-get-value
(
string-append
key-prepend
"-lat"
)))
(
lon
(
entity-get-value
(
string-append
key-prepend
"-lon"
))))
(
if
(
or
(
not
lat
)
(
not
lon
))
(
list
(
update-widget
'text-view
(
get-id
(
string-append
(
symbol->string
display-id
)
"-lat"
))
'text
"O"
)
(
update-widget
'text-view
(
get-id
(
string-append
(
symbol->string
display-id
)
"-lon"
))
'text
"0"
))
(
list
(
update-widget
'text-view
(
get-id
(
string-append
(
symbol->string
display-id
)
"-lat"
))
'text
(
number->string
lat
))
(
update-widget
'text-view
(
get-id
(
string-append
(
symbol->string
display-id
)
"-lon"
))
'text
(
number->string
lon
))))))
;; 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
title
entity-type
edit-activity
parent-fn
ktv-default
)
(
vert-colour
colour-two
(
horiz
(
mtitle-scale
title
)
(
button
(
make-id
(
string-append
(
symbol->string
title
)
"-add"
))
(
mtext-lookup
'add-item-to-list
)
40
(
layout
100
'wrap-content
1
'centre
5
)
(
lambda
()
(
entity-create!
db
table
entity-type
(
ktvlist-merge
ktv-default
(
list
(
ktv
"parent"
"varchar"
(
parent-fn
)))))
(
list
(
update-list-widget
db
table
entity-type
edit-activity
(
parent-fn
))))))
(
linear-layout
(
make-id
(
string-append
entity-type
"-list"
))
'vertical
(
layout
'fill-parent
'wrap-content
1
'centre
20
)
(
list
0
0
0
0
)
(
list
))))
;; pull db data into list of button widgets
(
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"
))
'contents
(
if
(
null?
search-results
)
(
list
(
mtext
'list-empty
))
(
map
(
lambda
(
e
)
(
button
(
make-id
(
string-append
"list-button-"
(
ktv-get
e
"unique_id"
)))
(
or
(
ktv-get
e
"name"
)
"Unamed item"
)
40
(
layout
'fill-parent
'wrap-content
1
'centre
5
)
(
lambda
()
(
msg
"sending start act"
(
ktv-get
e
"unique_id"
))
(
list
(
start-activity
edit-activity
0
(
ktv-get
e
"unique_id"
))))))
search-results
)))))
(
define
(
delete-button
)
(
mbutton
'delete
(
lambda
()
(
list
(
alert-dialog
"delete-check"
(
mtext-lookup
'delete-are-you-sure
)
(
lambda
(
v
)
(
cond
((
eqv?
v
1
)
(
entity-set-value!
"deleted"
"int"
1
)
(
entity-update-values!
)
(
list
(
finish-activity
1
)))
(
else
(
list
)))))))))
android/assets/eavdb.scm
View file @
a527726e
...
...
@@ -27,23 +27,59 @@
;; entity-attribut-value system for sqlite
;;
;; create eav tables (add types as required)
(
define
(
setup
db
table
)
(
db-exec
db
(
string-append
"create table "
table
"_entity ( entity_id integer primary key autoincrement, entity_type varchar(256), unique_id varchar(256), dirty integer, version integer)"
))
(
db-exec
db
(
string-append
"create table "
table
"_attribute ( id integer primary key autoincrement, attribute_id varchar(256), entity_type varchar(256), attribute_type varchar(256))"
))
(
db-exec
db
(
string-append
"create table "
table
"_value_varchar ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer)"
))
(
db-exec
db
(
string-append
"create table "
table
"_value_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer, dirty integer)"
))
(
db-exec
db
(
string-append
"create table "
table
"_value_real ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value real, dirty integer)"
))
(
db-exec
db
(
string-append
"create table "
table
"_value_file ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty integer)"
)))
(
db-exec
db
(
string-append
"create table "
table
"_value_varchar ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty
integer, version
integer)"
))
(
db-exec
db
(
string-append
"create table "
table
"_value_int ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value integer, dirty
integer, version
integer)"
))
(
db-exec
db
(
string-append
"create table "
table
"_value_real ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value real, dirty
integer, version
integer)"
))
(
db-exec
db
(
string-append
"create table "
table
"_value_file ( id integer primary key autoincrement, entity_id integer, attribute_id varchar(255), value varchar(4096), dirty
integer, version
integer)"
)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic key/type/value structure
(
define
(
ktv
key
type
value
)
(
list
key
type
value
))
;; used for all data internally, and maps to the eavdb types
(
define
(
ktv
key
type
value
)
(
list
key
type
value
-999
))
(
define
(
ktv-with-version
key
type
value
version
)
(
list
key
type
value
version
))
(
define
(
ktv-create
key
type
value
)
(
list
key
type
value
0
))
(
define
ktv-key
car
)
(
define
ktv-type
cadr
)
(
define
ktv-value
caddr
)
(
define
(
ktv-version
ktv
)
(
list-ref
ktv
3
))
(
define
(
ktv-eq?
a
b
)
(
and
(
equal?
(
ktv-key
a
)
(
ktv-key
b
))
(
equal?
(
ktv-type
a
)
(
ktv-type
b
))
(
cond
((
or
(
equal?
(
ktv-type
a
)
"int"
)
(
equal?
(
ktv-type
a
)
"real"
))
(
eqv?
(
ktv-value
a
)
(
ktv-value
b
)))
((
or
(
equal?
(
ktv-type
a
)
"varchar"
)
(
equal?
(
ktv-type
a
)
"file"
))
(
equal?
(
ktv-value
a
)
(
ktv-value
b
)))
(
else
(
msg
"unsupported ktv type in ktv-eq?: "
(
ktv-type
a
))
#f
))))
;; replace or insert a ktv
(
define
(
ktvlist-replace
ktv
ktvlist
)
(
cond
((
null?
ktvlist
)
(
list
ktv
))
((
equal?
(
ktv-key
(
car
ktvlist
))
(
ktv-key
ktv
))
(
cons
ktv
(
cdr
ktvlist
)))
(
else
(
cons
(
car
ktvlist
)
(
ktvlist-replace
ktv
(
cdr
ktvlist
))))))
(
define
(
ktvlist-merge
a
b
)
(
foldl
(
lambda
(
ktv
r
)
(
ktvlist-replace
ktv
r
))
a
b
))
;; stringify based on type (for url)
(
define
(
stringify-value
ktv
)
...
...
@@ -65,6 +101,7 @@
(
number->string
(
ktv-value
ktv
))
(
ktv-value
ktv
)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; helper to return first instance from a select
(
define
(
select-first
db
str
.
args
)
...
...
@@ -105,11 +142,11 @@
type
))))))
;; low level insert of a ktv
(
define
(
insert-value
db
table
entity-id
ktv
)
(
define
(
insert-value
db
table
entity-id
ktv
dirty
)
;; use type to dispatch insert to correct value table
(
db-insert
db
(
string-append
"insert into "
table
"_value_"
(
ktv-type
ktv
)
" values (null, ?, ?, ?,
0
)"
)
entity-id
(
ktv-key
ktv
)
(
ktv-value
ktv
)))
" values (null, ?, ?, ?,
?, ?
)"
)
entity-id
(
ktv-key
ktv
)
(
ktv-value
ktv
)
(
if
dirty
1
0
)
(
ktv-version
ktv
)))
(
define
(
get-unique
user
)
(
let
((
t
(
time-of-day
)))
...
...
@@ -140,23 +177,45 @@
;; add all the keys
(
for-each
(
lambda
(
ktv
)
(
insert-value
db
table
id
ktv
))
(
insert-value
db
table
id
ktv
dirty
))
ktvlist
)
id
))
;; update the value given an entity type, a attribute type and it's key (= attriute_id)
;; creates the value if it doesn't already exist, updates it otherwise
;; creates the value if it doesn't already exist, updates it otherwise
if it's different
(
define
(
update-value
db
table
entity-id
ktv
)
(
if
(
null?
(
select-first
db
(
string-append
"select * from "
table
"_value_"
(
ktv-type
ktv
)
" where entity_id = ? and attribute_id = ?"
)
entity-id
(
ktv-key
ktv
)))
(
insert-value
db
table
entity-id
ktv
)
(
db-exec
db
(
string-append
"update "
table
"_value_"
(
ktv-type
ktv
)
" set value=? where entity_id = ? and attribute_id = ?"
)
(
ktv-value
ktv
)
entity-id
(
ktv-key
ktv
))))
(
msg
"update-value"
)
(
let
((
s
(
select-first
db
(
string-append
"select value from "
table
"_value_"
(
ktv-type
ktv
)
" where entity_id = ? and attribute_id = ?"
)
entity-id
(
ktv-key
ktv
))))
(
if
(
null?
s
)
(
insert-value
db
table
entity-id
ktv
#t
)
;; only update if they are different