raspberry pi changes

eavdb/eavdb.ss

@@ -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

@@ -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

@@ -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

@@ -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

 #!/bin/bash
-./server.scm 8889
+./server.scm 8889 >>client/htdocs/log.txt 2>&1
+
 
 

web/scripts/sql.ss

@@ -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

-#!/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