296 行
9.9 KiB
Common Lisp
296 行
9.9 KiB
Common 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))
|