Skip to content

GitLab

Commit 651e57f3 authored by dave griffiths's avatar dave griffiths
Browse files

raspberry pi changes

parent cb1894d6
Show whitespace changes
Inline Side-by-side
Showing with 243 additions and 56 deletions
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
......
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