93 lines
2.8 KiB
Common Lisp
93 lines
2.8 KiB
Common 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)
|
|
(:util :scopes/util)
|
|
(:alx :alexandria))
|
|
(:export #:config
|
|
#:storage #:params #:setup
|
|
#:qualified-table-name
|
|
#:do-sql #:query #:drop-table
|
|
#:normalize-plist))
|
|
|
|
(in-package :scopes/storage)
|
|
|
|
;;;; config
|
|
|
|
(defclass config (config:base)
|
|
((backend :reader backend :initarg :backend :initform :dbi)
|
|
(db-type :reader db-type :initarg :db-type :initform :sqlite3)
|
|
(connect-args :reader connect-args :initarg :connect-args)
|
|
(options :reader options :initarg :options :initform nil)))
|
|
|
|
(defvar *db-params*
|
|
'(:sqlite3 (:id-type integer :json-type json :ts-sql identity)
|
|
:postgres (:id-type bigserial :json-type jsonb :ts-sql ts-string)))
|
|
|
|
;;;; 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* ((db-type (db-type cfg))
|
|
(conn-args (connect-args cfg))
|
|
(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 (options cfg) :schema))
|
|
ctx))
|
|
|
|
;;;; 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)
|
|
;(util:lgd sql args)
|
|
(let* ((qp (dbi:prepare (conn st) sql))
|
|
(qx (dbi:execute qp args)))
|
|
(mapcar #'normalize-plist (dbi:fetch-all qx)))))
|
|
|
|
(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-plist (pl)
|
|
(let ((res nil))
|
|
(alx:doplist (k v pl res)
|
|
(push v res)
|
|
(push (util:to-keyword k) res))))
|
|
|
|
(defun ts-string (ts)
|
|
(format nil "~a" (local-time:universal-to-timestamp ts)))
|