defpersist

defpersist.lisp

(defpackage #:snippets/defpersist
  (:documentation
   "Persist a variable's values across images.")
  (:use #:cl)
  (:import-from #:sqlite
                #:with-open-database
                #:with-transaction
                #:execute-non-query
                #:execute-single
                #:execute-to-list)
  (:import-from #:constantia
                #:outs
                #:singlep)
  (:import-from #:cl-store
                #:store
                #:restore)
  (:import-from #:flexi-streams
                #:with-input-from-sequence
                #:with-output-to-sequence)
  (:import-from #:iterate
                #:iter
                #:for)
  (:export
   #:*sqlite-filename*
   #:defpersist))

(in-package #:snippets/defpersist)

(defvar *sqlite-filename*
  "/tmp/persist.db"
  "The pathname of the SQLite file.")

(defvar *db* nil
  "The current connection to our database, or NIL if there's no
connection.")

(defvar *within-tx* nil
  "True if currently within an SQLite transaction, and false otherwise.")

(defun call-with-db (function &key (tx nil))
  (cond (*db*
         (if (and tx (not *within-tx*))
             (with-transaction *db*
               (let ((*within-tx* t))
                 (funcall function)))
             (funcall function)))
        (t
         (ensure-directories-exist *sqlite-filename*)
         (with-open-database (*db* *sqlite-filename*)
           (reset)
           (let ((*within-tx* (if tx t nil)))
             (if *within-tx*
                 (with-transaction *db*
                   (funcall function))
                 (funcall function)))))))

(defmacro with-db (&body forms)
  `(call-with-db (lambda () ,@forms)))

(defmacro with-tx (&body forms)
  `(call-with-db (lambda () ,@forms) :tx t))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun parse-sqlite-command (command)
    (let* ((args-tag (member :args command))
           (sql (ldiff command args-tag))
           (sql-form (if (singlep sql)
                         (first sql)
                         `(outs (:s (list ,@sql) :separator " "))))
           (arg-forms (rest args-tag)))
      (values sql-form arg-forms))))

(macrolet ((def (macro-name sqlite-operator)
             `(defmacro ,macro-name (&body command)
                (multiple-value-bind (sql-form arg-forms)
                    (parse-sqlite-command command)
                  `(,',sqlite-operator *db* ,sql-form ,@arg-forms)))))
  (def e execute-non-query)
  (def e/s execute-single)
  (def e/l execute-to-list))

(defmacro do-query (((&rest vars) &body command) &body forms)
  (multiple-value-bind (sql-form arg-forms)
      (parse-sqlite-command command)
    `(iter (for ,vars in-sqlite-query ,sql-form on-database *db*
                with-parameters ,arg-forms)
           ,@forms)))

(defun reset (&key (hard nil))
  (with-db
    (when hard
      (e "DROP TABLE IF EXISTS symbols")
      (e "VACUUM"))
    (e "CREATE TABLE IF NOT EXISTS symbols ("
       "  qname TEXT PRIMARY KEY,"
       "  value_blob BLOB"
       ")")))

(defvar *persist-names*
  (make-hash-table :test 'eq)
  "A set of the names of variables to persist.")

(defun coerce-to-octet-vector (vector)
  (make-array (length vector)
              :element-type '(unsigned-byte 8)
              :initial-contents vector))

(defun symbol-key (symbol)
  (format nil "~A:~A"
          (package-name (symbol-package symbol))
          (symbol-name symbol)))

(defun persist-accessor (symbol)
  (intern (format nil "%~A-PERSIST" (symbol-name symbol))
          (symbol-package symbol)))

(defun read-value (key)
  (with-db
    (blob->value
     (e/s "SELECT value_blob FROM symbols"
          "WHERE qname=?"
          :args key))))

(defun persist-boundp (key)
  (with-db
    (e/s "SELECT 1 FROM symbols"
         "WHERE qname=? AND value_blob IS NOT NULL"
         :args key)))

(defun value->blob (value)
  (coerce-to-octet-vector
   (with-output-to-sequence (out :element-type '(unsigned-byte 8))
     (store value out))))

(defun blob->value (blob)
  (when blob
    (with-input-from-sequence (in blob)
      (restore in))))

(defun write-value (key new-value)
  (with-db
    (e "INSERT OR REPLACE INTO symbols"
       "(qname, value_blob)"
       "VALUES (?, ?)"
       :args key (value->blob new-value))))

(defmacro defpersist (symbol value &optional docstring)
  (let ((key (symbol-key symbol))
        (persist-accessor (persist-accessor symbol)))
    `(progn
       (let ((bound nil)
             (value nil))
         (defun ,persist-accessor ()
           (if bound
               value
               (setf bound t value (read-value ,key))))
         (defun (setf ,persist-accessor) (new-value)
           (when (or (not bound)
                     (not (eql value new-value)))
             (write-value ,key (setf value new-value))
             (setf bound t))
           new-value))
       (define-symbol-macro ,symbol
           (,persist-accessor))
       (setf (gethash ',symbol *persist-names*) t)
       (unless (persist-boundp ,key)
         (setf ,symbol ,value))
       ,@(when docstring
           `((setf (documentation ',symbol 'variable) ,docstring)))
       ',symbol)))