;;; 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)))