Skip to content

GitLab

Commit b16d27ce authored by dave griffiths's avatar dave griffiths
Browse files

syncing parallel fixes

parent 06ecbda4
Hide whitespace changes
Inline Side-by-side
Showing with 108 additions and 51 deletions
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 8889
./server.scm 8888
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
......
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