cl-deck-builder2/src/db.lisp

#|

src/db.lisp

Database / connection skeleton generated by Caveman.

Additional changes:

WITH-DATAFLY-CONNECTION :: Same as WITH-CONNECTION, but we use
DATAFLY:*CONNECTION* instead of MITO.CORE:*CONNECTION*.

WITH-DATAFLY-TRANSACTION is the same.

TODO: I would like to be able to specify :MITO or :DATAFLY.

TODO Test this stuff

DONE Caveman has a db module and dbi manager middleware - Looks
useless. We already have CONNECT-CACHED in db.lisp.

|#

(in-package :cl-user)

(defpackage #:cl-deck-builder2.db
  (:use #:cl)
  (:import-from #:cl-deck-builder2.config
                #:config)
  (:import-from #:cl-deck-builder2.toolkit
                #:grouped
                #:relative-pathname)
  (:import-from #:cl-dbi
                #:connect-cached)
  (:export #:connection-settings
           #:db
           #:with-connection
           #:with-transaction
           #:with-datafly-connection
           #:with-datafly-transaction
           #:with-includes

           #:do-grouped-insert

           #:count-dao
           #:create-dao
           #:delete-by-values
           #:delete-from
           #:delete-dao

           #:create-table
           #:drop-table
           #:recreate-table

           #:find-dao
           #:find-or-make-instance
           #:find-or-create-instance
           #:insert-dao
           #:max-dao
           #:retrieve-by-sql
           #:retrieve-dao
           #:save-dao
           #:select-dao
           #:update-dao)
  (:documentation "The database package.

This is more than just the default generated by Caveman2 skeleton.

It provides convenience functions for accessing database information and objects."))

(in-package #:cl-deck-builder2.db)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun connection-settings (&optional (db :maindb))
  "Query the Caveman configuration for these database settings. DB is the name of the configuration query, e.g. :MAINDB."
  (cdr (assoc db (config :databases))))

(defun db (&optional (db :maindb))
  "Get a handle to an open database, possibly cached with CONNECT-CACHED."
  (apply #'connect-cached (connection-settings db)))

(defmacro with-connection (conn &body body)
  "Wrap BODY using LEXICAL-LET to bind MITO.CORE:*CONNECTION* to CONN."
  ;; TODO
  ;; `(if (and (listp ,conn)
  ;;           (eq (type-of ,(car conn)) 'cl-dbi::dbi-connection))
  ;;      (let ((,(car conn) ,(cdr conn)))
  ;;        ,@body))
  `(let ((mito.core:*connection* ,conn))
     ,@body))

(defmacro with-transaction (&body body)
  "Wrap BODY with CL-DBI:WITH-TRANSACTION."
  `(cl-dbi:with-transaction mito.core:*connection*
     ,@body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; What's a better way to do this? DEFGENERIC?
(defmacro with-datafly-connection (conn &body body)
  "Wrap BODY using LEXICAL-LET to bind DATAFLY:*CONNECTION* to CONN."
  `(let ((datafly:*connection* ,conn))
     ;; (datafly:*trace-sql* t))
     ,@body))

(defmacro with-datafly-transaction (&body body)
  "Wrap BODY with CL-DBI:WITH-TRANSACTION. Datafly variant."
  `(cl-dbi:with-transaction datafly:*connection*
     ,@body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; I didn't realize that this implicitly only allows SELECT-DAO. I
;; guess in the MITO documentation he only allows SELECT-DAO to have
;; MITO:INCLUDES machinery. Where is that captured? For now, I assume
;; you know this, and that WITH-INCLUDES is only compatible with
;; SELECT-DAO anyway.
(defmacro with-includes (class includes &body body)
  `(mito:select-dao ,class
     ,includes
     ,@body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; What happened here? It used to work now it's returning NIL. A LOOP
;; is nicer than a DOLIST+SETF but...
(defun do-grouped-insert (obj &key (n 1000) (fn #'mito:insert-dao))
  "Batch INSERT-DAO to the database. Display a progress bar."
  (let ((pos 0)
        (width 50)
        (grouped (grouped obj n)))
    (with-connection (db)
      (loop for group in grouped
            collect
            (prog1
                (with-transaction
                  (mapcan fn group))
              (format t ".")
              (if (>= pos (1- width))
                  (progn
                    (setf pos 0)
                    (format t "~%"))
                  (incf pos))
              (finish-output))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO FIND-DAO-OR-MAKE-INSTANCE?
;; TODO Maybe merge FIND-OR-MAKE-INSTANCE and FIND-OR-CREATE-INSTANCE
(defun find-or-make-instance (class &rest args)
  "Wrap MITO:FIND-DAO and if no result is returned, issue MAKE-INSTANCE for CLASS."
  (with-connection (db)
    (with-transaction
      (or (apply #'mito:find-dao class args)
          (apply #'make-instance class args)))))

(defun find-or-create-instance (class &rest args)
  "Wrap MITO:FIND-DAO and if no result is returned, issue CREATE-DAO for CLASS."
  (with-connection (db)
    (with-transaction
      (or (apply #'mito:find-dao class args)
          (apply #'mito:create-dao class args)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DAOs
(defmacro select-dao (class &body body)
  "Select an object of CLASS from the database by wrapping MITO:SELECT-DAO in WITH-CONNECTION etc.

Note that SELECT-DAO is a DEFMACRO form.

You may additionally specify BODY parameters that are SXQL statements."
  `(with-connection (db)
     (with-transaction
       (mito:select-dao ,class ,@body))))

(defun delete-from (class &rest clauses)
  "Delete entries for CLASS by wrapping SXQL:DELETE-FROM.

You may additionally specify CLAUSES parameters that are SXQL statements."
  (with-connection (db)
    (with-transaction
      (mito:execute-sql
       (apply #'sxql:make-statement :delete-from
              (sxql:make-sql-symbol
               (mito.class:table-name (find-class class)))
              clauses)))))

(defun count-dao (class &rest fields-and-values)
  "Count the number of entries matching this CLASS using FIELDS-AND-VALUES.

Simply wrap MITO:COUNT-DAO in WITH-CONNECTION etc."
  (with-connection (db)
    (with-transaction
      (apply #'mito:count-dao class fields-and-values))))

(defun create-dao (class &rest initargs)
  "Create an entry for this CLASS by wrapping MITO:CREATE-DAO in WITH-CONNECTION etc."
  (with-connection (db)
    (with-transaction
      (apply #'mito:create-dao class initargs))))

(defun max-dao (class &rest fields-and-values &key (field :id))
  "Select the aggregate MAX from the SQL database and return the result, if any.

You may additionally specify the FIELD to find the MAX by."
  (setf class (mito.util::ensure-class class))
  (let ((sql (sxql:select ((:as (:ifnull (:max field) 0) :max))
               (sxql:from (sxql:make-sql-symbol
                           (mito.class:table-name class))))))
    (when fields-and-values
      (sxql:add-child sql (mito.dao::where-and fields-and-values class)))
    (getf (first
           (retrieve-by-sql sql))
          :max)))

(defun delete-by-values (class &rest fields-and-values)
  "Delete an entry for this CLASS by wrapping MITO:DELETE-BY-VALUES.

You may specify additional FIELDS-AND-VALUES to narrow your search."
  (with-connection (db)
    (with-transaction
      (apply #'mito:delete-by-values class fields-and-values))))

(defun delete-dao (obj)
  (with-connection (db)
    (with-transaction
      (mito:delete-dao obj))))

(defun find-dao (class &rest fields-and-values)
  "Find an entry for this CLASS, if it exists, by wrapping MITO:FIND-DAO.

You may specify additional FIELDS-AND-VALUES to narrow your search."
  (with-connection (db)
    (with-transaction
      (apply #'mito:find-dao class fields-and-values))))

(defun insert-dao (obj)
  "Insert an existing object OBJ into the database by wrapping MITO:INSERT-DAO in WITH-CONNECTION etc."
  (with-connection (db)
    (with-transaction
      (mito:insert-dao obj))))

(defun save-dao (obj)
  "Save an existing object OBJ into the database by wrapping MITO:SAVE-DAO in WITH-CONNECTION etc."
  (with-connection (db)
    (with-transaction
      (mito:save-dao obj))))

(defun update-dao (obj)
  "Update an existing object OBJ into the database by wrapping MITO:UPDATE-DAO in WITH-CONNECTION etc."
  (with-connection (db)
    (with-transaction
      (mito:update-dao obj))))

(defun retrieve-by-sql (sql &key binds)
  "Retrieve a query from the database by wrapping MITO:RETRIEVE-BY-SQL in WITH-CONNECTION etc.

I don't know what BINDS does. I think it has something to do with passing parameters to queries."
  (with-connection (db)
    (with-transaction
      (mito:retrieve-by-sql sql :binds binds))))

(defun retrieve-dao (class &rest fields-and-values)
  "Retrieve a row for this CLASS, if it exists, by wrapping MITO:RETRIEVE-DAO.

You may specify additional FIELDS-AND-VALUES to narrow your search."
  (with-connection (db)
    (with-transaction
      (apply #'mito:retrieve-dao class fields-and-values))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tables
(defun create-table (&rest classes)
  "Create tables for CLASSES by wrapping MITO:ENSURE-TABLE-EXISTS.

CLASSES may be a list of classes to create corresponding tables for."
  (with-connection (db)
    (with-transaction
      (mapcar (alexandria:compose #'mito:ensure-table-exists #'find-class)
              classes))))

(defun drop-table (&rest classes)
  "Drop tables for CLASSES by wrapping SXQL:DROP-TABLE.

CLASSES may be a list of classes to drop corresponding tables for."
  (with-connection (db)
    (with-transaction
      (mapcar (lambda (class)
                (mito:execute-sql
                 (sxql:drop-table
                  (sxql:make-sql-symbol
                   (mito.class:table-name (find-class class)))
                  :if-exists t)))
              classes))))

(defun recreate-table (&rest classes)
  "DROP-TABLE then CREATE-TABLE for CLASSES."
  (mapcar #'drop-table classes)
  (mapcar #'create-table classes))