Commit 4492c06f authored by Dave Griffiths's avatar Dave Griffiths
Browse files

imported symbai version of base stuff

parent df7416c2
......@@ -63,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
......@@ -83,8 +82,14 @@
;; 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)))
;; only return (eg. name and photo)
(define (db-filter-only-inc-deleted db table type filter kt-list)
(map
(lambda (i)
(get-entity-only db table i kt-list))
(filter-entities-inc-deleted db table type filter)))
......@@ -89,7 +89,6 @@
"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)
......@@ -100,7 +99,6 @@
r "\n"
(foldl
(lambda (ktv r)
(msg ktv)
(cond
((equal? (ktv-key ktv) "unique_id") r)
((null? (ktv-value ktv))
......@@ -116,7 +114,7 @@
;; exporting human editable reports
(define (deref-entity entity)
(define (deref-entity db entity)
(foldl
(lambda (ktv r)
(append
......@@ -160,37 +158,51 @@
(string-append r ", " converted))))
"" row)))
(msg row-text)
(dbg (string-append r row-text "\n"))))
(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
(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))))))))
;(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))))))))
......@@ -86,6 +86,28 @@
(if typed "where e.entity_type = ? order by n.value"
"order by n.value")))
(define (build-query-inc-deleted table filter)
(string-append
(foldl
(lambda (i r)
(let ((var (string-append (filter-key i) "_var")))
;; add a query chunk
(string-append
r "join " table "_value_" (filter-type i) " "
"as " var " on "
var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and "
var ".value " (filter-op i) " ? ")))
;; boilerplate query start
(string-append
"select e.entity_id from " table "_entity as e "
;; order by name
"join " table "_value_varchar "
"as n on n.entity_id = e.entity_id and n.attribute_id = 'name' ")
filter)
"where e.entity_type = ? order by n.value"))
(define (build-args filter)
(map
(lambda (i)
......@@ -93,6 +115,23 @@
filter))
(define (filter-entities db table type filter)
(let ((q (build-query table filter (not (equal? type "*")))))
(let ((s (apply
db-select
(append
(list db q)
(build-args filter)
(list type)))))
(msg (db-status db))
(if (null? s)
'()
(map
(lambda (i)
(vector-ref i 0))
(cdr s))))))
(define (filter-entities-inc-deleted db table type filter)
(let ((q (build-query-inc-deleted table filter)))
(let ((s (apply
db-select
(append
......@@ -105,4 +144,4 @@
(map
(lambda (i)
(vector-ref i 0))
(cdr s)))))
(cdr s))))))
......@@ -65,8 +65,7 @@
;; add all the keys
(for-each
(lambda (ktv)
(msg "inserting" ktv)
(insert-value db table id ktv dirty))
(insert-value db table id ktv (not (zero? dirty))))
ktvlist)
(db-exec db "end transaction")
......
......@@ -68,7 +68,8 @@
(define (dirty-entities db table)
(let ((de (db-select
db (string-append
"select entity_id, entity_type, unique_id, dirty, version from " table "_entity where dirty=1;"))))
"select entity_id, entity_type, unique_id, dirty, version from "
table "_entity where dirty=1 limit 5;"))))
(if (null? de)
'()
(map
......
......@@ -88,7 +88,7 @@
;;(msg ktv)
;;(msg entity-id)
(if (null? s)
(insert-value db table entity-id ktv #t)
(insert-value db table entity-id ktv #t) ;; <- don't make dirty!?
(db-exec
db (string-append "update " table "_value_" (ktv-type ktv)
" set value=?, dirty=0 where entity_id = ? and attribute_id = ?")
......@@ -114,8 +114,8 @@
" where entity_id = ? and attribute_id = ?")
entity-id (ktv-key kt))))
(if (null? s) '()
(list (vector-ref (cadr s) 0)
(vector-ref (cadr s) 1)))))
(list (vector-ref (cadr s) 0)
(vector-ref (cadr s) 1)))))
(define (clean-value db table entity-id kt)
(db-exec db (string-append "update " table "_value_" (ktv-type kt)
......
......@@ -25,6 +25,13 @@
(ktv-value (car ktv-list)))
(else (ktv-get (cdr ktv-list) key))))
(define (ktv-get-whole ktv-list key)
(cond
((null? ktv-list) #f)
((equal? (ktv-key (car ktv-list)) key)
(car ktv-list))
(else (ktv-get-whole (cdr ktv-list) key))))
(define (ktv-get-type ktv-list key)
(cond
((null? ktv-list) #f)
......
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