sqlite driver
This commit is contained in:
parent
939396b9b7
commit
f6ab8320c5
|
@ -0,0 +1,167 @@
|
|||
#lang imperative-syndicate
|
||||
;; SQLite driver
|
||||
|
||||
(provide (struct-out sqlite-db)
|
||||
(struct-out sqlite-db-ready)
|
||||
(struct-out sqlite-row)
|
||||
(struct-out sqlite-exec)
|
||||
(struct-out sqlite-create-table)
|
||||
(struct-out sqlite-insert)
|
||||
(struct-out sqlite-delete)
|
||||
sqlite-exec!
|
||||
sqlite-create-table!
|
||||
sqlite-insert!
|
||||
sqlite-delete!
|
||||
(struct-out discard) ;; from imperative-syndicate/pattern
|
||||
)
|
||||
|
||||
(require db)
|
||||
(require racket/set)
|
||||
(require racket/string)
|
||||
(require imperative-syndicate/pattern)
|
||||
|
||||
(define-logger syndicate/sqlite)
|
||||
|
||||
(struct sqlite-db (path) #:prefab)
|
||||
|
||||
(assertion-struct sqlite-db-ready (db))
|
||||
|
||||
(assertion-struct sqlite-row (db table columns))
|
||||
|
||||
(message-struct sqlite-exec (db template arguments id))
|
||||
(message-struct sqlite-status (id value))
|
||||
|
||||
(message-struct sqlite-create-table (db table column-names id))
|
||||
(message-struct sqlite-insert (db table columns id))
|
||||
(message-struct sqlite-delete (db table columns id))
|
||||
|
||||
(define (sqlite-call db msg-proc)
|
||||
(define id (gensym 'exec))
|
||||
(react/suspend (k)
|
||||
(on (message (sqlite-status id $v))
|
||||
(if (exn? v) (raise v) (k v)))
|
||||
(on (asserted (sqlite-db-ready db))
|
||||
(send! (msg-proc id)))))
|
||||
|
||||
(define (sqlite-exec! db template . arguments)
|
||||
(sqlite-call db (lambda (id) (sqlite-exec db template arguments id))))
|
||||
|
||||
(define (sqlite-create-table! db table . column-names)
|
||||
(sqlite-call db (lambda (id) (sqlite-create-table db table column-names id))))
|
||||
|
||||
(define (sqlite-insert! db table . columns)
|
||||
(sqlite-call db (lambda (id) (sqlite-insert db table columns id))))
|
||||
|
||||
(define (sqlite-delete! db table . columns)
|
||||
(sqlite-call db (lambda (id) (sqlite-delete db table columns id))))
|
||||
|
||||
(define (strip-capture p)
|
||||
(if (capture? p)
|
||||
(strip-capture (capture-detail p))
|
||||
p))
|
||||
|
||||
(spawn #:name 'drivers/sqlite
|
||||
(during/spawn ($ db (sqlite-db $path))
|
||||
#:name (list 'drivers/sqlite path)
|
||||
(define handle (sqlite3-connect #:database path #:mode 'create)) ;; TODO: #:use-place ?
|
||||
(on-stop (disconnect handle))
|
||||
|
||||
(assert (sqlite-db-ready db))
|
||||
|
||||
(on (message (sqlite-exec db $template $arguments $id))
|
||||
(with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
|
||||
(log-syndicate/sqlite-debug "~s ~s" template arguments)
|
||||
(send! (sqlite-status id (apply query-exec handle template arguments)))))
|
||||
|
||||
(field [known-tables (set)])
|
||||
|
||||
(on (message (sqlite-create-table db $table $column-names $id))
|
||||
(with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
|
||||
(define template
|
||||
(format "create table ~a (~a)" table (string-join column-names ", ")))
|
||||
(define arguments '())
|
||||
(table-facet handle known-tables db table column-names)
|
||||
(log-syndicate/sqlite-debug "~s ~s" template arguments)
|
||||
(send! (sqlite-status id (apply query-exec handle template arguments)))))
|
||||
|
||||
(on-start
|
||||
(for [(table (query-list handle
|
||||
"select distinct name from sqlite_master where type='table'"))]
|
||||
(define column-names
|
||||
(map (lambda (r) (vector-ref r 1))
|
||||
(query-rows handle (string-append "pragma table_info(" table ")"))))
|
||||
(table-facet handle known-tables db table column-names)))))
|
||||
|
||||
(define (table-facet handle known-tables db table column-names)
|
||||
(when (not (set-member? (known-tables) table))
|
||||
(known-tables (set-add (known-tables) table))
|
||||
(react
|
||||
(on (message ($ m (sqlite-insert db table $columns $id)))
|
||||
(with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
|
||||
(define template (format "insert into ~a values (~a)"
|
||||
table
|
||||
(string-join (for/list [(i (in-naturals 1)) (c columns)]
|
||||
(format "$~a" i))
|
||||
", ")))
|
||||
(define arguments columns)
|
||||
(log-syndicate/sqlite-debug "~s ~s" template arguments)
|
||||
(send! (sqlite-status id (apply query-exec handle template arguments)))))
|
||||
|
||||
(on (message ($ m (sqlite-delete db table $columns $id)))
|
||||
(with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))]
|
||||
(define filters
|
||||
(for/list [(n column-names) (c columns) #:when (not (discard? c))]
|
||||
(list n c)))
|
||||
(define template
|
||||
(format "delete from ~a~a"
|
||||
table
|
||||
(if (null? filters)
|
||||
""
|
||||
(format " where ~a"
|
||||
(string-join (for/list [(i (in-naturals 1)) (f filters)]
|
||||
(format "~a = $~a" (car f) i))
|
||||
" and ")))))
|
||||
(define arguments (map cadr filters))
|
||||
(log-syndicate/sqlite-debug "~s ~s" template arguments)
|
||||
(send! (sqlite-status id (apply query-exec handle template arguments)))))
|
||||
|
||||
(define (row-facet columns)
|
||||
(react (assert (sqlite-row db table columns))
|
||||
(on (message (sqlite-delete db table $cs _))
|
||||
(when (for/and [(c1 columns) (c2 cs)] (or (discard? c2) (equal? c1 c2)))
|
||||
(stop-current-facet)))))
|
||||
|
||||
(during/spawn (observe (sqlite-row db table $column-patterns0))
|
||||
(define column-patterns
|
||||
(let ((ps (strip-capture column-patterns0)))
|
||||
(if (discard? ps)
|
||||
(for/list [(n column-names)] (discard))
|
||||
ps)))
|
||||
(define filters
|
||||
(for/list [(n column-names)
|
||||
(p (map strip-capture column-patterns))
|
||||
#:when (not (discard? p))]
|
||||
(list n p)))
|
||||
|
||||
(define initial-rows
|
||||
(let ()
|
||||
(define template
|
||||
(format "select distinct * from ~a~a"
|
||||
table
|
||||
(if (null? filters)
|
||||
""
|
||||
(format " where ~a"
|
||||
(string-join (for/list [(i (in-naturals 1)) (f filters)]
|
||||
(format "~a = $~a" (car f) i))
|
||||
" and ")))))
|
||||
(define arguments (map cadr filters))
|
||||
(log-syndicate/sqlite-debug "~s ~s" template arguments)
|
||||
(map vector->list (apply query-rows handle template (map cadr filters)))))
|
||||
|
||||
(on-start (for-each row-facet initial-rows))
|
||||
(on (message (sqlite-insert db table $columns _))
|
||||
(when (for/and [(n column-names) (c columns)]
|
||||
(match (assoc n filters)
|
||||
[(list _ v) (equal? c v)]
|
||||
[#f #t]))
|
||||
(row-facet columns)))))))
|
|
@ -0,0 +1,36 @@
|
|||
#lang imperative-syndicate
|
||||
|
||||
(require/activate imperative-syndicate/drivers/sqlite)
|
||||
(require/activate imperative-syndicate/drivers/timer)
|
||||
|
||||
(define PATH "t.sqlite")
|
||||
(define DB (sqlite-db PATH))
|
||||
|
||||
(spawn* (with-handlers [(exn:fail:filesystem? void)]
|
||||
(delete-file PATH))
|
||||
(react (assert DB))
|
||||
|
||||
(sqlite-create-table! DB "x" "y" "z")
|
||||
|
||||
(send! (sqlite-insert DB "x" (list 1 "yy") (gensym 'init)))
|
||||
(send! (sqlite-insert DB "x" (list "yy" "hello") (gensym 'init)))
|
||||
(send! (sqlite-insert DB "x" (list "yy" "goodbye") (gensym 'init)))
|
||||
(send! (sqlite-insert DB "x" (list 1 "yy") (gensym 'init)))
|
||||
|
||||
(react
|
||||
(during (sqlite-row DB "x" (list _ $key))
|
||||
(during (sqlite-row DB "x" (list key $value))
|
||||
(on-start (printf "+ ~a row in x: ~a\n" key value))
|
||||
(on-stop (printf "- ~a row in x: ~a\n" key value))))
|
||||
(during (sqlite-row DB "x" $columns)
|
||||
(on-start (printf "+ row in x: ~a\n" columns))
|
||||
(on-stop (printf "- row in x: ~a\n" columns))))
|
||||
|
||||
(sqlite-insert! DB "x" "a" "b")
|
||||
(sqlite-insert! DB "x" "a" "c")
|
||||
(sqlite-insert! DB "x" "yy" "b")
|
||||
(sqlite-insert! DB "x" "yy" "c")
|
||||
(sqlite-delete! DB "x" "a" "b")
|
||||
(sqlite-delete! DB "x" (discard) "b")
|
||||
(sqlite-delete! DB "x" "a" (discard))
|
||||
(sqlite-delete! DB "x" (discard) "c"))
|
Loading…
Reference in New Issue