cl-scopes/storage/storage.lisp

;;; cl-scopes/storage/storage.lisp

;;;; Common layer for SQL storage functionality.

(defpackage :scopes/storage
  (:use :common-lisp)
  (:local-nicknames (:config :scopes/config)
                    (:core :scopes/core)
                    (:alx :alexandria))
  (:export #:config
           #:*db-config*
           #:make-engine #:make-storage #:engine
           #:timestamp-to-sql
           #:storage #:setup
           #:params #:db-options #:db-params #:qualified-table-name
           #:do-sql #:query #:drop-table
           #:schema
           #:normalize-keyword #:normalize-plist))

(in-package :scopes/storage)

;;;; config

(defclass config (config:base)
  ((config:env-slots :initform '(db-name db-user db-password))
   (db-config :reader db-config :initarg :db-config)    ;to be replaced
   (backend)
   (db-type)
   (connect-args)))

;;;; db configurations

(defvar *backends*
  '(:dbi dbi-make-engine))

(defvar *db-engines*
  '(:postgres db-engine-pg))

(defvar *db-params*
  '(:sqlite3 (:id-type integer :json-type json :ts-sql identity)
    :postgres (:id-type bigserial :json-type jsonb :ts-sql ts-string)))

(defclass db-engine ()
  ((connect :initarg :connect)
   (params :initarg :params)
   (config :reader config :initarg :config)))

(defun make-engine (cfg)
  (let* ((dbconf (db-config cfg))
         (backend (getf dbconf :backend)))
    (funcall (getf *backends* backend) dbconf)))

(defgeneric timestamp-to-sql (engine ts)
  (:method ((engine db-engine) ts) ts))

;;;; context and storage classes

(defclass context (core:context)
  ((storage :reader storage :initarg :storage)))

(defclass storage ()
  ((engine :reader engine :initarg :engine)
   (connect :reader connect :initarg :connect)
   (params :reader params :initarg :params)
   (conn :accessor conn)
   (schema :accessor schema)))

(defun setup (cfg)
  (let* ((conf (db-config cfg))
         (db-type (getf conf :db-type))
         (conn-args (getf conf :connect-args))
         (connect #'(lambda () 
                      (apply #'dbi:connect-cached db-type conn-args)))
         (st (make-instance 'storage 
                            :params (getf *db-params* db-type)
                            :connect connect))
         (ctx (make-instance 'context 
                             :config cfg :name (config:name cfg) :storage st)))
    (setf (conn st) (funcall connect))
    (setf (schema st) (getf (getf conf :options) :schema))
    ctx))

(defun make-storage (engine)
  (let ((st (make-instance 'storage :engine engine))
        (conn (funcall (slot-value engine 'connect))))
    (setf (slot-value st 'conn) conn)
    st))

(defun db-params (st)
  (slot-value (slot-value st 'engine) 'params))

(defun db-options (st)
  (let ((config (config (engine st))))
    (getf config :options)))

;;;; database (SQL) interface

(defun qualified-table-name (st tn)
  (let ((schema (schema st)))
    (if schema
      (intern (format nil "~a.~a" schema (symbol-name tn)))
      tn)))

(defun query (st spec)
  (multiple-value-bind (sql args) (sxql:yield spec)
    ;(print sql)
    (let* ((qp (dbi:prepare (conn st) sql))
           (qx (dbi:execute qp args)))
      (dbi:fetch-all qx))))

(defun xdo-sql (st spec)
  (multiple-value-bind (sql args) (sxql:yield spec)
    ;(print sql)
    (dbi:do-sql (conn st) sql args)))

(defun do-sql (st spec)
  (multiple-value-bind (sql args) (sxql:yield spec)
    (let* ((conn (conn st))
           (qp (dbi:prepare conn sql)))
      (dbi:execute qp args)
      (dbi:free-query-resources qp)
      (dbi:row-count conn))))

(defun drop-table (st tn)
  (let ((table (qualified-table-name st tn)))
    (do-sql st (sxql:drop-table table :if-exists t))))

;;;; utilities

(defun normalize-keyword (kw)
  (intern (string-upcase kw) :keyword))

(defun normalize-plist (pl)
  (let ((res nil))
    (alx:doplist (k v pl res)
      (push v res)
      (push (normalize-keyword k) res))))

;;;; backend-/driver-specific stuff

(defun dbi-make-engine (config)
  (let* ((db-type (getf config :db-type))
         (params (getf *db-params* db-type))
         (engine (getf *db-engines* db-type 'db-engine))
         (conn-args (getf config :connect-args)))
    (make-instance engine 
                   :params params :config config
                   :connect #'(lambda () 
                                (apply #'dbi:connect-cached db-type conn-args)))))

(defclass db-engine-pg (db-engine) ())

(defmethod timestamp-to-sql ((engine db-engine-pg) ts)
  (ts-string ts))

(defun ts-string (ts)
  (format nil "~a" (local-time:universal-to-timestamp ts)))