171 lines
6.9 KiB
Racket
171 lines
6.9 KiB
Racket
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
#lang 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 syndicate/pattern
|
|
)
|
|
|
|
(require db)
|
|
(require racket/set)
|
|
(require racket/string)
|
|
(require 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)))))))
|