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
651e57f3
Commit
651e57f3
authored
Jul 11, 2014
by
dave griffiths
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
raspberry pi changes
parent
cb1894d6
Changes
7
Show whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
243 additions
and
56 deletions
+243
-56
eavdb/eavdb.ss
eavdb/eavdb.ss
+13
-5
eavdb/entity-csv.ss
eavdb/entity-csv.ss
+170
-33
eavdb/entity-filter.ss
eavdb/entity-filter.ss
+21
-10
eavdb/entity-sync.ss
eavdb/entity-sync.ss
+17
-0
web/run
web/run
+2
-1
web/scripts/sql.ss
web/scripts/sql.ss
+4
-1
web/server.scm
web/server.scm
+16
-6
No files found.
eavdb/eavdb.ss
View file @
651e57f3
...
...
@@ -35,14 +35,24 @@
(
msg
"hello from eavdb.ss"
)
(
define
(
upgrade-table
db
name
)
(
db-exec
db
(
string-append
"alter table "
name
" add version integer"
)))
;; create eav tables (add types as required)
(
define
(
setup
db
table
)
(
msg
"db setup"
)
(
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, version integer)"
))
(
upgrade-table
db
(
string-append
table
"_value_varchar"
))
(
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)"
))
(
upgrade-table
db
(
string-append
table
"_value_int"
))
(
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)"
)))
(
upgrade-table
db
(
string-append
table
"_value_real"
))
(
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)"
))
(
upgrade-table
db
(
string-append
table
"_value_file"
)))
(
define
(
validate
db
)
...
...
@@ -53,11 +63,10 @@
;; helpers
(
define
(
db-all
db
table
type
)
(
msg
"db-all"
)
(
map
(
lambda
(
i
)
(
get-entity
db
table
i
))
(
dbg
(
all-entities
db
table
type
)))
)
(
all-entities
db
table
type
)))
(
define
(
db-with-parent
db
table
type
parent
)
(
map
...
...
@@ -73,8 +82,7 @@
;; only return (eg. name and photo)
(
define
(
db-filter-only
db
table
type
filter
kt-list
)
(
msg
"db-filter-only"
)
(
map
(
lambda
(
i
)
(
get-entity-only
db
table
i
kt-list
))
(
dbg
(
filter-entities
db
table
type
filter
)))
)
(
filter-entities
db
table
type
filter
)))
eavdb/entity-csv.ss
View file @
651e57f3
...
...
@@ -33,14 +33,25 @@
"id "
(
get-attribute-ids/types
db
table
entity-type
)))
(
define
(
csv
db
table
entity-type
)
(
define
(
csv-old
db
table
entity-type
)
(
let
((
s
(
db-select
db
(
string-append
"select entity_id, unique_id from "
table
"_entity where entity_type = ?"
)
entity-type
)))
(
msg
"CSV ------------------------------>"
entity-type
)
(
msg
s
)
(
if
(
null?
s
)
;; nothing here, just return titles
(
csv-titles
db
table
entity-type
)
(
foldl
(
lambda
(
res
r
)
(
msg
res
)
(
let
((
entity
(
get-entity-for-csv
db
table
(
vector-ref
res
0
))))
(
string-append
r
"\n"
(
foldl
(
lambda
(
ktv
r
)
(
msg
ktv
)
(
cond
((
equal?
(
ktv-key
ktv
)
"unique_id"
)
r
)
((
null?
(
ktv-value
ktv
))
...
...
@@ -50,12 +61,17 @@
((
and
(
>
(
string-length
(
ktv-key
ktv
))
8
)
(
equal?
(
substring
(
ktv-key
ktv
)
0
8
)
"id-list-"
))
(
string-append
r
", \""
(
get-entity-names
db
"sync"
(
string-split
(
ktv-value
ktv
)
'
(
#
\
,
)))
"\""
))
(
let
((
ids
(
string-split
(
ktv-value
ktv
)
'
(
#
\
,
))))
(
if
(
null?
ids
)
(
string-append
r
", \"\""
)
(
string-append
r
", \""
(
get-entity-names
db
"sync"
"\""
)))))
;; look for unique ids and dereference them
((
and
(
>
(
string-length
(
ktv-key
ktv
))
3
)
(
equal?
(
substring
(
ktv-key
ktv
)
0
3
)
"id-"
)
(
not
(
equal?
(
ktv-value
ktv
)
"none"
)))
(
msg
"looking up name"
)
(
msg
ktv
)
(
let
((
name
(
get-entity-name
db
"sync"
(
ktv-value
ktv
))))
(
if
(
null?
name
)
"\"nobody\""
...
...
@@ -65,7 +81,128 @@
(
vector-ref
res
1
)
;; unique_id
entity
))))
(
csv-titles
db
table
entity-type
)
(
cdr
(
db-select
(
cdr
s
)))))
(
define
(
csv
db
table
entity-type
)
(
let
((
s
(
db-select
db
(
string-append
"select entity_id, unique_id from "
table
"_entity where entity_type = ?"
)
entity-type
))))
table
"_entity where entity_type = ?"
)
entity-type
)))
(
msg
"CSV ------------------------------>"
entity-type
)
(
if
(
null?
s
)
;; nothing here, just return titles
(
csv-titles
db
table
entity-type
)
(
foldl
(
lambda
(
res
r
)
(
let
((
entity
(
get-entity-for-csv
db
table
(
vector-ref
res
0
))))
(
string-append
r
"\n"
(
foldl
(
lambda
(
ktv
r
)
(
cond
((
equal?
(
ktv-key
ktv
)
"unique_id"
)
r
)
((
null?
(
ktv-value
ktv
))
(
msg
"value not found in csv for "
(
ktv-key
ktv
))
(
string-append
r
", NULL"
))
;; dereferences lists of ids
(
else
(
string-append
r
", \""
(
stringify-value-url
ktv
)
"\""
))))
(
vector-ref
res
1
)
;; unique_id
entity
))))
(
csv-titles
db
table
entity-type
)
(
cdr
s
)))))
;; exporting human editable reports
(
define
(
deref-entity
db
entity
)
(
foldl
(
lambda
(
ktv
r
)
(
append
r
(
list
(
ktv-key
ktv
)
(
cond
;; dereferences lists of ids
((
and
(
>
(
string-length
(
ktv-key
ktv
))
8
)
(
equal?
(
substring
(
ktv-key
ktv
)
0
8
)
"id-list-"
))
(
get-entity-names
db
"sync"
(
string-split
(
ktv-value
ktv
)
'
(
#
\
,
))))
;; look for unique ids and dereference them
((
and
(
>
(
string-length
(
ktv-key
ktv
))
3
)
(
equal?
(
substring
(
ktv-key
ktv
)
0
3
)
"id-"
))
(
get-entity-name
db
"sync"
(
ktv-value
ktv
)))
(
else
(
ktv-value
ktv
))))))
'
()
entity
))
(
define
(
csv-convert
col
)
(
if
(
number?
col
)
(
number->string
col
)
(
if
(
string?
col
)
col
(
begin
(
msg
"csvify found:"
col
)
"oops"
))))
;; convert list of lists into comma seperated columns
;; and newline seperated rows
(
define
(
csvify
l
)
(
foldl
(
lambda
(
row
r
)
(
let
((
row-text
(
foldl
(
lambda
(
col
r
)
(
let
((
converted
(
csv-convert
col
)))
(
if
(
equal?
r
""
)
converted
(
string-append
r
", "
converted
))))
""
row
)))
(
msg
row-text
)
(
string-append
r
row-text
"\n"
)))
""
l
))
(
define
(
ktv-filter
ktv-list
key
)
(
filter
(
lambda
(
ktv
)
(
not
(
equal?
(
ktv-key
ktv
)
key
)))
ktv-list
))
(
define
(
ktv-filter-many
ktv-list
key-list
)
(
foldl
(
lambda
(
key
r
)
(
ktv-filter
r
key
))
ktv-list
key-list
))
;; meant to be general, but made for pup focal reports
;(define (export-csv db table parent-entity entity-types)
; (let* ((focal (get-entity db "sync" (get-entity-id db "sync" (ktv-get parent-entity "id-focal-subject"))))
; (pack (get-entity db "sync" (get-entity-id db "sync" (ktv-get focal "pack-id")))))
; (csvify
; (cons
; '("time" "user" "pack" "subject" "observation type" "key" "value" "key" "value")
; (sort
; (foldl
; (lambda (entity-type r)
; (append
; r (map
; (lambda (entity)
; (append
; (list
; (ktv-get entity "time")
; (ktv-get entity "user")
; (ktv-get pack "name")
; (ktv-get focal "name")
; entity-type)
; (deref-entity
; db (ktv-filter-many
; entity (list "user" "unique_id" "parent" "time")))))
; (db-all-with-parent
; db table entity-type
; (ktv-get parent-entity "unique_id")))))
; '()
; entity-types)
; (lambda (a b)
; (string<? (car a) (car b))))))))
eavdb/entity-filter.ss
View file @
651e57f3
...
...
@@ -50,11 +50,21 @@
(
cdr
fl
))
(
else
(
cons
(
car
fl
)
(
delete-filter
key
(
cdr
fl
))))))
(
define
(
build-query
table
filter
)
;; replace - with _
(
define
(
mangle
var
)
(
list->string
(
map
(
lambda
(
c
)
(
cond
((
eqv?
c
#\-
)
#\_
)
(
else
c
)))
(
string->list
var
))))
(
define
(
build-query
table
filter
typed
)
(
string-append
(
foldl
(
lambda
(
i
r
)
(
let
((
var
(
string-append
(
filter-key
i
)
"_var"
)))
(
let
((
var
(
mangle
(
string-append
(
filter-key
i
)
"_var"
)))
)
;; add a query chunk
(
string-append
r
"join "
table
"_value_"
(
filter-type
i
)
" "
...
...
@@ -68,12 +78,13 @@
;; order by name
"join "
table
"_value_varchar "
"as n on n.entity_id = e.entity_id and n.attribute_id = 'name' "
;; ignore deleted
"join "
table
"_value_int "
;; ignore deleted
(if exists)
"
left
join "
table
"_value_int "
"as d on d.entity_id = e.entity_id and d.attribute_id = 'deleted' and "
"d.value = 0 "
)
"d.value = 0
or d.value = NULL
"
)
filter
)
"where e.entity_type = ? order by n.value"
))
(
if
typed
"where e.entity_type = ? order by n.value"
"order by n.value"
)))
(
define
(
build-args
filter
)
(
map
...
...
@@ -84,10 +95,10 @@
(
define
(
filter-entities
db
table
type
filter
)
(
let
((
s
(
apply
db-select
(
dbg
(
append
(
list
db
(
build-query
table
filter
))
(
append
(
list
db
(
build-query
table
filter
(
not
(
equal?
type
"*"
))
))
(
build-args
filter
)
(
list
type
))))))
(
if
(
equal?
type
"*"
)
'
()
(
list
type
))))))
(
msg
(
db-status
db
))
(
if
(
null?
s
)
'
()
...
...
eavdb/entity-sync.ss
View file @
651e57f3
...
...
@@ -80,6 +80,23 @@
(
get-entity-plain-for-sync
db
table
(
vector-ref
i
0
))))
(
cdr
de
)))))
;; include all the ktvs
(
define
(
dirty-entities-for-review
db
table
)
(
let
((
de
(
db-select
db
(
string-append
"select entity_id, entity_type, unique_id, dirty, version from "
table
"_entity where dirty=1;"
))))
(
if
(
null?
de
)
'
()
(
map
(
lambda
(
i
)
;;(msg "dirty-entities")
(
list
;; build according to url ([table] entity-type unique-id dirty version)
(
cdr
(
vector->list
i
))
(
get-entity-plain
db
table
(
vector-ref
i
0
))))
(
cdr
de
)))))
;; todo: BROKEN...
;; used for sync-all
;(define (dirty-and-all-entities db table)
...
...
web/run
View file @
651e57f3
#!/bin/bash
./server.scm 8889
./server.scm 8889
>>
client/htdocs/log.txt 2>&1
web/scripts/sql.ss
View file @
651e57f3
...
...
@@ -22,8 +22,11 @@
;; tinyscheme
;(define db-select db-exec)
(
define
(
db-exec
.
args
)
(
with-handlers
(((
lambda
(
x
)
#t
)
(
lambda
(
x
)
(
msg
"error:"
x
))))
(
apply
exec/ignore
args
)))
;; racket
(
define
db-exec
exec/ignore
)
(
define
db-select
select
)
(
define
db-insert
insert
)
(
define
(
db-status
db
)
(
errmsg
db
))
...
...
web/server.scm
View file @
651e57f3
#
!/usr//bin/env
mzscheme
#
lang
scheme/base
#
!/usr//bin/env
racket
#
lang
racket
;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths
;;
;; This program is free software: you can redistribute it and/or modify
...
...
@@ -15,7 +15,7 @@
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(
require
scheme
/system
(
require
racket
/system
scheme/foreign
scheme/cmdline
web-server/servlet
...
...
@@ -64,6 +64,15 @@
; (msg "couldn't get lock")
; (pluto-response (scheme->txt '("fail"))))))
(
define
(
syncro-new
fn
)
(
msg
"s-start"
)
(
semaphore-wait
sema
)
(
let
((
r
(
fn
)))
(
msg
"s-end"
)
(
semaphore-post
sema
)
r
))
(
define
registered-requests
(
list
...
...
@@ -150,7 +159,7 @@
(
lambda
()
(
msg
"entity-csv"
)
(
let
((
r
(
csv
db
table
type
)))
(
msg
"--------------------------------------- csv request for"
type
"["
r
"]"
)
;;
(msg "--------------------------------------- csv request for" type "[" r "]")
(
pluto-response
r
))))))
...
...
@@ -161,8 +170,8 @@
(
lambda
()
(
msg
"file-list"
)
(
pluto-response
(
dbg
(
scheme->txt
(
map
path->string
(
directory-list
"files/"
))))))))
)
(
scheme->txt
(
map
path->string
(
directory-list
"files/"
))))))))
))
...
...
@@ -172,6 +181,7 @@
(
if
(
not
(
null?
values
))
; do we have some parameters?
(
let
((
name
(
assq
'fn
values
)))
(
msg
"request incoming:"
name
)
(
msg
"arguments:"
values
)
(
if
name
; is this a well formed request?
(
request-dispatch
registered-requests
...
...
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