Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Dave Griffiths
mongoose-2000
Commits
b16d27ce
Commit
b16d27ce
authored
Jul 02, 2014
by
dave griffiths
Browse files
syncing parallel fixes
parent
06ecbda4
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
108 additions
and
51 deletions
+108
-51
eavdb/eavdb.ss
eavdb/eavdb.ss
+1
-1
eavdb/entity-csv.ss
eavdb/entity-csv.ss
+77
-33
web/run
web/run
+1
-1
web/scripts/sql.ss
web/scripts/sql.ss
+9
-2
web/server.scm
web/server.scm
+20
-14
No files found.
eavdb/eavdb.ss
View file @
b16d27ce
...
...
@@ -37,7 +37,7 @@
(
define
(
upgrade-table
db
name
)
(
db-exec
db
(
string-append
"alter table "
name
" add
column
version integer"
)))
(
db-exec
db
(
string-append
"alter table "
name
" add version integer"
)))
;; create eav tables (add types as required)
...
...
eavdb/entity-csv.ss
View file @
b16d27ce
...
...
@@ -33,39 +33,83 @@
"id "
(
get-attribute-ids/types
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
))
(
msg
"value not found in csv for "
(
ktv-key
ktv
))
(
string-append
r
", NULL"
))
;; dereferences lists of ids
((
and
(
>
(
string-length
(
ktv-key
ktv
))
8
)
(
equal?
(
substring
(
ktv-key
ktv
)
0
8
)
"id-list-"
))
(
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\""
(
string-append
r
", \""
name
"\""
))))
(
else
(
string-append
r
", \""
(
stringify-value-url
ktv
)
"\""
))))
(
vector-ref
res
1
)
;; unique_id
entity
))))
(
csv-titles
db
table
entity-type
)
(
cdr
s
)))))
(
define
(
csv
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
((
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
)
'
(
#
\
,
)))
"\""
))
;; 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"
)))
(
let
((
name
(
get-entity-name
db
"sync"
(
ktv-value
ktv
))))
(
if
(
null?
name
)
"\"nobody\""
(
string-append
r
", \""
name
"\""
))))
(
else
(
string-append
r
", \""
(
stringify-value-url
ktv
)
"\""
))))
(
vector-ref
res
1
)
;; unique_id
entity
))))
(
csv-titles
db
table
entity-type
)
(
cdr
(
db-select
(
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
)
(
msg
s
)
(
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
)
(
msg
ktv
)
(
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
)))))
web/run
View file @
b16d27ce
#!/bin/bash
./server.scm 888
9
./server.scm 888
8
web/scripts/sql.ss
View file @
b16d27ce
...
...
@@ -23,7 +23,10 @@
;(define db-select db-exec)
;; racket
(
define
db-exec
exec/ignore
)
(
define
(
db-exec
.
args
)
(
with-handlers
(((
lambda
(
x
)
#t
)
(
lambda
(
x
)
(
msg
"error:"
x
))))
(
apply
exec/ignore
args
)))
(
define
db-select
select
)
(
define
db-insert
insert
)
(
define
(
db-status
db
)
(
errmsg
db
))
...
...
@@ -35,7 +38,11 @@
(
cond
((
file-exists?
(
string->path
db-name
))
(
display
"open existing db"
)(
newline
)
(
open
(
string->path
db-name
)))
(
let
((
db
(
open
(
string->path
db-name
))))
;; upgrade...
(
setup-fn
db
"sync"
)
(
setup-fn
db
"stream"
)
db
))
(
else
(
display
"making new db"
)(
newline
)
(
let
((
db
(
open
(
string->path
db-name
))))
...
...
web/server.scm
View file @
b16d27ce
#
!/usr//bin/env
mzscheme
#
!/usr//bin/env
racket
#
lang
scheme/base
;; Naked on Pluto Copyright (C) 2010 Aymeric Mansoux, Marloes de Valk, Dave Griffiths
;;
...
...
@@ -51,18 +51,24 @@
(
define
sema
(
make-semaphore
1
))
(
define
(
syncro-try
fn
)
(
msg
"s-start"
)
(
if
(
semaphore-try-wait?
sema
)
(
let
((
r
(
fn
)))
(
msg
"s-end"
)
(
semaphore-post
sema
)
r
)
(
begin
(
msg
"couldn't get lock"
)
(
pluto-response
(
scheme->txt
'
(
"fail"
))))))
(
define
(
syncro
fn
)
(
fn
))
; (msg "s-start")
; (if (semaphore-try-wait? sema)
; (let ((r (fn)))
; (msg "s-end")
; (semaphore-post sema)
; r)
; (begin
; (msg "couldn't get lock")
; (pluto-response (scheme->txt '("fail"))))))
(
msg
"s-start"
)
(
semaphore-wait
sema
)
(
let
((
r
(
fn
)))
(
msg
"s-end"
)
(
semaphore-post
sema
)
r
))
(
define
registered-requests
(
list
...
...
@@ -101,14 +107,14 @@
(
lambda
()
(
msg
"sync"
)
(
pluto-response
(
scheme->txt
(
dbg
(
scheme->txt
(
check-for-sync
db
table
entity-type
unique-id
(
string->number
dirty
)
(
string->number
version
)
(
dbg
data
))))))))
(
string->number
version
)
(
dbg
data
))))))))
)
;; returns a table of all entities and their corresponding versions
(
register
...
...
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