104 lines
2.9 KiB
Common Lisp
104 lines
2.9 KiB
Common Lisp
;;; cl-scopes/storage/storage.lisp
|
|
|
|
;;;; Common layer for SQL storage functionality.
|
|
|
|
(defpackage :scopes/storage
|
|
(:use :common-lisp)
|
|
(:export #:*db-config*
|
|
#:make-engine #:make-storage #:engine
|
|
#:timestamp-to-sql
|
|
#:db-options #:db-params #:qualified-table-name
|
|
#:do-sql #:query #:drop-table
|
|
#:schema))
|
|
|
|
(in-package :scopes/storage)
|
|
|
|
(defparameter *db-config* nil)
|
|
|
|
(defvar *backends*
|
|
'(:dbi dbi-make-engine))
|
|
|
|
(defvar *db-engines*
|
|
'(:postgres db-engine-pg))
|
|
|
|
(defvar *db-params*
|
|
'(:sqlite3 (:id-type integer :json-type json)
|
|
:postgres (:id-type bigserial :json-type jsonb)))
|
|
|
|
(defclass db-engine ()
|
|
((connect :initarg :connect)
|
|
(params :initarg :params)
|
|
(config :reader config :initarg :config)))
|
|
|
|
(defun make-engine ()
|
|
(let ((backend (getf *db-config* :backend)))
|
|
(funcall (getf *backends* backend) *db-config*)))
|
|
|
|
(defgeneric timestamp-to-sql (engine ts))
|
|
|
|
(defmethod timestamp-to-sql ((engine db-engine) ts) ts)
|
|
|
|
(defclass storage ()
|
|
((engine :reader engine :initarg :engine)
|
|
(conn :reader conn)
|
|
(schema :accessor schema)))
|
|
|
|
(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)))
|
|
|
|
(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))))
|
|
|
|
;;; 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)
|
|
(format nil "~a" (local-time:universal-to-timestamp ts)))
|