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