syndicate-rkt/syndicate/drivers/sqlite.rkt

; SPDX-License-Identifier: LGPL-3.0-or-later
; Copyright (C) 2010-2021 Tony Garnock-Jones <tonygarnockjones@gmail.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)))))))