├── .dockerignore ├── .github ├── FUNDING.yml └── workflows │ └── ci.yml ├── .gitignore ├── CONTRIBUTING.md ├── README.markdown ├── docker-compose.yml ├── docker ├── Dockerfile └── entrypoint.sh ├── lack-middleware-mito.asd ├── mito-core.asd ├── mito-migration.asd ├── mito-test.asd ├── mito.asd ├── qlfile ├── qlfile.lock ├── roswell └── mito.ros ├── src ├── core.lisp ├── core │ ├── class.lisp │ ├── class │ │ ├── column.lisp │ │ └── table.lisp │ ├── connection.lisp │ ├── conversion.lisp │ ├── dao.lisp │ ├── dao │ │ ├── column.lisp │ │ ├── mixin.lisp │ │ ├── table.lisp │ │ └── view.lisp │ ├── db.lisp │ ├── db │ │ ├── mysql.lisp │ │ ├── postgres.lisp │ │ └── sqlite3.lisp │ ├── error.lisp │ ├── logger.lisp │ ├── type.lisp │ └── util.lisp ├── middleware.lisp ├── migration.lisp ├── migration │ ├── sql-parse.lisp │ ├── sxql.lisp │ ├── table.lisp │ ├── util.lisp │ └── versions.lisp └── mito.lisp └── t ├── class.lisp ├── dao.lisp ├── db ├── main.lisp ├── mysql.lisp ├── postgres.lisp └── sqlite3.lisp ├── migration ├── mysql.lisp ├── postgres.lisp └── sqlite3.lisp ├── mixin.lisp ├── postgres-types.lisp └── util.lisp /.dockerignore: -------------------------------------------------------------------------------- 1 | .qlot 2 | -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: [fukamachi] 2 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | test: 7 | name: ${{ matrix.lisp }} 8 | runs-on: ubuntu-latest 9 | strategy: 10 | matrix: 11 | lisp: [sbcl] 12 | 13 | steps: 14 | - uses: actions/checkout@v4 15 | - name: Run tests 16 | env: 17 | LISP: ${{ matrix.lisp }} 18 | run: | 19 | docker compose up --exit-code-from tests tests 20 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* 9 | 10 | t/test.db 11 | .qlot/ 12 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Mito 2 | 3 | Mito is an open source project and we appreciate your help! 4 | 5 | ## Reporting bugs 6 | 7 | Please [open an issue](https://github.com/fukamachi/mito/issues/new) at GitHub. 8 | 9 | Good reports must include these informations: 10 | 11 | - The full backtrace with your error 12 | - Minimum steps to reproduce it 13 | - Names and versions you are using: OS, Common Lisp implementation, RDBMS (MySQL, PostgreSQL or SQLite3), ASDF and Quicklisp dist 14 | 15 | You can get informations about your environment by this code: 16 | 17 | ```common-lisp 18 | (flet ((put (k v &rest vs) 19 | (format t "~&~A: ~A~{ ~A~}~%" k v vs))) 20 | (put "Machine" (software-type) (software-version)) 21 | (put "Lisp" (lisp-implementation-type) (lisp-implementation-version) 22 | #+(and sbcl (not sb-thread)) "(without threads)") 23 | (put "ASDF" (asdf:asdf-version)) 24 | (let ((qlversion (ql:dist-version "quicklisp"))) 25 | (put "Quicklisp" qlversion 26 | (if (string= (car (first (ql:available-dist-versions "quicklisp"))) 27 | qlversion) 28 | "(latest)" 29 | "(update available)")))) 30 | ;-> Machine: Darwin 15.2.0 31 | ; Lisp: SBCL 1.3.1 32 | ; ASDF: 3.1.5 33 | ; Quicklisp: 2015-10-31 (latest) 34 | ;=> NIL 35 | ``` 36 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '3.7' 2 | services: 3 | tests: 4 | container_name: mito-tests 5 | build: 6 | dockerfile: docker/Dockerfile 7 | context: . 8 | target: base 9 | args: 10 | - LISP=${LISP:-sbcl} 11 | restart: "no" 12 | volumes: 13 | - .:/app 14 | - /app/.qlot 15 | depends_on: 16 | - postgres 17 | - mysql 18 | environment: 19 | POSTGRES_HOST: mito-test-postgres 20 | POSTGRES_USER: mito 21 | POSTGRES_PASS: mito 22 | MYSQL_HOST: mito-test-mysql 23 | MYSQL_USER: root 24 | MYSQL_PASS: mito 25 | 26 | postgres: 27 | container_name: mito-postgres 28 | image: "postgres:10" 29 | hostname: mito-test-postgres 30 | ports: 31 | - "5432:5432" 32 | environment: 33 | POSTGRES_USER: mito 34 | POSTGRES_PASSWORD: mito 35 | 36 | mysql: 37 | container_name: mito-mysql 38 | image: "mysql:8.4" 39 | hostname: mito-test-mysql 40 | ports: 41 | - "3306:3306" 42 | command: --mysql_native_password=ON 43 | environment: 44 | MYSQL_ROOT_PASSWORD: mito 45 | -------------------------------------------------------------------------------- /docker/Dockerfile: -------------------------------------------------------------------------------- 1 | ARG LISP=sbcl 2 | 3 | FROM fukamachi/qlot AS build-env 4 | 5 | WORKDIR /app 6 | COPY qlfile /app 7 | COPY qlfile.lock /app 8 | 9 | RUN qlot install --no-deps 10 | 11 | FROM fukamachi/${LISP} AS base 12 | 13 | RUN apt-get update && \ 14 | apt-get install -y --no-install-recommends \ 15 | libsqlite3-dev \ 16 | default-libmysqlclient-dev \ 17 | default-mysql-client && \ 18 | rm -rf /var/lib/apt/lists/* 19 | 20 | WORKDIR /app 21 | RUN set -x; \ 22 | ros -e '(ql:update-dist "quicklisp" :prompt nil)' && \ 23 | ros install "fukamachi/qlot" 24 | 25 | COPY --from=build-env /app/.qlot /app/.qlot 26 | 27 | COPY . /app 28 | RUN qlot install 29 | 30 | ENTRYPOINT "/app/docker/entrypoint.sh" 31 | -------------------------------------------------------------------------------- /docker/entrypoint.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -x 4 | set -e 5 | 6 | qlot exec ros -s mito-test 7 | 8 | while ! mysql -u "$MYSQL_USER" \ 9 | -h "$MYSQL_HOST" \ 10 | -P "$MYSQL_PORT" \ 11 | -p"$MYSQL_PASS" \ 12 | -e 'CREATE DATABASE IF NOT EXISTS `mito`'; do \ 13 | sleep 1 14 | done 15 | 16 | .qlot/bin/rove mito-test.asd 17 | -------------------------------------------------------------------------------- /lack-middleware-mito.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-middleware-mito" 2 | :version "0.1" 3 | :author "Eitaro Fukamachi" 4 | :license "BSD 3-Clause" 5 | :depends-on ("mito-core" 6 | "dbi") 7 | :components ((:module "src" 8 | :components 9 | ((:file "middleware"))))) 10 | -------------------------------------------------------------------------------- /mito-core.asd: -------------------------------------------------------------------------------- 1 | (defsystem "mito-core" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "BSD 3-Clause" 5 | :depends-on ((:version "dbi" "0.11.1") 6 | "sxql" 7 | "cl-ppcre" 8 | "closer-mop" 9 | "dissect" 10 | "trivia" 11 | "local-time" 12 | "uuid" 13 | "alexandria") 14 | :components ((:file "src/core" :depends-on ("core-components")) 15 | (:module "core-components" 16 | :pathname "src/core" 17 | :components 18 | ((:file "dao" :depends-on ("dao-components")) 19 | (:module "dao-components" 20 | :pathname "dao" 21 | :depends-on ("connection" "class" "db" "conversion" "logger" "util") 22 | :components 23 | ((:file "table" :depends-on ("column" "mixin" "view")) 24 | (:file "view" :depends-on ("column")) 25 | (:file "mixin" :depends-on ("column")) 26 | (:file "column"))) 27 | (:file "class" :depends-on ("class-components")) 28 | (:module "class-components" 29 | :pathname "class" 30 | :depends-on ("error" "util") 31 | :components 32 | ((:file "table" :depends-on ("column")) 33 | (:file "column"))) 34 | (:file "connection" :depends-on ("error")) 35 | (:file "type" :depends-on ("db")) 36 | (:file "db" :depends-on ("db-drivers" "connection" "class" "util")) 37 | (:module "db-drivers" 38 | :pathname "db" 39 | :depends-on ("logger" "util") 40 | :components 41 | ((:file "mysql") 42 | (:file "postgres") 43 | (:file "sqlite3"))) 44 | (:file "conversion") 45 | (:file "logger") 46 | (:file "error") 47 | (:file "util"))))) 48 | -------------------------------------------------------------------------------- /mito-migration.asd: -------------------------------------------------------------------------------- 1 | (defsystem "mito-migration" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "BSD 3-Clause" 5 | :depends-on ("mito-core" 6 | "sxql" 7 | "dbi" 8 | "closer-mop" 9 | "esrap" 10 | "alexandria" 11 | "uiop" 12 | "chipz") 13 | :components ((:file "src/migration" :depends-on ("migration-components")) 14 | (:module "migration-components" 15 | :pathname "src/migration" 16 | :components 17 | ((:file "table" :depends-on ("sxql")) 18 | (:file "versions" :depends-on ("table" "sql-parse" "util")) 19 | (:file "sxql") 20 | (:file "sql-parse") 21 | (:file "util"))))) 22 | -------------------------------------------------------------------------------- /mito-test.asd: -------------------------------------------------------------------------------- 1 | (defsystem "mito-test" 2 | :author "Eitaro Fukamachi" 3 | :license "BSD 3-Clause" 4 | :depends-on ("mito" 5 | "dbd-mysql" 6 | "dbd-postgres" 7 | "dbd-sqlite3" 8 | "rove") 9 | :components ((:module "t" 10 | :components 11 | ((:file "util") 12 | (:file "db/main") 13 | (:file "db/sqlite3") 14 | (:file "db/mysql") 15 | (:file "db/postgres") 16 | (:file "class") 17 | (:file "dao") 18 | (:file "migration/sqlite3") 19 | (:file "migration/mysql") 20 | (:file "migration/postgres") 21 | (:file "postgres-types") 22 | (:file "mixin")))) 23 | :description "Test system for mito" 24 | :perform (test-op (op c) (symbol-call :rove :run c))) 25 | -------------------------------------------------------------------------------- /mito.asd: -------------------------------------------------------------------------------- 1 | (defsystem "mito" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "BSD 3-Clause" 5 | :depends-on ("mito-core" 6 | "mito-migration" 7 | "lack-middleware-mito" 8 | (:feature :sb-package-locks "cl-package-locks")) 9 | :components ((:file "src/mito")) 10 | :description "Abstraction layer for DB schema" 11 | :in-order-to ((test-op (test-op "mito-test")))) 12 | -------------------------------------------------------------------------------- /qlfile: -------------------------------------------------------------------------------- 1 | ql cl-dbi :upstream 2 | ql cl-mysql :upstream 3 | ql dissect :upstream 4 | ql sxql :upstream 5 | ql rove :upstream 6 | -------------------------------------------------------------------------------- /qlfile.lock: -------------------------------------------------------------------------------- 1 | ("quicklisp" . 2 | (:class qlot/source/dist:source-dist 3 | :initargs (:distribution "https://beta.quicklisp.org/dist/quicklisp.txt" :%version :latest) 4 | :version "2023-10-21")) 5 | ("cl-dbi" . 6 | (:class qlot/source/ql:source-ql-upstream 7 | :initargs nil 8 | :version "ql-upstream-f58761b4da39e0559fcfbd744fa6f024182c6d94" 9 | :remote-url "https://github.com/fukamachi/cl-dbi.git")) 10 | ("cl-mysql" . 11 | (:class qlot/source/ql:source-ql-upstream 12 | :initargs nil 13 | :version "ql-upstream-b273cf772f13a525b534f5ee58bf36fb733204f3" 14 | :remote-url "https://github.com/hackinghat/cl-mysql.git")) 15 | ("dissect" . 16 | (:class qlot/source/ql:source-ql-upstream 17 | :initargs nil 18 | :version "ql-upstream-a70cabcd748cf7c041196efd711e2dcca2bbbb2c" 19 | :remote-url "https://github.com/Shinmera/dissect.git")) 20 | ("sxql" . 21 | (:class qlot/source/ql:source-ql-upstream 22 | :initargs nil 23 | :version "ql-upstream-c79c252bef276bb0343ced5149083e3b91d85d9b" 24 | :remote-url "https://github.com/fukamachi/sxql.git")) 25 | ("rove" . 26 | (:class qlot/source/ql:source-ql-upstream 27 | :initargs nil 28 | :version "ql-upstream-cacea7331c10fe9d8398d104b2dfd579bf7ea353" 29 | :remote-url "https://github.com/fukamachi/rove.git")) 30 | -------------------------------------------------------------------------------- /roswell/mito.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | (ql:quickload '(:mito-migration :dbi :sxql :uiop :alexandria) :silent t) 7 | 8 | (defpackage :ros.script.roswell/mito.3663426439 9 | (:use #:cl 10 | #:mito.migration) 11 | (:import-from #:mito.core 12 | #:*connection* 13 | #:*mito-logger-stream* 14 | #:execute-sql) 15 | (:import-from #:dbi 16 | #:with-transaction 17 | #:connect 18 | #:) 19 | (:import-from #:sxql 20 | #:yield) 21 | (:import-from #:alexandria 22 | #:nconcf)) 23 | (in-package :ros.script.roswell/mito.3663426439) 24 | 25 | (defparameter *default-migration-directory* 26 | (merge-pathnames #P"db/" *default-pathname-defaults*)) 27 | 28 | (defmacro case-equal (keyform &body cases) 29 | (let ((g-keyform (gensym "KEYFORM"))) 30 | `(let ((,g-keyform ,keyform)) 31 | (cond 32 | ,@(loop for (case . body) in cases 33 | if (eq case 'otherwise) 34 | collect `(t ,@body) 35 | else 36 | collect `((find ,g-keyform ',(if (listp case) 37 | case 38 | (list case)) 39 | :test #'equal) 40 | ,@body)))))) 41 | 42 | (defun parse-args (args) 43 | (let ((connect-args '()) 44 | driver-type 45 | (directory *default-migration-directory*) 46 | (systems '()) 47 | force 48 | dry-run) 49 | (loop for option = (pop args) 50 | while option 51 | do (case-equal option 52 | (("-t" "--type") 53 | (let ((driver (pop args))) 54 | (setf driver-type 55 | (if driver 56 | (intern (string-upcase driver) :keyword) 57 | nil)))) 58 | (("-d" "--database") 59 | (nconcf connect-args (list :database-name (pop args)))) 60 | (("-u" "--username") 61 | (nconcf connect-args (list :username (pop args)))) 62 | (("-p" "--password") 63 | (nconcf connect-args (list :password (pop args)))) 64 | (("-H" "--host") 65 | (nconcf connect-args (list :host (pop args)))) 66 | (("-P" "--port") 67 | (nconcf connect-args (list :port (parse-integer (pop args))))) 68 | (("-s" "--system") 69 | (push (pop args) systems)) 70 | (("-D" "--directory") 71 | (setf directory (uiop:ensure-directory-pathname (pop args)))) 72 | ("--dry-run" 73 | (setf dry-run t)) 74 | (("-f" "--force") 75 | (setf force t)) 76 | (otherwise (error "Unknown option: ~A" option)))) 77 | (values (cons driver-type connect-args) directory (nreverse systems) dry-run force))) 78 | 79 | (defun print-usage () 80 | (format *error-output* "~&Usage: mito command [option...] 81 | 82 | Commands: 83 | generate-migrations 84 | migrate 85 | migration-status 86 | 87 | Options: 88 | -t, --type DRIVER-TYPE DBI driver type (one of \"mysql\", \"postgres\" or \"sqlite3\") 89 | -H, --host DATABASE-HOST Database host to use (default is 127.0.0.1) 90 | -P, --port DATABASE-PORT Database port to use (default is depends on the driver type) 91 | -d, --database DATABASE-NAME Database name to use 92 | -u, --username USERNAME Username for RDBMS 93 | -p, --password PASSWORD Password for RDBMS 94 | -s, --system SYSTEM ASDF system to load (several -s's allowed) 95 | -D, --directory DIRECTORY Directory path to keep migration SQL files (default: \"~A\") 96 | --dry-run List SQL expressions to migrate 97 | -f, --force Create a new empty migration file even when it's unnecessary. 98 | " 99 | *default-migration-directory*)) 100 | 101 | (defun main (&optional command &rest argv) 102 | (unless (find command '("generate-migrations" "migrate" "migration-status") :test #'string=) 103 | (when command 104 | (format *error-output* "~&Invalid command: ~A~%" command)) 105 | (print-usage) 106 | (uiop:quit -1)) 107 | 108 | (multiple-value-bind (connect-args directory systems dry-run force) 109 | (handler-case (parse-args argv) 110 | (error (e) (format *error-output* "~&~A~%" e) (uiop:quit -1))) 111 | (when (null (first connect-args)) 112 | (format *error-output* "~&--type is required.~%") 113 | (uiop:quit -1)) 114 | (unless (getf (cdr connect-args) :database-name) 115 | (format *error-output* "~&--database is required.~%") 116 | (uiop:quit -1)) 117 | 118 | (dolist (system systems) 119 | (format t "~&Loading ~S...~%" system) 120 | (ql:quickload system :silent t)) 121 | (write-char #\Newline) 122 | (handler-case 123 | (let ((*connection* (handler-case (let ((*standard-output* (make-broadcast-stream))) 124 | (apply #'dbi:connect connect-args)) 125 | (ql:system-not-found () 126 | (format *error-output* "~&Unknown driver type: ~A~%" (first connect-args)) 127 | (uiop:quit -1)) 128 | (error (e) 129 | (format *error-output* "~&Failed to connect to the database:~% ~A~%" e) 130 | (uiop:quit -1))))) 131 | (setf *mito-logger-stream* nil) 132 | (case-equal command 133 | ("generate-migrations" 134 | (mito.migration:generate-migrations directory :force force)) 135 | ("migrate" 136 | (mito.migration:migrate directory :dry-run dry-run)) 137 | ("migration-status" 138 | (mito.migration:migration-status directory)))) 139 | (dbi: (e) 140 | (format *error-output* "~&~A~%" e) 141 | (uiop:quit -1))))) 142 | -------------------------------------------------------------------------------- /src/core.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:mito.core 2 | (:use #:cl) 3 | (:use-reexport #:mito.dao 4 | #:mito.error) 5 | (:import-from #:mito.db 6 | #:*use-prepare-cached* 7 | #:execute-sql 8 | #:retrieve-by-sql) 9 | (:import-from #:mito.connection 10 | #:*connection* 11 | #:connect-toplevel 12 | #:disconnect-toplevel 13 | #:connection-database-name) 14 | (:import-from #:mito.logger 15 | #:*mito-logger-stream* 16 | #:*mito-migration-logger-stream* 17 | #:*trace-sql-hooks*) 18 | (:export #:*use-prepare-cached* 19 | #:execute-sql 20 | #:retrieve-by-sql 21 | #:*connection* 22 | #:connect-toplevel 23 | #:disconnect-toplevel 24 | #:connection-database-name 25 | #:*mito-logger-stream* 26 | #:*mito-migration-logger-stream* 27 | #:*trace-sql-hooks*)) 28 | (in-package #:mito.core) 29 | -------------------------------------------------------------------------------- /src/core/class.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.class 3 | (:use #:cl 4 | #:mito.class.column 5 | #:mito.class.table) 6 | (:import-from #:sxql 7 | #:make-statement 8 | #:primary-key 9 | #:unique-key 10 | #:index-key) 11 | (:import-from #:alexandria 12 | #:appendf 13 | #:ensure-list) 14 | (:export #:create-table-sxql 15 | 16 | #:table-class 17 | #:table-column-class 18 | #:table-column-name 19 | #:table-column-type 20 | #:table-column-not-null-p 21 | #:table-column-slots 22 | #:table-direct-column-slots 23 | #:table-name 24 | #:table-primary-key 25 | #:table-serial-key 26 | #:database-column-slots 27 | #:table-column-info 28 | #:table-indices-info 29 | #:find-slot-by-name 30 | 31 | #:find-parent-column 32 | #:find-child-columns)) 33 | (in-package :mito.class) 34 | 35 | (defgeneric create-table-sxql (class driver-type &key if-not-exists) 36 | (:method (class driver-type &key if-not-exists) 37 | (let ((add-indices '())) 38 | (cons 39 | (apply #'sxql:make-statement 40 | :create-table 41 | (list (sxql:make-sql-symbol (table-name class)) 42 | :if-not-exists if-not-exists) 43 | (mapcar (lambda (column) 44 | (table-column-info-for-create-table column driver-type)) 45 | (database-column-slots class)) 46 | (mapcan (lambda (index) 47 | (cond 48 | ((getf (cdr index) :primary-key) 49 | (unless (some #'primary-key-p (database-column-slots class)) 50 | (list (sxql:primary-key (mapcar #'sxql:make-sql-symbol (getf (cdr index) :columns)))))) 51 | ((getf (cdr index) :unique-key) 52 | (if (eq driver-type :postgres) 53 | (progn 54 | (appendf add-indices 55 | (list (sxql:create-index (sxql:make-sql-symbol 56 | (format nil "unique_~A_~{~A~^_~}" 57 | (table-name class) 58 | (getf (cdr index) :columns))) 59 | :on 60 | (cons (sxql:make-sql-symbol (table-name class)) 61 | (mapcar #'sxql:make-sql-symbol (getf (cdr index) :columns))) 62 | :unique t))) 63 | nil) 64 | (list (sxql:unique-key (mapcar #'sxql:make-sql-symbol (getf (cdr index) :columns)))))) 65 | (t 66 | (if (eq driver-type :postgres) 67 | (progn 68 | (appendf add-indices 69 | (list (sxql:create-index (sxql:make-sql-symbol 70 | (format nil "key_~A_~{~A~^_~}" 71 | (table-name class) 72 | (getf (cdr index) :columns))) 73 | :on 74 | (cons (sxql:make-sql-symbol (table-name class)) 75 | (mapcar #'sxql:make-sql-symbol (getf (cdr index) :columns)))))) 76 | nil) 77 | (list (sxql:index-key (mapcar #'sxql:make-sql-symbol (getf (cdr index) :columns)))))))) 78 | (table-indices-info class driver-type))) 79 | add-indices)))) 80 | 81 | (defmethod table-column-references-column ((column table-column-class)) 82 | (destructuring-bind (&optional ref-class-name ref-column-name) 83 | (ensure-list (table-column-references column)) 84 | (when ref-class-name 85 | (let ((ref-class (find-class ref-class-name))) 86 | (find-slot-by-name ref-class 87 | (or ref-column-name 88 | (let ((pk-names (table-primary-key ref-class))) 89 | (unless pk-names 90 | (error "Foreign class ~S has no primary keys and no slot name is specified to :references" 91 | (class-name ref-class))) 92 | (when (cdr pk-names) 93 | (error "Foreign class ~S has a composite primary key and failed to detect which to use for :references" 94 | (class-name ref-class))) 95 | (first pk-names)))))))) 96 | -------------------------------------------------------------------------------- /src/core/class/column.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.class.column 3 | (:use #:cl 4 | #:mito.util 5 | #:mito.error) 6 | (:import-from #:alexandria 7 | #:delete-from-plist 8 | #:ensure-car) 9 | (:export #:table-column-class 10 | #:table-column-type 11 | #:table-column-not-null-p 12 | #:table-column-name 13 | #:primary-key-p 14 | #:ghost-slot-p 15 | #:table-column-references 16 | #:table-column-references-column 17 | #:table-column-info 18 | #:table-column-info-for-create-table)) 19 | (in-package :mito.class.column) 20 | 21 | (deftype references () 22 | '(or null symbol (cons symbol (or null (cons symbol null))))) 23 | 24 | (defun parse-col-type (col-type) 25 | (trivia:match col-type 26 | ((or (list 'or :null x) 27 | (list 'or x :null)) 28 | (values x nil)) 29 | (otherwise 30 | (values col-type t)))) 31 | 32 | (defclass table-column-class (c2mop:standard-direct-slot-definition) 33 | ((col-type :type (or symbol cons null) 34 | :initarg :col-type 35 | :accessor %table-column-type) 36 | (references :type references 37 | :initarg :references 38 | :initform nil 39 | :reader table-column-references) 40 | (primary-key :type boolean 41 | :initarg :primary-key 42 | :initform nil 43 | :accessor primary-key-p) 44 | (ghost :type boolean 45 | :initarg :ghost 46 | :initform nil 47 | :accessor ghost-slot-p 48 | :documentation "Option to specify slots as ghost slots. Ghost slots do not depend on a database."))) 49 | 50 | (defgeneric table-column-type (column) 51 | (:method ((column table-column-class)) 52 | (values 53 | (parse-col-type (%table-column-type column))))) 54 | 55 | (defgeneric table-column-not-null-p (column) 56 | (:method ((column table-column-class)) 57 | (nth-value 1 (parse-col-type (%table-column-type column))))) 58 | 59 | (defgeneric table-column-name (column) 60 | (:method ((column table-column-class)) 61 | (unlispify (symbol-name-literally (c2mop:slot-definition-name column))))) 62 | 63 | (defmethod initialize-instance :around ((class table-column-class) &rest rest-initargs 64 | &key name initargs ghost 65 | &allow-other-keys) 66 | (declare (ignore ghost)) 67 | (unless (find (symbol-name name) initargs :test #'string=) 68 | ;; Add the default initarg. 69 | (push (intern (symbol-name name) :keyword) 70 | (getf rest-initargs :initargs))) 71 | 72 | (let ((class (apply #'call-next-method class rest-initargs))) 73 | (unless (slot-boundp class 'col-type) 74 | (if (or (ghost-slot-p class) 75 | (slot-value class 'references)) 76 | (setf (slot-value class 'col-type) nil) 77 | (error 'col-type-required 78 | :slot class))) 79 | class)) 80 | 81 | (defgeneric table-column-references-column (column)) 82 | 83 | (defgeneric table-column-info (column driver-type) 84 | (:method (column (driver-type (eql :sqlite3))) 85 | (let (auto-increment 86 | (col-type (table-column-type column)) 87 | (not-null (table-column-not-null-p column))) 88 | (cond 89 | ((or (eq col-type :serial) 90 | (eq col-type :bigserial)) 91 | (setf col-type :integer 92 | auto-increment t 93 | not-null t)) 94 | ((eq col-type :timestamptz) 95 | (setf col-type :timestamp))) 96 | (when auto-increment 97 | (unless (primary-key-p column) 98 | (warn "SQLite3 supports AUTOINCREMENT for PRIMARY KEYs. Ignoring :auto-increment.") 99 | (setf auto-increment nil)) 100 | (unless (eq col-type :integer) 101 | (warn "SQLite3 supports AUTOINCREMENT only for INTEGER columns. Ignoring :auto-increment.") 102 | (setf auto-increment nil))) 103 | 104 | `(,(table-column-name column) 105 | :type ,col-type 106 | :auto-increment ,auto-increment 107 | :primary-key ,(primary-key-p column) 108 | :not-null ,(or not-null 109 | (primary-key-p column))))) 110 | (:method (column (driver-type (eql :mysql))) 111 | (let (auto-increment 112 | (col-type (table-column-type column)) 113 | (not-null (table-column-not-null-p column))) 114 | (cond 115 | ((eq col-type :bigserial) 116 | (setf col-type '(:bigint () :unsigned) 117 | auto-increment t 118 | not-null t)) 119 | ((eq col-type :serial) 120 | (setf col-type '(:int () :unsigned) 121 | auto-increment t 122 | not-null t)) 123 | ((eq col-type :bytea) 124 | (setf col-type :binary)) 125 | ((eq col-type :timestamptz) 126 | (setf col-type :timestamp))) 127 | `(,(table-column-name column) 128 | :type ,col-type 129 | :auto-increment ,auto-increment 130 | :primary-key ,(primary-key-p column) 131 | :not-null ,(or not-null 132 | (primary-key-p column))))) 133 | (:method (column (driver-type (eql :postgres))) 134 | (let (auto-increment 135 | (col-type (table-column-type column)) 136 | (not-null (table-column-not-null-p column))) 137 | (cond 138 | ((eq col-type :bigserial) 139 | (setf auto-increment t 140 | not-null t)) 141 | ((eq col-type :serial) 142 | (setf auto-increment t 143 | not-null t)) 144 | ((eq (ensure-car col-type) :binary) 145 | (setf col-type :bytea)) 146 | ((eq (ensure-car col-type) :datetime) 147 | (setf col-type :timestamp))) 148 | `(,(table-column-name column) 149 | :type ,col-type 150 | :auto-increment ,auto-increment 151 | :primary-key ,(primary-key-p column) 152 | :not-null ,(or not-null 153 | (primary-key-p column))))) 154 | (:method :around (column driver-type) 155 | (let ((rel-column (table-column-references-column column))) 156 | (if rel-column 157 | (let* ((info (call-next-method)) 158 | (rel-col-type (getf (cdr (table-column-info rel-column driver-type)) :type))) 159 | (setf (getf (cdr info) :type) 160 | (ecase driver-type 161 | (:mysql 162 | (case rel-col-type 163 | (:bigserial :bigint) 164 | (:serial '(:int () :unsigned)) 165 | (otherwise rel-col-type))) 166 | (:postgres 167 | (case rel-col-type 168 | (:bigserial :bigint) 169 | (:serial :int) 170 | (otherwise rel-col-type))) 171 | (:sqlite3 172 | (case rel-col-type 173 | ((:bigserial :serial) :integer) 174 | (otherwise rel-col-type))))) 175 | info) 176 | (call-next-method))))) 177 | 178 | (defgeneric table-column-info-for-create-table (column driver-type) 179 | (:documentation "Similar to table-column-info except the return value is for sxql:make-create-table.") 180 | (:method (column driver-type) 181 | (table-column-info column driver-type)) 182 | (:method :around (column driver-type) 183 | (let ((column-info (call-next-method))) 184 | (rplaca column-info 185 | (sxql:make-sql-symbol (car column-info))) 186 | column-info)) 187 | (:method (column (driver-type (eql :mysql))) 188 | (let ((column-info (table-column-info column driver-type))) 189 | (when (and (getf (cdr column-info) :auto-increment) 190 | (member (getf (cdr column-info) :type) '(:serial :bigserial) :test #'eq)) 191 | (setf (getf (cdr column-info) :auto-increment) nil)) 192 | column-info)) 193 | (:method (column (driver-type (eql :sqlite3))) 194 | (let ((column-info (table-column-info column driver-type))) 195 | (when (getf (cdr column-info) :auto-increment) 196 | (rplaca (member :auto-increment (cdr column-info) :test #'eq) 197 | :autoincrement) 198 | ;; NOT NULL cannot be specified for an AUTOINCREMENT column 199 | (setf (cdr column-info) (delete-from-plist (cdr column-info) :not-null))) 200 | column-info)) 201 | (:method (column (driver-type (eql :postgres))) 202 | (let ((column-info (table-column-info column driver-type))) 203 | (setf (getf (cdr column-info) :auto-increment) nil) 204 | column-info))) 205 | -------------------------------------------------------------------------------- /src/core/class/table.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.class.table 3 | (:use #:cl 4 | #:mito.util) 5 | (:import-from #:mito.class.column 6 | #:parse-col-type 7 | #:table-column-class 8 | #:table-column-type 9 | #:table-column-name 10 | #:primary-key-p 11 | #:ghost-slot-p) 12 | (:import-from #:alexandria 13 | #:ensure-list) 14 | (:export #:table-class 15 | #:table-name 16 | #:table-column-slots 17 | #:table-direct-column-slots 18 | #:table-primary-key 19 | #:table-serial-key 20 | #:table-indices-info 21 | #:database-column-slots 22 | #:find-slot-by-name 23 | 24 | #:find-parent-column 25 | #:find-child-columns)) 26 | (in-package :mito.class.table) 27 | 28 | (defclass table-class (standard-class) 29 | ((primary-key :initarg :primary-key 30 | :initform nil) 31 | (unique-keys :initarg :unique-keys 32 | :initform nil) 33 | (keys :initarg :keys 34 | :initform nil) 35 | (table-name :initarg :table-name 36 | :initform nil) 37 | 38 | (parent-column-map))) 39 | 40 | (defun rel-column-name (name pk-name) 41 | (intern 42 | (format nil "~:@(~A-~A~)" name pk-name))) 43 | 44 | (defun add-referencing-slots (initargs) 45 | (let ((parent-column-map (make-hash-table :test 'eq)) 46 | (class-name (getf initargs :name))) 47 | (setf (getf initargs :direct-slots) 48 | (loop for column in (getf initargs :direct-slots) 49 | for (col-type not-null) = (multiple-value-list (parse-col-type (getf column :col-type))) 50 | 51 | if (typep col-type '(and symbol (not null) (not keyword))) 52 | append 53 | (let* ((column-name (getf column :name)) 54 | ;; FIXME: find-class raises an error if the class is not defined yet. 55 | (pk-names (if (eq col-type class-name) 56 | (or (getf initargs :primary-key) 57 | (getf (find-if (lambda (column-def) 58 | (getf column-def :primary-key)) 59 | (getf initargs :direct-slots)) 60 | :name) 61 | (loop for superclass in (getf initargs :direct-superclasses) 62 | for pk-names = (table-primary-key superclass) 63 | until pk-names 64 | finally (return pk-names))) 65 | (table-primary-key (find-class col-type))))) 66 | (unless pk-names 67 | (error "Primary keys can not be determined for ~A." 68 | col-type)) 69 | (rplacd (cdr column) 70 | `(:ghost t ,@(cddr column))) 71 | 72 | (cons column 73 | (mapcar (lambda (pk-name) 74 | (let ((rel-column-name (rel-column-name column-name pk-name))) 75 | (setf (gethash rel-column-name parent-column-map) column-name) 76 | `(:name ,rel-column-name 77 | :initargs (,(intern (symbol-name rel-column-name) :keyword)) 78 | :col-type ,(if not-null 79 | col-type 80 | `(or ,col-type :null)) 81 | :primary-key ,(getf column :primary-key) 82 | :references (,col-type ,pk-name)))) 83 | pk-names))) 84 | else collect column)) 85 | (values initargs parent-column-map))) 86 | 87 | (defun expand-relational-keys (class slot-name) 88 | (let ((keys (slot-value class slot-name)) 89 | (table-slots (table-column-slots class))) 90 | (labels ((expand-key (key) 91 | (let* ((key-name (if (stringp key) 92 | key 93 | (unlispify (symbol-name-literally key)))) 94 | (slot (find key-name table-slots 95 | :key #'table-column-name 96 | :test #'string=))) 97 | (unless slot 98 | (error "Unknown column ~S is found in ~S ~S." key (class-name class) slot-name)) 99 | (if (ghost-slot-p slot) 100 | (find-child-columns class slot) 101 | (list key)))) 102 | (expand-keys (keys) 103 | (loop for key in keys 104 | append (expand-key key)))) 105 | (setf (slot-value class slot-name) 106 | (loop for key in keys 107 | if (listp key) 108 | collect (expand-keys key) 109 | else 110 | append (expand-key key)))))) 111 | 112 | (defmethod initialize-instance :around ((class table-class) &rest initargs) 113 | (multiple-value-bind (initargs parent-column-map) 114 | (add-referencing-slots initargs) 115 | (let ((class (apply #'call-next-method class initargs))) 116 | (setf (slot-value class 'parent-column-map) parent-column-map) 117 | (expand-relational-keys class 'primary-key) 118 | (expand-relational-keys class 'unique-keys) 119 | (expand-relational-keys class 'keys) 120 | class))) 121 | 122 | (defmethod reinitialize-instance :around ((class table-class) &rest initargs) 123 | (multiple-value-bind (initargs parent-column-map) 124 | (add-referencing-slots initargs) 125 | (unless (getf initargs :primary-key) 126 | (setf (getf initargs :primary-key) nil)) 127 | (unless (getf initargs :unique-keys) 128 | (setf (getf initargs :unique-keys) nil)) 129 | (unless (getf initargs :keys) 130 | (setf (getf initargs :keys) nil)) 131 | (unless (getf initargs :table-name) 132 | (setf (getf initargs :table-name) nil)) 133 | (let ((class (apply #'call-next-method class initargs))) 134 | (setf (slot-value class 'parent-column-map) parent-column-map) 135 | (expand-relational-keys class 'primary-key) 136 | (expand-relational-keys class 'unique-keys) 137 | (expand-relational-keys class 'keys) 138 | class))) 139 | 140 | (defmethod c2mop:direct-slot-definition-class ((class table-class) &key &allow-other-keys) 141 | 'table-column-class) 142 | 143 | (defmethod c2mop:validate-superclass ((class table-class) (super standard-class)) 144 | t) 145 | 146 | (defgeneric table-name (class) 147 | (:method ((class table-class)) 148 | (if (slot-value class 'table-name) 149 | (string (car (slot-value class 'table-name))) 150 | (let ((class-name (lispify (symbol-name-literally (class-name class))))) 151 | (unlispify 152 | (if (and (char= (aref class-name 0) #\<) 153 | (char= (aref class-name (1- (length class-name))) #\>)) 154 | (subseq class-name 1 (1- (length class-name))) 155 | class-name)))))) 156 | 157 | (defgeneric table-primary-key (class) 158 | (:method ((class table-class)) 159 | (or (slot-value class 'primary-key) 160 | (let ((primary-slot (find-if 161 | #'primary-key-p 162 | (database-column-slots class)))) 163 | (if primary-slot 164 | (list (c2mop:slot-definition-name primary-slot)) 165 | nil))))) 166 | 167 | (defgeneric table-serial-key (class) 168 | (:method ((class table-class)) 169 | (let* ((primary-key (table-primary-key class)) 170 | (slot (find-if 171 | (lambda (slot) 172 | (and 173 | ;; AUTO INCREMENT slot 174 | (member (table-column-type slot) '(:serial :bigserial) 175 | :test #'eq) 176 | (member (c2mop:slot-definition-name slot) 177 | primary-key :test #'eq))) 178 | (database-column-slots class)))) 179 | (if slot 180 | (c2mop:slot-definition-name slot) 181 | nil)))) 182 | 183 | (defun table-direct-column-slots (class) 184 | (remove-if-not (lambda (slot) 185 | (typep slot 'table-column-class)) 186 | (c2mop:class-direct-slots class))) 187 | 188 | (defun map-all-superclasses (fn class &key (key #'identity)) 189 | (labels ((main (class &optional main-objects) 190 | (let ((ret (funcall fn class))) 191 | (loop for superclass in (c2mop:class-direct-superclasses class) 192 | if (eq (class-of superclass) (find-class 'standard-class)) 193 | append (if (eq superclass (find-class 'standard-object)) 194 | (append ret main-objects) 195 | ret) 196 | else 197 | append (main superclass 198 | (append ret main-objects)))))) 199 | (delete-duplicates 200 | (main class) 201 | :test #'eq 202 | :key key 203 | :from-end t))) 204 | 205 | (defun table-column-slots (class) 206 | (map-all-superclasses #'table-direct-column-slots 207 | class 208 | :key #'c2mop:slot-definition-name)) 209 | 210 | (defun find-slot-by-name (class slot-name &key (test #'eq)) 211 | (find slot-name 212 | (table-column-slots (if (typep class 'symbol) 213 | (find-class class) 214 | class)) 215 | :test test 216 | :key #'c2mop:slot-definition-name)) 217 | 218 | (defgeneric database-column-slots (class) 219 | (:method ((class table-class)) 220 | (remove-if #'ghost-slot-p 221 | (table-column-slots class)))) 222 | 223 | (defgeneric table-indices-info (class driver-type) 224 | (:method (class driver-type) 225 | (let ((table-name (table-name class))) 226 | (labels ((ensure-string (data) 227 | (etypecase data 228 | (symbol (symbol-name-literally data)) 229 | (string data))) 230 | (unlispify-keys (keys) 231 | (if (listp keys) 232 | (mapcar #'unlispify (mapcar #'ensure-string keys)) 233 | (unlispify (ensure-string keys))))) 234 | (append 235 | (when (slot-value class 'primary-key) 236 | (let ((primary-keys (slot-value class 'primary-key))) 237 | (list 238 | (list (format nil "~A_pkey" table-name) 239 | :unique-key t 240 | :primary-key t 241 | :columns (unlispify-keys primary-keys))))) 242 | ;; See also :primary-key column 243 | (let ((primary-key-slot (find-if #'primary-key-p (database-column-slots class)))) 244 | (when primary-key-slot 245 | (list 246 | (list (format nil "~A_pkey" table-name) 247 | :unique-key t 248 | :primary-key t 249 | :columns (unlispify-keys (list (table-column-name primary-key-slot))))))) 250 | 251 | (let ((unique-keys (map-all-superclasses (lambda (class) 252 | (slot-value class 'unique-keys)) 253 | class))) 254 | (when unique-keys 255 | (mapcar (lambda (key) 256 | ;; FIXME: it'll raise an error if the index name is too long 257 | (list (format nil "unique_~A_~{~A~^_~}" 258 | table-name 259 | (unlispify-keys (ensure-list key))) 260 | :unique-key t 261 | :primary-key nil 262 | :columns (ensure-list (unlispify-keys key)))) 263 | unique-keys))) 264 | ;; Ignore :keys when using SQLite3 265 | (unless (eq driver-type :sqlite3) 266 | (let ((keys (map-all-superclasses (lambda (class) 267 | (slot-value class 'keys)) 268 | class))) 269 | (when keys 270 | (mapcar (lambda (key) 271 | ;; FIXME: it'll raise an error if the index name is too long 272 | (list (format nil "key_~A_~{~A~^_~}" 273 | table-name 274 | (unlispify-keys (ensure-list key))) 275 | :unique-key nil 276 | :primary-key nil 277 | :columns (ensure-list (unlispify-keys key)))) 278 | keys))))))))) 279 | 280 | (defun find-parent-column (table slot) 281 | (let* ((name (c2mop:slot-definition-name slot)) 282 | (fifo-queue-of-classes (list table)) 283 | (last fifo-queue-of-classes)) 284 | ;; runs a breadth-first search 285 | (labels ((enqueue-last (thing) 286 | (setf (cdr last) (list thing) 287 | last (cdr last))) 288 | (rec () 289 | (let ((class (first fifo-queue-of-classes))) 290 | (when class 291 | (or (and (slot-exists-p class 'parent-column-map) 292 | (gethash name (slot-value class 'parent-column-map))) 293 | (progn 294 | (map nil #'enqueue-last (c2mop:class-direct-superclasses class)) 295 | (pop fifo-queue-of-classes) 296 | (rec))))))) 297 | (rec)))) 298 | 299 | (defun find-child-columns (table slot) 300 | (let (results) 301 | (map-all-superclasses 302 | (lambda (class) 303 | (when (slot-exists-p class 'parent-column-map) 304 | (maphash (lambda (child parent) 305 | (when (eq parent (c2mop:slot-definition-name slot)) 306 | (push child results))) 307 | (slot-value class 'parent-column-map)))) 308 | table) 309 | results)) 310 | -------------------------------------------------------------------------------- /src/core/connection.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.connection 3 | (:use #:cl 4 | #:mito.error) 5 | (:import-from #:dbi 6 | #:connect 7 | #:disconnect 8 | #:connection-driver-type) 9 | (:export #:*connection* 10 | #:driver-type 11 | #:connection-database-name 12 | #:connected-p 13 | #:check-connected 14 | #:connect-toplevel 15 | #:disconnect-toplevel 16 | #:connection-quote-character 17 | #:with-quote-char)) 18 | (in-package :mito.connection) 19 | 20 | (defvar *connection* nil) 21 | 22 | (defun connection-database-name (&optional conn) 23 | "Return the name of the current connection, or the one given as argument." 24 | (dbi:connection-database-name (or conn *connection*))) 25 | 26 | (defun connected-p () 27 | (not (null *connection*))) 28 | 29 | (defun check-connected () 30 | (or (connected-p) 31 | (error 'connection-not-established))) 32 | 33 | (defun driver-type (&optional conn) 34 | (unless conn 35 | (check-connected) 36 | (setf conn *connection*)) 37 | (dbi:connection-driver-type conn)) 38 | 39 | (defun connect-toplevel (driver-name &rest args &key database-name &allow-other-keys) 40 | (declare (ignore database-name)) 41 | (setf *connection* (apply #'dbi:connect driver-name args))) 42 | 43 | (defun disconnect-toplevel () 44 | (when (connected-p) 45 | (dbi:disconnect *connection*) 46 | (setf *connection* nil))) 47 | 48 | (defun connection-quote-character (conn) 49 | (ecase (connection-driver-type conn) 50 | (:mysql #\`) 51 | (:postgres #\") 52 | (:sqlite3 #\"))) 53 | 54 | (defmacro with-quote-char (&body body) 55 | `(let ((sxql:*quote-character* (or sxql:*quote-character* 56 | (connection-quote-character *connection*)))) 57 | ,@body)) 58 | -------------------------------------------------------------------------------- /src/core/conversion.lisp: -------------------------------------------------------------------------------- 1 | (defpackage mito.conversion 2 | (:use :cl) 3 | (:import-from :local-time) 4 | (:export :convert-for-driver-type)) 5 | (in-package :mito.conversion) 6 | 7 | (defvar *db-datetime-format* 8 | '((:year 4) #\- (:month 2) #\- (:day 2) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:usec 6) :gmt-offset-or-z)) 9 | 10 | (defvar *db-datetime-format-without-timezone* 11 | '((:year 4) #\- (:month 2) #\- (:day 2) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:usec 6))) 12 | 13 | (defvar *db-date-format* 14 | '((:year 4) #\- (:month 2) #\- (:day 2))) 15 | 16 | (defgeneric convert-for-driver-type (driver-type col-type value) 17 | (:method (driver-type col-type value) 18 | (declare (ignore driver-type col-type)) 19 | value) 20 | (:method (driver-type col-type (value string)) 21 | (declare (ignore driver-type col-type)) 22 | value) 23 | (:method ((driver-type (eql :mysql)) (col-type (eql :boolean)) value) 24 | (ecase value 25 | (t 1) 26 | ('nil 0))) 27 | (:method ((driver-type (eql :mysql)) (col-type (eql :datetime)) (value local-time:timestamp)) 28 | (local-time:format-timestring nil value 29 | :format *db-datetime-format-without-timezone*)) 30 | (:method (driver-type (col-type (eql :datetime)) (value local-time:timestamp)) 31 | (local-time:format-timestring nil value 32 | :format *db-datetime-format* 33 | :timezone local-time:+gmt-zone+)) 34 | (:method (driver-type (col-type (eql :date)) (value local-time:timestamp)) 35 | (local-time:format-timestring nil value 36 | :format *db-date-format*)) 37 | (:method (driver-type (col-type (eql :timestamp)) value) 38 | (convert-for-driver-type driver-type :datetime value)) 39 | (:method (driver-type (col-type (eql :timestamptz)) value) 40 | (convert-for-driver-type driver-type :datetime value)) 41 | (:method ((driver-type (eql :sqlite3)) (col-type (eql :boolean)) value) 42 | (ecase value 43 | (t 1) 44 | ('nil 0))) 45 | (:method ((driver-type (eql :postgres)) (col-type (eql :boolean)) value) 46 | (ecase value 47 | (t "true") 48 | ('nil "false")))) 49 | -------------------------------------------------------------------------------- /src/core/dao/column.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.dao.column 3 | (:use #:cl 4 | #:mito.util) 5 | (:import-from #:mito.class.column 6 | #:table-column-class 7 | #:table-column-type) 8 | (:import-from #:local-time) 9 | (:import-from #:cl-ppcre) 10 | (:export #:dao-table-column-class 11 | #:dao-table-column-inflate 12 | #:dao-table-column-deflate 13 | #:inflate-for-col-type 14 | #:deflate-for-col-type)) 15 | (in-package :mito.dao.column) 16 | 17 | (defparameter *conc-name* nil) 18 | 19 | (defclass dao-table-column-class (table-column-class) 20 | ((inflate :type (or function null) 21 | :initarg :inflate) 22 | (deflate :type (or function null) 23 | :initarg :deflate))) 24 | 25 | (defmethod initialize-instance :around ((object dao-table-column-class) &rest rest-initargs 26 | &key name readers writers inflate deflate 27 | &allow-other-keys) 28 | (when *conc-name* 29 | (let ((accessor (intern 30 | (format nil "~:@(~A~A~)" *conc-name* name) 31 | *package*))) 32 | (unless readers 33 | (pushnew accessor readers) 34 | (setf (getf rest-initargs :readers) readers)) 35 | (unless writers 36 | (pushnew `(setf ,accessor) writers) 37 | (setf (getf rest-initargs :writers) writers)))) 38 | 39 | (when inflate 40 | (setf (getf rest-initargs :inflate) (eval inflate))) 41 | (when deflate 42 | (setf (getf rest-initargs :deflate) (eval deflate))) 43 | 44 | (apply #'call-next-method object rest-initargs)) 45 | 46 | (defgeneric dao-table-column-inflate (column value) 47 | (:method ((column dao-table-column-class) value) 48 | (if (slot-boundp column 'inflate) 49 | (funcall (slot-value column 'inflate) value) 50 | (inflate-for-col-type 51 | (table-column-type column) 52 | value)))) 53 | 54 | (defgeneric dao-table-column-deflate (column value) 55 | (:method ((column dao-table-column-class) value) 56 | (if (slot-boundp column 'deflate) 57 | (funcall (slot-value column 'deflate) value) 58 | (deflate-for-col-type 59 | (table-column-type column) 60 | value)))) 61 | 62 | (defgeneric inflate-for-col-type (col-type value) 63 | (:method (col-type value) 64 | (declare (ignore col-type)) 65 | (identity value)) 66 | (:method ((col-type cons) value) 67 | (inflate-for-col-type (first col-type) value)) 68 | (:method ((col-type (eql :datetime)) value) 69 | (etypecase value 70 | (integer 71 | (local-time:universal-to-timestamp value)) 72 | (float 73 | (multiple-value-bind (sec nsec) 74 | (truncate value) 75 | (local-time:universal-to-timestamp sec :nsec (* (round (* nsec 1000000)) 1000)))) 76 | (string 77 | (local-time:parse-timestring value :date-time-separator #\Space)) 78 | (null nil))) 79 | (:method ((col-type (eql :date)) value) 80 | (etypecase value 81 | (integer 82 | (local-time:universal-to-timestamp value)) 83 | (string 84 | (ppcre:register-groups-bind ((#'parse-integer year month day)) 85 | ("^(\\d{4})-(\\d{2})-(\\d{2})$" value) 86 | (local-time:universal-to-timestamp 87 | (encode-universal-time 0 0 0 day month year)))) 88 | (null nil))) 89 | (:method ((col-type (eql :timestamp)) value) 90 | (inflate-for-col-type :datetime value)) 91 | (:method ((col-type (eql :timestamptz)) value) 92 | (inflate-for-col-type :datetime value)) 93 | (:method ((col-type (eql :time)) value) 94 | (flet ((v (key) 95 | (second (assoc key value)))) 96 | (if (consp value) 97 | (format nil "~2,'0D:~2,'0D:~2,'0D~:[.~3,'0D~;~]" 98 | (v :hours) (v :minutes) (v :seconds) (= (v :microseconds) 0) (v :microseconds)) 99 | value))) 100 | (:method ((col-type (eql :boolean)) value) 101 | (cond 102 | ;; MySQL & SQLite3 103 | ((typep value 'integer) 104 | (not (= value 0))) 105 | ;; PostgreSQL 106 | ((typep value 'boolean) 107 | value) 108 | (t 109 | (error "Unexpected value for boolean column: ~S" value))))) 110 | 111 | (defvar *db-datetime-format* 112 | '((:year 4) #\- (:month 2) #\- (:day 2) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:usec 6) :gmt-offset-or-z)) 113 | 114 | (defvar *db-datetime-format-with-out-timezone* 115 | '((:year 4) #\- (:month 2) #\- (:day 2) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:usec 6))) 116 | 117 | (defvar *db-date-format* 118 | '((:year 4) #\- (:month 2) #\- (:day 2))) 119 | 120 | (defgeneric deflate-for-col-type (col-type value) 121 | (:method (col-type value) 122 | (declare (ignore col-type)) 123 | (identity value)) 124 | (:method ((col-type cons) value) 125 | (deflate-for-col-type (first col-type) value)) 126 | (:method ((col-type (eql :datetime)) value) 127 | (etypecase value 128 | (integer 129 | (local-time:universal-to-timestamp value)) 130 | (local-time:timestamp 131 | value) 132 | (string value) 133 | (null nil))) 134 | (:method ((col-type (eql :date)) value) 135 | (etypecase value 136 | (local-time:timestamp 137 | value) 138 | (string value) 139 | (null nil))) 140 | (:method ((col-type (eql :timestamp)) value) 141 | (deflate-for-col-type :datetime value)) 142 | (:method ((col-type (eql :timestamptz)) value) 143 | (deflate-for-col-type :datetime value))) 144 | -------------------------------------------------------------------------------- /src/core/dao/mixin.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.dao.mixin 3 | (:use #:cl 4 | #:mito.util) 5 | (:import-from #:mito.class.column 6 | #:table-column-type) 7 | (:import-from #:mito.class.table 8 | #:table-direct-column-slots) 9 | (:import-from #:mito.class 10 | #:table-class 11 | #:table-name 12 | #:table-column-slots 13 | #:find-child-columns 14 | #:find-slot-by-name 15 | #:table-column-name 16 | #:table-column-references-column) 17 | (:import-from #:mito.dao.column 18 | #:dao-table-column-class 19 | #:dao-table-column-inflate 20 | #:*conc-name*) 21 | (:import-from #:uuid 22 | #:make-v4-uuid) 23 | (:import-from #:sxql) 24 | (:import-from #:alexandria 25 | #:if-let) 26 | (:export #:dao-table-mixin 27 | #:dao-class 28 | #:dao-synced 29 | #:dao-cache 30 | #:make-dao-instance 31 | #:define-accessor 32 | 33 | #:serial-pk-mixin 34 | #:uuid-pk-mixin 35 | #:record-timestamps-mixin 36 | 37 | #:object-id 38 | #:object= 39 | #:object-created-at 40 | #:object-updated-at)) 41 | (in-package :mito.dao.mixin) 42 | 43 | (defclass dao-class () 44 | ((synced :type boolean 45 | :initform nil 46 | :accessor dao-synced) 47 | (cache :type (or hash-table null) 48 | :initform nil 49 | :accessor %dao-cache))) 50 | 51 | (defun dao-cache (dao key) 52 | (if-let (cache-obj (%dao-cache dao)) 53 | (gethash key cache-obj) 54 | (values nil nil))) 55 | 56 | (defun (setf dao-cache) (value dao key) 57 | (let ((cache-obj (or (%dao-cache dao) 58 | (setf (%dao-cache dao) 59 | (make-hash-table :test 'eq))))) 60 | (setf (gethash key cache-obj) value))) 61 | 62 | (defmacro define-accessor (name (dao class) &body body) 63 | `(defun ,name (,dao) 64 | (check-type ,dao ,class) 65 | (or (dao-cache ,dao ',name) 66 | (setf (dao-cache ,dao ',name) 67 | (progn ,@body))))) 68 | 69 | (defclass dao-table-mixin (table-class) ()) 70 | 71 | (defmethod c2mop:direct-slot-definition-class ((class dao-table-mixin) &key) 72 | 'dao-table-column-class) 73 | 74 | (defgeneric make-dao-instance (class &rest initargs) 75 | (:method ((class-name symbol) &rest initargs) 76 | (apply #'make-dao-instance 77 | (find-class class-name) 78 | initargs)) 79 | 80 | (:method ((class table-class) &rest initargs) 81 | (let* ((list (loop for (k v) on initargs by #'cddr 82 | for column = (find-if (lambda (initargs) 83 | (find k initargs :test #'eq)) 84 | (table-column-slots class) 85 | :key #'c2mop:slot-definition-initargs) 86 | if column 87 | append (list k 88 | (dao-table-column-inflate column v)) 89 | else 90 | append (list k v))) 91 | (obj (allocate-instance class)) 92 | (obj (apply #'shared-initialize obj nil list))) 93 | (setf (dao-synced obj) t) 94 | obj))) 95 | 96 | (defun make-relational-reader-method (func-name class slot-name rel-class-name) 97 | (let ((generic-function 98 | (ensure-generic-function func-name :lambda-list '(object)))) 99 | (add-method 100 | generic-function 101 | (make-instance 'standard-method 102 | :lambda-list '(object) 103 | :qualifiers () 104 | :specializers (list class) 105 | :function 106 | (let ((calledp nil)) 107 | (lambda (object &rest ignore) 108 | (declare (ignore ignore)) 109 | ;; I don't know why but SBCL pass a CONS of the instance instead of the instance itself. 110 | (when (consp object) 111 | (setf object (first object))) 112 | (if (and (slot-boundp object slot-name) 113 | (or calledp 114 | (not (null (slot-value object slot-name))))) 115 | (slot-value object slot-name) 116 | (let* ((child-columns (find-child-columns class 117 | (find-slot-by-name class slot-name))) 118 | (foreign-object 119 | (and (every (lambda (slot-name) 120 | (and (slot-boundp object slot-name) 121 | (slot-value object slot-name))) 122 | child-columns) 123 | (let ((result 124 | (first 125 | (mito.db:retrieve-by-sql 126 | (sxql:select :* 127 | (sxql:from (sxql:make-sql-symbol (table-name (find-class rel-class-name)))) 128 | (sxql:where 129 | `(:and 130 | ,@(mapcar (lambda (slot-name) 131 | `(:= ,(sxql:make-sql-symbol 132 | (table-column-name 133 | (table-column-references-column 134 | (find-slot-by-name class slot-name)))) 135 | ,(slot-value object slot-name))) 136 | child-columns))) 137 | (sxql:limit 1)))))) 138 | (and result 139 | (apply #'make-dao-instance rel-class-name result)))))) 140 | (setf calledp t 141 | (slot-value object slot-name) foreign-object))))))))) 142 | 143 | (defun add-relational-readers (class) 144 | (loop for column in (table-direct-column-slots class) 145 | for col-type = (table-column-type column) 146 | when (and (symbolp col-type) 147 | (not (null col-type)) 148 | (not (keywordp col-type))) 149 | do (let ((name (c2mop:slot-definition-name column))) 150 | (dolist (reader (c2mop:slot-definition-readers column)) 151 | (make-relational-reader-method reader class name col-type))))) 152 | 153 | (defmethod initialize-instance :around ((class dao-table-mixin) &rest initargs 154 | &key conc-name &allow-other-keys) 155 | (let ((*conc-name* (first conc-name))) 156 | (let ((class (apply #'call-next-method class initargs))) 157 | (add-relational-readers class) 158 | class))) 159 | 160 | (defmethod reinitialize-instance :around ((class dao-table-mixin) &rest initargs 161 | &key conc-name &allow-other-keys) 162 | (let ((*conc-name* (first conc-name))) 163 | (let ((class (apply #'call-next-method class initargs))) 164 | (add-relational-readers class) 165 | class))) 166 | 167 | (defclass serial-pk-mixin () 168 | ((id :col-type :bigserial 169 | :initarg :id 170 | :primary-key t 171 | :accessor %object-id)) 172 | (:metaclass dao-table-mixin)) 173 | 174 | (defun generate-uuid () 175 | (string-downcase (print-object (uuid:make-v4-uuid) nil))) 176 | 177 | (defclass uuid-pk-mixin () 178 | ((id :col-type (:varchar 36) 179 | :initform (generate-uuid) 180 | :accessor %object-uuid 181 | :primary-key t)) 182 | (:metaclass dao-table-mixin)) 183 | 184 | (defgeneric object-id (object) 185 | (:method ((object serial-pk-mixin)) 186 | (if (slot-boundp object 'id) 187 | (%object-id object) 188 | nil)) 189 | (:method ((object uuid-pk-mixin)) 190 | (if (slot-boundp object 'id) 191 | (%object-uuid object) 192 | nil))) 193 | 194 | (defgeneric (setf object-id) (id object) 195 | (:method (id (object serial-pk-mixin)) 196 | (setf (%object-id object) id)) 197 | (:method (id (object uuid-pk-mixin)) 198 | (setf (%object-uuid object) id))) 199 | 200 | (defgeneric object= (object1 object2) 201 | (:method (object1 object2) 202 | (and (eq (class-of object1) (class-of object2)) 203 | (eql (object-id object1) (object-id object2))))) 204 | 205 | (defclass record-timestamps-mixin () 206 | ((created-at :col-type (or :timestamptz :null) 207 | :initarg :created-at 208 | :accessor object-created-at) 209 | (updated-at :col-type (or :timestamptz :null) 210 | :initarg :updated-at 211 | :accessor object-updated-at)) 212 | (:metaclass dao-table-mixin)) 213 | -------------------------------------------------------------------------------- /src/core/dao/table.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.dao.table 3 | (:use #:cl 4 | #:mito.util 5 | #:mito.error) 6 | (:import-from #:mito.dao.view 7 | #:table-definition) 8 | (:import-from #:mito.connection 9 | #:driver-type) 10 | (:import-from #:mito.class 11 | #:table-class 12 | #:table-column-type 13 | #:table-column-slots 14 | #:table-primary-key 15 | #:create-table-sxql) 16 | (:import-from #:mito.dao.column 17 | #:dao-table-column-class 18 | #:dao-table-column-inflate) 19 | (:import-from #:mito.dao.mixin 20 | #:dao-table-mixin 21 | #:dao-class 22 | #:serial-pk-mixin 23 | #:uuid-pk-mixin 24 | #:record-timestamps-mixin 25 | #:add-relational-readers) 26 | (:export #:dao-table-class 27 | #:depending-table-classes)) 28 | (in-package :mito.dao.table) 29 | 30 | (defclass dao-table-class (dao-table-mixin) 31 | ((auto-pk :initarg :auto-pk 32 | :initform '(:serial)) 33 | (record-timestamps :initarg :record-timestamps 34 | :initform '(t)))) 35 | 36 | (defmethod c2mop:direct-slot-definition-class ((class dao-table-class) &key) 37 | 'dao-table-column-class) 38 | 39 | (defun initargs-enables-auto-pk (initargs) 40 | (first (or (getf initargs :auto-pk) '(:serial)))) 41 | 42 | (defun initargs-enables-record-timestamps (initargs) 43 | (first (or (getf initargs :record-timestamps) '(t)))) 44 | 45 | (defun initargs-contains-primary-key (initargs) 46 | (or (getf initargs :primary-key) 47 | (find-if (lambda (slot) 48 | (getf slot :primary-key)) 49 | (getf initargs :direct-slots)))) 50 | 51 | (defun depending-table-classes (class) 52 | (let ((class-name (class-name class))) 53 | (delete-duplicates 54 | (loop for column in (table-column-slots class) 55 | if (mito.class.column:table-column-references column) 56 | append (let ((col-type (table-column-type column))) 57 | (if (eq col-type class-name) 58 | nil 59 | (list (find-class col-type))))) 60 | :from-end t 61 | :test #'eq))) 62 | 63 | (defun append-record-timestamp-mixin-to-direct-superclasses-if-needed (initargs direct-superclasses) 64 | (when (and (initargs-enables-record-timestamps initargs) 65 | (not (contains-class-or-subclasses 'record-timestamps-mixin direct-superclasses))) 66 | (setf (getf initargs :direct-superclasses) 67 | (append (getf initargs :direct-superclasses) 68 | (list (find-class 'record-timestamps-mixin)))))) 69 | 70 | (defun append-auto-pk-class-to-direct-superclasses-if-needed (initargs direct-superclasses) 71 | (let ((auto-pk-type (initargs-enables-auto-pk initargs))) 72 | (when auto-pk-type 73 | (let ((auto-pk-class (ecase auto-pk-type 74 | (:serial 'serial-pk-mixin) 75 | (:uuid 'uuid-pk-mixin) 76 | ('t 'serial-pk-mixin)))) 77 | (when (and (not (initargs-contains-primary-key initargs)) 78 | (not (contains-class-or-subclasses auto-pk-class direct-superclasses)) 79 | (not (mapcan #'table-primary-key 80 | (remove-if-not (lambda (c) 81 | (typep c 'table-class)) 82 | direct-superclasses)))) 83 | (push (find-class auto-pk-class) (getf initargs :direct-superclasses))))))) 84 | 85 | (defmethod initialize-instance :around ((class dao-table-class) &rest initargs 86 | &key direct-superclasses &allow-other-keys) 87 | (append-record-timestamp-mixin-to-direct-superclasses-if-needed initargs direct-superclasses) 88 | (unless (contains-class-or-subclasses 'dao-class direct-superclasses) 89 | (push (find-class 'dao-class) (getf initargs :direct-superclasses))) 90 | (append-auto-pk-class-to-direct-superclasses-if-needed initargs direct-superclasses) 91 | (apply #'call-next-method class initargs)) 92 | 93 | (defmethod reinitialize-instance :around ((class dao-table-class) &rest initargs 94 | &key direct-superclasses &allow-other-keys) 95 | (append-record-timestamp-mixin-to-direct-superclasses-if-needed initargs direct-superclasses) 96 | (append-auto-pk-class-to-direct-superclasses-if-needed initargs direct-superclasses) 97 | (apply #'call-next-method class initargs)) 98 | 99 | (defmethod c2mop:ensure-class-using-class :around ((class dao-table-class) name &rest keys 100 | &key direct-superclasses &allow-other-keys) 101 | (unless (contains-class-or-subclasses 'dao-class direct-superclasses) 102 | (setf (getf keys :direct-superclasses) 103 | (cons (find-class 'dao-class) direct-superclasses))) 104 | (apply #'call-next-method class name keys)) 105 | 106 | (defmethod table-definition ((class dao-table-class) &key if-not-exists &allow-other-keys) 107 | (create-table-sxql class (driver-type) 108 | :if-not-exists if-not-exists)) 109 | -------------------------------------------------------------------------------- /src/core/dao/view.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:mito.dao.view 3 | (:use #:cl) 4 | (:import-from #:mito.class 5 | #:table-class 6 | #:table-name) 7 | (:import-from #:mito.dao.column 8 | #:dao-table-column-class) 9 | (:import-from #:sxql) 10 | (:export #:dao-table-view 11 | #:dao-table-view-as-query 12 | #:table-definition)) 13 | (in-package #:mito.dao.view) 14 | 15 | (defclass dao-table-view (table-class) 16 | ((as :initarg :as 17 | :initform (error ":as query is required for dao-table-view") 18 | :reader dao-table-view-as-query))) 19 | 20 | (defmethod c2mop:direct-slot-definition-class ((class dao-table-view) &key) 21 | 'dao-table-column-class) 22 | 23 | (defstruct (create-view (:include sxql.sql-type:sql-statement (sxql.sql-type:name "CREATE VIEW")) 24 | (:constructor make-create-view (view-name &key or-replace as))) 25 | view-name 26 | or-replace 27 | as) 28 | 29 | (defmethod sxql:make-statement ((statement-name (eql :create-view)) &rest args) 30 | (destructuring-bind (view-name &key or-replace as) 31 | args 32 | (make-create-view (sxql.operator:detect-and-convert view-name) :or-replace or-replace :as as))) 33 | 34 | (defmethod sxql:yield ((statement create-view)) 35 | (sxql.sql-type:with-yield-binds 36 | (format nil "CREATE~:[~; OR REPLACE~] VIEW ~A AS ~A" 37 | (create-view-or-replace statement) 38 | (sxql:yield (create-view-view-name statement)) 39 | (create-view-as statement)))) 40 | 41 | (defstruct (drop-view (:include sxql.sql-type:sql-statement (sxql.sql-type:name "DROP VIEW")) 42 | (:constructor make-drop-view (view-name &key if-exists))) 43 | view-name 44 | if-exists) 45 | 46 | (defmethod sxql:make-statement ((statement-name (eql :drop-view)) &rest args) 47 | (destructuring-bind (view-name &key if-exists) 48 | args 49 | (make-drop-view (typecase view-name 50 | (sxql.sql-type:sql-symbol view-name) 51 | (string (sxql:make-sql-symbol view-name)) 52 | (otherwise (sxql.operator:detect-and-convert view-name))) 53 | :if-exists if-exists))) 54 | 55 | (defmethod sxql:yield ((statement drop-view)) 56 | (sxql.sql-type:with-yield-binds 57 | (format nil "DROP~:[~; IF EXISTS~] VIEW ~A" 58 | (drop-view-if-exists statement) 59 | (sxql:yield (drop-view-view-name statement))))) 60 | 61 | (defgeneric table-definition (class &key if-not-exists or-replace) 62 | (:method ((class symbol) &rest args &key if-not-exists or-replace) 63 | (declare (ignore if-not-exists or-replace)) 64 | (apply #'table-definition (find-class class) args)) 65 | (:method ((class dao-table-view) &key or-replace &allow-other-keys) 66 | (list 67 | (sxql:make-statement :create-view 68 | (sxql:make-sql-symbol (table-name class)) 69 | :or-replace or-replace 70 | :as (first (dao-table-view-as-query class)))))) 71 | -------------------------------------------------------------------------------- /src/core/db.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.db 3 | (:use #:cl) 4 | (:import-from #:mito.connection 5 | #:*connection* 6 | #:with-quote-char 7 | #:connection-quote-character 8 | #:check-connected) 9 | (:import-from #:mito.logger 10 | #:with-trace-sql) 11 | (:import-from #:mito.util 12 | #:with-prepared-query 13 | #:execute-with-retry) 14 | (:import-from #:dbi 15 | #:connection-driver-type 16 | #:do-sql 17 | #:execute 18 | #:fetch-all) 19 | (:import-from #:dbi.driver 20 | #:query-row-count) 21 | (:import-from #:sxql 22 | #:*quote-character* 23 | #:yield) 24 | (:import-from #:sxql.sql-type 25 | #:sql-statement 26 | #:conjunctive-op) 27 | (:import-from #:sxql.composed-statement 28 | #:composed-statement) 29 | (:export #:*use-prepare-cached* 30 | #:last-insert-id 31 | #:table-indices 32 | #:column-definitions 33 | #:table-view-query 34 | #:table-exists-p 35 | #:execute-sql 36 | #:retrieve-by-sql 37 | #:acquire-advisory-lock 38 | #:release-advisory-lock)) 39 | (in-package :mito.db) 40 | 41 | (defvar *use-prepare-cached* nil 42 | "EXPERIMENTAL FEATURE: If this is T, Mito uses DBI:PREPARE-CACHED 43 | to retrieve/execute SQLs instead of DBI:PREPARE. The default value is NIL. 44 | Note that DBI:PREPARE-CACHED is added CL-DBI v0.9.5.") 45 | 46 | (defun last-insert-id (conn table-name serial-key-name) 47 | (check-type serial-key-name string) 48 | (let ((sxql:*quote-character* (connection-quote-character conn))) 49 | (ecase (dbi:connection-driver-type conn) 50 | (:mysql (mito.db.mysql:last-insert-id conn table-name serial-key-name)) 51 | (:postgres (mito.db.postgres:last-insert-id conn table-name serial-key-name)) 52 | (:sqlite3 (mito.db.sqlite3:last-insert-id conn table-name))))) 53 | 54 | (defun table-indices (conn table-name) 55 | (sort 56 | (funcall 57 | (ecase (dbi:connection-driver-type conn) 58 | (:mysql #'mito.db.mysql:table-indices) 59 | (:postgres #'mito.db.postgres:table-indices) 60 | (:sqlite3 #'mito.db.sqlite3:table-indices)) 61 | conn table-name) 62 | (lambda (a b) 63 | (cond 64 | ((getf a :primary-key) 65 | (not (getf b :primary-key))) 66 | ((getf b :primary-key) nil) 67 | ((getf a :unique-key) 68 | (or (not (getf b :unique-key)) 69 | (string< (prin1-to-string a) (prin1-to-string b)))) 70 | (t 71 | (string< (prin1-to-string a) (prin1-to-string b))))) 72 | :key #'cdr)) 73 | 74 | (defun column-definitions (conn table-name) 75 | (funcall 76 | (ecase (dbi:connection-driver-type conn) 77 | (:mysql #'mito.db.mysql:column-definitions) 78 | (:postgres #'mito.db.postgres:column-definitions) 79 | (:sqlite3 #'mito.db.sqlite3:column-definitions)) 80 | conn table-name)) 81 | 82 | (defun table-view-query (conn table-name) 83 | (funcall 84 | (ecase (dbi:connection-driver-type conn) 85 | (:mysql #'mito.db.mysql:table-view-query) 86 | (:postgres #'mito.db.postgres:table-view-query)) 87 | conn table-name)) 88 | 89 | (defun table-exists-p (conn table-name) 90 | (check-type table-name string) 91 | (multiple-value-bind (sql binds) 92 | (sxql:yield 93 | (ecase (dbi:connection-driver-type conn) 94 | (:mysql 95 | (sxql:select :1 96 | (sxql:from :information_schema.tables) 97 | (sxql:where (:and (:= :table_schema (dbi:connection-database-name conn)) 98 | (:= :table_name table-name))) 99 | (sxql:limit 1))) 100 | (:postgres 101 | (sxql:select :1 102 | (sxql:from :information_schema.tables) 103 | (sxql:where (:and (:= :table_schema "public") 104 | (:= :table_name table-name))) 105 | (sxql:limit 1))) 106 | (:sqlite3 107 | (sxql:select :1 108 | (sxql:from :sqlite_master) 109 | (sxql:where (:and (:= :name table-name) 110 | (:= :type "table"))) 111 | (sxql:limit 1))))) 112 | (with-prepared-query query (conn sql) 113 | (and (dbi:fetch-all 114 | (execute-with-retry query binds) 115 | :format :plist) 116 | t)))) 117 | 118 | (defun sxql-to-sql (sql) 119 | (with-quote-char (sxql:yield sql))) 120 | 121 | (defun ensure-sql (sql) 122 | (etypecase sql 123 | (string sql) 124 | ((or sql-statement 125 | composed-statement 126 | ;; For UNION [ALL] 127 | conjunctive-op) 128 | (sxql-to-sql sql)))) 129 | 130 | (defgeneric execute-sql (sql &optional binds) 131 | (:method ((sql string) &optional binds) 132 | (check-connected) 133 | (with-trace-sql 134 | (with-prepared-query query (*connection* sql :use-prepare-cached *use-prepare-cached*) 135 | (setf query (execute-with-retry query binds)) 136 | (query-row-count query)))) 137 | (:method ((sql sql-statement) &optional binds) 138 | (declare (ignore binds)) 139 | (multiple-value-bind (sql binds) 140 | (sxql-to-sql sql) 141 | (execute-sql sql binds)))) 142 | 143 | (defun lispified-fields (query) 144 | (mapcar (lambda (field) 145 | (declare (type string field)) 146 | (intern (map 'string 147 | (lambda (char) 148 | (declare (type character char)) 149 | (if (char= char #\_) 150 | #\- 151 | (char-upcase char))) 152 | field) 153 | :keyword)) 154 | (dbi:query-fields query))) 155 | 156 | (defun convert-nulls-to-nils (value) 157 | (typecase value 158 | ((eql :null) 159 | nil) 160 | (cons 161 | (mapcar #'convert-nulls-to-nils value)) 162 | ((and (not string) vector) 163 | (map (type-of value) #'convert-nulls-to-nils value)) 164 | (otherwise 165 | value))) 166 | 167 | (defvar *plist-row-lispify* nil) 168 | 169 | (defun retrieve-from-query (query format) 170 | (ecase format 171 | (:plist 172 | (let ((rows (dbi:fetch-all query :format :values)) 173 | (fields (if *plist-row-lispify* 174 | (lispified-fields query) 175 | (mapcar (lambda (field) 176 | (intern field :keyword)) 177 | (dbi:query-fields query))))) 178 | (loop for row in rows 179 | collect 180 | (loop for field in fields 181 | for v in row 182 | collect field 183 | collect (convert-nulls-to-nils v))))) 184 | (:alist 185 | (let ((rows (dbi:fetch-all query :format :values))) 186 | (mapcar (lambda (row) 187 | (loop for v in row 188 | for field in (dbi:query-fields query) 189 | collect (cons field 190 | (convert-nulls-to-nils v)))) 191 | rows))) 192 | (:hash-table 193 | (let ((rows (dbi:fetch-all query :format :hash-table))) 194 | (maphash (lambda (k v) 195 | (setf (gethash k rows) 196 | (convert-nulls-to-nils v))) 197 | rows) 198 | rows)) 199 | (:values 200 | (convert-nulls-to-nils 201 | (dbi:fetch-all query :format :values))))) 202 | 203 | (defgeneric retrieve-by-sql (sql &key binds format lispify) 204 | (:method ((sql string) &key binds format (lispify nil lispify-specified)) 205 | (check-connected) 206 | (with-prepared-query query (*connection* sql :use-prepare-cached *use-prepare-cached*) 207 | (let* ((query (with-trace-sql 208 | (execute-with-retry query binds))) 209 | (format (or format :plist)) 210 | (*plist-row-lispify* 211 | (if lispify-specified 212 | lispify 213 | (case format 214 | (:plist t) 215 | (otherwise nil))))) 216 | (retrieve-from-query query format)))) 217 | (:method (sql &rest args &key binds &allow-other-keys) 218 | (assert (null binds)) 219 | (multiple-value-bind (sql binds) 220 | (ensure-sql sql) 221 | (apply #'retrieve-by-sql sql :binds binds args)))) 222 | 223 | (defun acquire-advisory-lock (conn id) 224 | (funcall 225 | (case (dbi:connection-driver-type conn) 226 | (:postgres #'mito.db.postgres:acquire-advisory-lock) 227 | (:mysql #'mito.db.mysql:acquire-advisory-lock) 228 | (otherwise 229 | ;; Just ignore 230 | (lambda (&rest args) (declare (ignore args))))) 231 | conn id)) 232 | 233 | (defun release-advisory-lock (conn id) 234 | (funcall 235 | (case (dbi:connection-driver-type conn) 236 | (:postgres #'mito.db.postgres:release-advisory-lock) 237 | (:mysql #'mito.db.mysql:release-advisory-lock) 238 | (otherwise 239 | ;; Just ignore 240 | (lambda (&rest args) (declare (ignore args))))) 241 | conn id)) 242 | -------------------------------------------------------------------------------- /src/core/db/mysql.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.db.mysql 3 | (:use #:cl 4 | #:mito.util 5 | #:sxql) 6 | (:import-from #:mito.connection 7 | #:connection-quote-character) 8 | (:import-from #:dbi 9 | #:execute 10 | #:fetch 11 | #:fetch-all 12 | #:connection-database-name) 13 | (:import-from #:alexandria 14 | #:delete-from-plist) 15 | (:export #:last-insert-id 16 | #:table-indices 17 | #:column-definitions 18 | #:table-view-query 19 | #:acquire-advisory-lock 20 | #:release-advisory-lock)) 21 | (in-package :mito.db.mysql) 22 | 23 | (defun last-insert-id (conn table-name serial-key-name) 24 | (declare (ignore table-name serial-key-name)) 25 | (with-prepared-query query (conn "SELECT last_insert_id() AS last_insert_id") 26 | (or (first (dbi:fetch (dbi:execute query) :format :values)) 27 | 0))) 28 | 29 | (defun table-indices (conn table-name) 30 | (with-prepared-query query 31 | (conn (format nil 32 | ;; Ensure the field names are downcased 33 | "SELECT index_name AS index_name, column_name AS column_name, non_unique AS non_unique 34 | FROM information_schema.statistics 35 | WHERE table_schema = '~A' 36 | AND table_name = '~A' 37 | ORDER BY index_name, seq_in_index" 38 | (connection-database-name conn) 39 | table-name)) 40 | (let ((results (dbi:execute query))) 41 | (mapcar (lambda (plist) 42 | (destructuring-bind (index-name &rest column-list) plist 43 | (list index-name 44 | :unique-key (or (string= index-name "PRIMARY") 45 | (= (getf (first column-list) :|non_unique|) 0)) 46 | :primary-key (string= index-name "PRIMARY") 47 | :columns (mapcar (lambda (column) 48 | (getf column :|column_name|)) 49 | column-list)))) 50 | (group-by-plist (dbi:fetch-all results :format :plist) 51 | :key :|index_name| 52 | :test #'string=))))) 53 | 54 | (defun ensure-string (val) 55 | (etypecase val 56 | ((vector (unsigned-byte 8)) 57 | (map 'string #'code-char val)) 58 | (string val))) 59 | 60 | (defun column-definitions (conn table-name) 61 | (let ((sql (format nil "SHOW FULL FIELDS FROM `~A`" table-name))) 62 | (with-prepared-query query (conn sql) 63 | (let* ((results (dbi:execute query)) 64 | (definitions 65 | (loop for column = (dbi:fetch results :format :plist) 66 | while column 67 | collect (list (getf column :|Field|) 68 | :type (ensure-string (getf column :|Type|)) 69 | :auto-increment (string= (getf column :|Extra|) "auto_increment") 70 | :primary-key (string= (getf column :|Key|) "PRI") 71 | :not-null (or (string= (getf column :|Key|) "PRI") 72 | (string= (getf column :|Null|) "NO")) 73 | :default (getf column :|Default|))))) 74 | ;; Set :primary-key NIL if there's a composite primary key. 75 | (if (< 1 (count-if (lambda (def) 76 | (getf (cdr def) :primary-key)) 77 | definitions)) 78 | (mapc (lambda (def) 79 | (setf (getf (cdr def) :primary-key) nil)) 80 | definitions) 81 | definitions))))) 82 | 83 | (defun table-view-query (conn table-name) 84 | (with-prepared-query query (conn (format nil "SHOW CREATE VIEW `~A`" table-name)) 85 | (let ((results (dbi:execute query))) 86 | (getf (first (dbi:fetch-all results :format :plist)) :|Create View|)))) 87 | 88 | (defun acquire-advisory-lock (conn id) 89 | ;; MySQL accepts -1 to wait forever, while MariaDB doesn't. 90 | ;; Give it a large enough number to simulate it. 91 | (dbi:do-sql conn "SELECT GET_LOCK(?, 0xffffff)" (list id)) 92 | (values)) 93 | 94 | (defun release-advisory-lock (conn id) 95 | (dbi:do-sql conn "SELECT RELEASE_LOCK(?)" (list id)) 96 | (values)) 97 | -------------------------------------------------------------------------------- /src/core/db/postgres.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.db.postgres 3 | (:use #:cl 4 | #:sxql 5 | #:mito.util) 6 | (:import-from #:dbi 7 | #:execute 8 | #:fetch 9 | #:fetch-all) 10 | (:export #:last-insert-id 11 | #:column-definitions 12 | #:table-indices 13 | #:table-view-query 14 | #:acquire-advisory-lock 15 | #:release-advisory-lock)) 16 | (in-package :mito.db.postgres) 17 | 18 | (defun last-insert-id (conn table-name serial-key-name) 19 | (handler-case 20 | (with-prepared-query query 21 | (conn (format nil 22 | "SELECT currval(pg_get_serial_sequence('~A', '~A')) AS last_insert_id" 23 | table-name 24 | serial-key-name)) 25 | (or (first (dbi:fetch (dbi:execute query) :format :values)) 0)) 26 | (dbi: () 0))) 27 | 28 | (defun get-serial-keys (conn table-name) 29 | (remove-if-not 30 | (lambda (column) 31 | (with-prepared-query query 32 | (conn (format nil "SELECT pg_get_serial_sequence('~A', '~A')" table-name column)) 33 | (let ((seq (first (dbi:fetch 34 | (dbi:execute query) 35 | :format :values)))) 36 | (if (eq seq :null) 37 | nil 38 | seq)))) 39 | (with-prepared-query query 40 | (conn (format nil "SELECT column_name FROM information_schema.columns WHERE table_name = '~A'" 41 | table-name)) 42 | (mapcar #'car (dbi:fetch-all (dbi:execute query) :format :values))))) 43 | 44 | (defun column-definitions (conn table-name) 45 | (let* ((serial-keys (get-serial-keys conn table-name)) 46 | (sql (format nil "SELECT~ 47 | ~% f.attname AS name,~ 48 | ~% pg_catalog.format_type(f.atttypid,f.atttypmod) AS type,~ 49 | ~% f.attnotnull AS notnull,~ 50 | ~% CASE~ 51 | ~% WHEN p.contype = 'p' THEN true~ 52 | ~% ELSE false~ 53 | ~% END AS primary,~ 54 | ~% CASE~ 55 | ~% WHEN f.atthasdef THEN pg_get_expr(d.adbin, d.adrelid)~ 56 | ~% END AS default~ 57 | ~%FROM pg_attribute f~ 58 | ~% JOIN pg_class c ON c.oid = f.attrelid~ 59 | ~% LEFT JOIN pg_constraint p ON p.conrelid = f.attrelid AND f.attnum = ANY (p.conkey)~ 60 | ~% LEFT JOIN pg_attrdef d ON d.adrelid = c.oid~ 61 | ~%WHERE c.relkind = 'r'::char~ 62 | ~% AND c.relname = '~A'~ 63 | ~% AND f.attnum > 0~ 64 | ~% AND f.atttypid != 0~ 65 | ~%ORDER BY f.attnum, p.contype" table-name))) 66 | (with-prepared-query query (conn sql) 67 | (let ((definitions 68 | (delete-duplicates 69 | (loop with results = (dbi:execute query) 70 | for column = (dbi:fetch results :format :plist) 71 | while column 72 | collect (let ((auto-increment (not (null (member (getf column :|name|) 73 | serial-keys 74 | :test #'string=))))) 75 | (list (getf column :|name|) 76 | :type (getf column :|type|) 77 | :auto-increment auto-increment 78 | :primary-key (getf column :|primary|) 79 | :not-null (or (getf column :|primary|) 80 | (getf column :|notnull|)) 81 | :default (if (or auto-increment 82 | (eq :null (getf column :|default|))) 83 | nil 84 | (getf column :|default|))))) 85 | :key #'car 86 | :test #'string= 87 | :from-end t))) 88 | ;; Set :primary-key NIL if there's a composite primary key. 89 | (if (< 1 (count-if (lambda (def) 90 | (getf (cdr def) :primary-key)) 91 | definitions)) 92 | (mapc (lambda (def) 93 | (setf (getf (cdr def) :primary-key) nil)) 94 | definitions) 95 | definitions))))) 96 | 97 | (defun table-indices (conn table-name) 98 | (with-prepared-query query (conn (format nil 99 | "SELECT~ 100 | ~% i.relname AS index_name,~ 101 | ~% ARRAY(~ 102 | ~% SELECT pg_get_indexdef(ix.indexrelid, k + 1, TRUE)~ 103 | ~% FROM~ 104 | ~% generate_subscripts(ix.indkey, 1) AS k~ 105 | ~% ORDER BY k~ 106 | ~% ) AS column_names,~ 107 | ~% ix.indisunique AS is_unique,~ 108 | ~% ix.indisprimary AS is_primary~ 109 | ~%FROM~ 110 | ~% pg_class t,~ 111 | ~% pg_class i,~ 112 | ~% pg_index ix,~ 113 | ~% pg_attribute a~ 114 | ~%WHERE~ 115 | ~% t.oid = ix.indrelid~ 116 | ~% and i.oid = ix.indexrelid~ 117 | ~% and a.attrelid = t.oid~ 118 | ~% and a.attnum = ANY(ix.indkey)~ 119 | ~% and t.relkind = 'r'~ 120 | ~% and t.relname = '~A'~ 121 | ~%GROUP BY~ 122 | ~% t.relname, i.relname, ix.indexrelid, ix.indkey, ix.indisunique, ix.indisprimary~ 123 | ~%ORDER BY t.relname, i.relname" table-name)) 124 | (let ((results (dbi:execute query))) 125 | (mapcar #'(lambda (plist) 126 | (destructuring-bind (&key |index_name| |column_names| |is_unique| |is_primary|) plist 127 | (list |index_name| 128 | :unique-key |is_unique| 129 | :primary-key |is_primary| 130 | :columns (map 'list (lambda (column) 131 | (if (and (char= (aref column 0) #\") 132 | (char= (aref column (1- (length column))) #\")) 133 | (read-from-string column) 134 | column)) 135 | |column_names|)))) 136 | (dbi:fetch-all results :format :plist))))) 137 | 138 | (defun table-view-query (conn table-name) 139 | (with-prepared-query query (conn (format nil "SELECT pg_get_viewdef('~A'::regclass) AS def" table-name)) 140 | (let ((results (dbi:execute query))) 141 | (string-right-trim 142 | '(#\Space #\;) 143 | (string-left-trim 144 | '(#\Space) 145 | (first (first (dbi:fetch-all results :format :values)))))))) 146 | 147 | (defun acquire-advisory-lock (conn id) 148 | (dbi:do-sql conn "SELECT pg_advisory_lock(?)" (list id)) 149 | (values)) 150 | 151 | (defun release-advisory-lock (conn id) 152 | (dbi:do-sql conn "SELECT pg_advisory_unlock(?)" (list id)) 153 | (values)) 154 | -------------------------------------------------------------------------------- /src/core/db/sqlite3.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.db.sqlite3 3 | (:use #:cl 4 | #:mito.util 5 | #:sxql) 6 | (:import-from #:dbi 7 | #:execute 8 | #:fetch 9 | #:fetch-all) 10 | (:export #:last-insert-id 11 | #:column-definitions 12 | #:table-indices)) 13 | (in-package :mito.db.sqlite3) 14 | 15 | (defun table-info (conn table-name) 16 | (let* ((sql (format nil "PRAGMA table_info(\"~A\")" table-name))) 17 | (with-prepared-query query (conn sql) 18 | (or (dbi:fetch-all (dbi:execute query) :format :plist) 19 | (error "Table \"~A\" doesn't exist." table-name))))) 20 | 21 | (defun last-insert-id (conn table-name) 22 | (declare (ignore table-name)) 23 | (with-prepared-query query (conn "SELECT last_insert_rowid() AS last_insert_id") 24 | (or (first (dbi:fetch 25 | (dbi:execute query) 26 | :format :values)) 27 | 0))) 28 | 29 | (defun autoincrement-p (conn table-name) 30 | (with-prepared-query query (conn (format nil 31 | "SELECT 1 FROM sqlite_master WHERE tbl_name = '~A' AND sql LIKE '%AUTOINCREMENT%'" 32 | table-name)) 33 | (and (first (dbi:fetch (dbi:execute query) :format :values)) 34 | t))) 35 | 36 | (defun column-definitions (conn table-name) 37 | (labels ((column-primary-key-p (column) 38 | (not (= (getf column :|pk|) 0))) 39 | (column-auto-increment-p (column) 40 | (and (column-primary-key-p column) 41 | (string-equal (getf column :|type|) "INTEGER") 42 | (autoincrement-p conn table-name)))) 43 | (loop with pk-count = 0 44 | for column in (table-info conn table-name) 45 | if (column-primary-key-p column) 46 | do (incf pk-count) 47 | collect (list (getf column :|name|) 48 | :type (getf column :|type|) 49 | :auto-increment (column-auto-increment-p column) 50 | :primary-key (column-primary-key-p column) 51 | :not-null (or (column-primary-key-p column) 52 | (not (= (getf column :|notnull|) 0))) 53 | :default (let ((default (getf column :|dflt_value|))) 54 | (if (stringp default) 55 | (read-from-string default) 56 | default))) 57 | into definitions 58 | finally 59 | (return 60 | (if (< 1 pk-count) 61 | (mapc (lambda (def) 62 | (setf (getf (cdr def) :auto-increment) nil) 63 | (setf (getf (cdr def) :primary-key) nil)) 64 | definitions) 65 | definitions))))) 66 | 67 | (defun table-primary-keys (conn table-name) 68 | (mapcar #'(lambda (column) (getf column :|name|)) 69 | (remove-if (lambda (column) 70 | (= (getf column :|pk|) 0)) 71 | (table-info conn table-name)))) 72 | 73 | (defun table-indices (conn table-name) 74 | (let ((primary-keys (table-primary-keys conn table-name))) 75 | (with-prepared-query query (conn (format nil "PRAGMA index_list(\"~A\")" table-name)) 76 | (append 77 | (loop with results = (dbi:execute query) 78 | for index = (dbi:fetch results :format :plist) 79 | while index 80 | collect 81 | (let* ((columns (mapcar 82 | (lambda (info) (getf info :|name|)) 83 | (dbi:fetch-all 84 | (dbi:execute (dbi:prepare conn (format nil "PRAGMA index_info(\"~A\")" 85 | (getf index :|name|)))) 86 | :format :plist))) 87 | (unique-key (= (getf index :|unique|) 1)) 88 | (primary-key (and unique-key 89 | primary-keys 90 | (equal columns primary-keys)))) 91 | (when primary-key 92 | (setf primary-keys nil)) 93 | (list (getf index :|name|) 94 | :unique-key unique-key 95 | :primary-key primary-key 96 | :columns columns))) 97 | (if primary-keys 98 | (list (list "PRIMARY" :unique-key t :primary-key t :columns primary-keys)) 99 | nil))))) 100 | -------------------------------------------------------------------------------- /src/core/error.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.error 3 | (:use #:cl) 4 | (:export #:mito-error 5 | #:invalid-definition 6 | #:col-type-required 7 | #:no-primary-keys 8 | #:connection-not-established)) 9 | (in-package :mito.error) 10 | 11 | (define-condition mito-error (error) ()) 12 | 13 | (define-condition invalid-definition (mito-error) ()) 14 | 15 | (define-condition col-type-required (invalid-definition) 16 | ((slot :initarg :slot)) 17 | (:report (lambda (condition stream) 18 | (with-slots (slot) condition 19 | (format stream 20 | ":col-type is missing at ~S." 21 | (c2mop:slot-definition-name slot)))))) 22 | 23 | (define-condition no-primary-keys (mito-error) 24 | ((table :initarg :table)) 25 | (:report (lambda (condition stream) 26 | (with-slots (table) condition 27 | (format stream 28 | "No primary keys in ~S." 29 | table))))) 30 | 31 | (define-condition connection-not-established (mito-error) () 32 | (:report (lambda (condition stream) 33 | (declare (ignore condition)) 34 | (format stream 35 | "Connection is not established yet.")))) 36 | -------------------------------------------------------------------------------- /src/core/logger.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.logger 3 | (:use #:cl) 4 | (:import-from #:dbi 5 | #:*sql-execution-hooks*) 6 | (:import-from #:alexandria 7 | #:delete-from-plist) 8 | (:export #:*mito-logger-stream* 9 | #:*mito-migration-logger-stream* 10 | #:*trace-sql-hooks* 11 | #:mito-sql-logger 12 | #:with-trace-sql 13 | #:with-sql-logging)) 14 | (in-package :mito.logger) 15 | 16 | (defvar *mito-logger-stream* nil) 17 | 18 | (defvar *mito-migration-logger-stream* (make-synonym-stream '*standard-output*) 19 | "Stream to output sql generated during migrations.") 20 | 21 | (defun get-prev-stack () 22 | (labels ((normalize-call (call) 23 | (typecase call 24 | (symbol call) 25 | (cons 26 | (case (first call) 27 | (:method (second call)) 28 | ((lambda flet labels) nil) 29 | (otherwise (second call)))))) 30 | #+sbcl 31 | (sbcl-package-p (package) 32 | (let ((name (package-name package))) 33 | (eql (mismatch "SB-" name) 3))) 34 | (system-call-p (call) 35 | (when call 36 | (let ((package (symbol-package call))) 37 | (and package 38 | (or #+sbcl (sbcl-package-p package) 39 | (find (package-name package) 40 | '(:common-lisp :mito.logger :mito.db :mito.dao :mito.util :dbi.logger :dbi.driver) 41 | :test #'string=)))))) 42 | (users-call-p (call) 43 | (and call 44 | (or (not (symbolp call)) 45 | (not (system-call-p call)))))) 46 | 47 | #+sbcl 48 | (do ((frame (sb-di:frame-down (sb-di:top-frame)) 49 | (sb-di:frame-down frame))) 50 | ((null frame)) 51 | (multiple-value-bind (call) 52 | (sb-debug::frame-call frame) 53 | (let ((call (normalize-call call))) 54 | (when (users-call-p call) 55 | (return call))))) 56 | #+ccl 57 | (block nil 58 | (let ((i 0)) 59 | (ccl:map-call-frames 60 | (lambda (pointer context) 61 | (let* ((function (ccl:frame-function pointer context)) 62 | (call (normalize-call (or (ccl:function-name function) function)))) 63 | (when (users-call-p call) 64 | (return call))) 65 | (incf i)) 66 | :start-frame-number 1))) 67 | #-(or sbcl ccl) 68 | (loop with prev-stack = nil 69 | for stack in (dissect:stack) 70 | for call = (let ((call (dissect:call stack))) 71 | (normalize-call call)) 72 | when (users-call-p call) 73 | do (return call)))) 74 | 75 | (defun mito-sql-logger (sql params row-count took-usec prev-stack) 76 | (when *mito-logger-stream* 77 | (format *mito-logger-stream* 78 | "~&~<;; ~@;~A (~{~S~^, ~}) ~@[[~D row~:P]~]~@[ (~Dms)~]~:[~;~:* | ~S~]~:>~%" 79 | (list sql 80 | (mapcar (lambda (param) 81 | (if (typep param '(simple-array (unsigned-byte 8) (*))) 82 | (map 'string #'code-char param) 83 | param)) 84 | params) 85 | row-count 86 | took-usec 87 | prev-stack)))) 88 | 89 | (defvar *trace-sql-hooks* (list #'mito-sql-logger)) 90 | 91 | (defun trace-sql (sql params row-count took-usec) 92 | (when *trace-sql-hooks* 93 | (let ((prev-stack (get-prev-stack))) 94 | (dolist (hook *trace-sql-hooks*) 95 | (funcall hook sql params row-count took-usec prev-stack))))) 96 | 97 | (defmacro with-trace-sql (&body body) 98 | `(let ((dbi:*sql-execution-hooks* (cons #'trace-sql 99 | dbi:*sql-execution-hooks*))) 100 | ,@body)) 101 | 102 | (defmacro with-sql-logging (&body body) 103 | `(let ((*mito-logger-stream* *mito-migration-logger-stream*)) 104 | (with-trace-sql ,@body))) 105 | -------------------------------------------------------------------------------- /src/core/type.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.type 3 | (:use #:cl) 4 | (:import-from #:mito.db 5 | #:column-definitions) 6 | (:import-from #:dbi 7 | #:do-sql) 8 | (:import-from #:sxql 9 | #:yield 10 | #:drop-table 11 | #:create-table) 12 | (:export #:parse-dbtype 13 | #:get-column-real-type)) 14 | (in-package :mito.type) 15 | 16 | (defun parse-type-vars (vars) 17 | (flet ((db-string-p (var) 18 | (and (/= 0 (length var)) 19 | (or (and (char= (aref var 0) #\') 20 | (char= (aref var (1- (length var))) #\')) 21 | (and (char= (aref var 0) #\") 22 | (char= (aref var (1- (length var))) #\"))))) 23 | (db-number-p (var) 24 | (ppcre:scan "\\d+(?:\\.\\d*)?" var))) 25 | (loop for var in (ppcre:split "\\s*,\\s*" vars) 26 | if (db-string-p var) 27 | collect (subseq var 1 (1- (length var))) 28 | else if (db-number-p var) 29 | collect (read-from-string var) 30 | else 31 | collect var))) 32 | 33 | (defun parse-dbtype (dbtype) 34 | (flet ((parse (type) 35 | (let ((match 36 | (nth-value 1 37 | (ppcre:scan-to-strings "^([^(]+?)(?:\\s*\\(([^)]+)\\))?(?:\\s+(.+))?$" type)))) 38 | (unless match 39 | (error "Invalid DB type: ~A" type)) 40 | (values (aref match 0) 41 | (parse-type-vars (aref match 1)) 42 | (ppcre:split "\\s+" (aref match 2)))))) 43 | (multiple-value-bind (name vars rest) 44 | (parse dbtype) 45 | `(,(string-upcase name) 46 | ,vars 47 | ,@rest)))) 48 | 49 | (defvar *real-type-cache* (make-hash-table :test 'equalp)) 50 | 51 | (defun get-column-real-type (conn name) 52 | (symbol-macrolet ((real-type 53 | (gethash (list (dbi:connection-driver-type conn) name) 54 | *real-type-cache*))) 55 | (or real-type 56 | (setf real-type 57 | (progn 58 | (let ((*error-output* (make-broadcast-stream))) 59 | (dbi:do-sql conn 60 | (sxql:yield 61 | (sxql:drop-table :get_column_real_type :if-exists t)))) 62 | (dbi:do-sql conn 63 | (sxql:yield 64 | (sxql:create-table :get_column_real_type 65 | ((test :type name))))) 66 | (getf (cdr (assoc "test" (mito.db:column-definitions conn "get_column_real_type") 67 | :test #'string=)) 68 | :type)))))) 69 | -------------------------------------------------------------------------------- /src/core/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.util 3 | (:use #:cl) 4 | (:import-from #:closer-mop) 5 | (:import-from #:dbi 6 | #:prepare 7 | #:free-query-resources) 8 | (:export #:group-by-plist 9 | #:list-diff 10 | #:lispify 11 | #:unlispify 12 | #:symbol-name-literally 13 | #:contains-class-or-subclasses 14 | #:ensure-class 15 | #:with-prepared-query 16 | #:execute-with-retry)) 17 | (in-package :mito.util) 18 | 19 | (defun group-by-plist (plists &key key (test #'equal)) 20 | (loop with map = (list) 21 | for plist in plists 22 | for found = (assoc (getf plist key) map :test test) 23 | if found 24 | do (push plist (cdr found)) 25 | else 26 | do (setf map (cons (cons (getf plist key) 27 | (list plist)) 28 | map)) 29 | finally 30 | (return 31 | (mapc (lambda (record) 32 | (rplacd record 33 | (nreverse (cdr record)))) 34 | (nreverse map))))) 35 | 36 | (defun %list-diff (a b &key (key #'identity) (test #'string=)) 37 | (cond 38 | ((null a) 39 | (values nil nil b)) 40 | ((null b) 41 | (values nil a nil)) 42 | ((funcall test 43 | (funcall key (car a)) 44 | (funcall key (car b))) 45 | (multiple-value-bind (intersection sub-a sub-b) 46 | (%list-diff (cdr a) (cdr b) 47 | :key key 48 | :test test) 49 | (values (cons (car a) intersection) 50 | sub-a 51 | sub-b))) 52 | (T (let ((pos (position (funcall key (car a)) (cdr b) 53 | :key key 54 | :test test))) 55 | (if pos 56 | (multiple-value-bind (intersection sub-a sub-b) 57 | (%list-diff (cdr a) (nthcdr (+ 2 pos) b) 58 | :key key 59 | :test test) 60 | (values (cons (car a) intersection) 61 | sub-a 62 | (append (subseq b 0 (1+ pos)) sub-b))) 63 | (multiple-value-bind (intersection sub-a sub-b) 64 | (%list-diff (cdr a) b 65 | :key key 66 | :test test) 67 | (values intersection 68 | (cons (car a) sub-a) 69 | sub-b))))))) 70 | 71 | (defun list-diff (a b &key sort-key sort-key-a sort-key-b (sort-fn #'string<) (key #'identity) (test #'string=)) 72 | "Compute differences two lists. 73 | Note this can be applied for a list of string-designators." 74 | (%list-diff (sort (copy-list a) sort-fn :key (or sort-key-a sort-key key)) 75 | (sort (copy-list b) sort-fn :key (or sort-key-b sort-key key)) 76 | :key key 77 | :test test)) 78 | 79 | (defun escaped-symbol-p (symbol) 80 | (declare (optimize speed) 81 | (type symbol symbol)) 82 | (not (string= symbol (string-upcase symbol)))) 83 | 84 | (defun symbol-name-literally (symbol) 85 | (if (escaped-symbol-p symbol) 86 | (symbol-name symbol) 87 | (string-downcase symbol))) 88 | 89 | (defun lispify (object) 90 | (etypecase object 91 | (symbol (intern (lispify (string-upcase object)) 92 | (symbol-package object))) 93 | (string (substitute #\- #\_ object)))) 94 | 95 | (defun unlispify (object) 96 | (etypecase object 97 | (symbol (intern (unlispify (symbol-name-literally object)) 98 | (symbol-package object))) 99 | (string (substitute #\_ #\- object)))) 100 | 101 | (defun contains-class-or-subclasses (class target-classes) 102 | (let ((class (if (typep class 'class) 103 | class 104 | (find-class class)))) 105 | (find-if (lambda (target-class) 106 | (let ((target-class (if (typep target-class 'class) 107 | target-class 108 | (find-class target-class nil)))) 109 | (and target-class 110 | (or (eq target-class class) 111 | (subtypep target-class class))))) 112 | target-classes))) 113 | 114 | (defun ensure-class (class-or-class-name) 115 | (etypecase class-or-class-name 116 | (symbol (find-class class-or-class-name)) 117 | (standard-class class-or-class-name))) 118 | 119 | (defun call-with-prepared-query (conn sql thunk &key use-prepare-cached) 120 | (let ((query (funcall (if use-prepare-cached 121 | 'dbi::prepare-cached 122 | #'dbi:prepare) 123 | conn sql))) 124 | (unwind-protect 125 | (funcall thunk query) 126 | (unless use-prepare-cached 127 | (dbi:free-query-resources query))))) 128 | 129 | (defmacro with-prepared-query (query (conn sql &key use-prepare-cached) &body body) 130 | `(call-with-prepared-query ,conn ,sql (lambda (,query) ,@body) :use-prepare-cached ,use-prepare-cached)) 131 | 132 | (defun obsolete-prepared-statement-p (conn e) 133 | (and (eq (dbi:connection-driver-type conn) :postgres) 134 | (equal (dbi:database-error-code e) "0A000") 135 | (equal (dbi:database-error-message e) "cached plan must not change result type"))) 136 | 137 | (defun execute-with-retry (query binds) 138 | "Same as DBI:EXECUTE except will recreate a prepared statement when getting DBI:DBI-DATABASE-ERROR." 139 | (let ((retried nil)) 140 | (tagbody retry 141 | (handler-bind ((dbi:dbi-database-error 142 | (lambda (e) 143 | (let ((conn (dbi:query-connection query))) 144 | (when (and (not retried) 145 | (dbi:query-cached-p query) 146 | (obsolete-prepared-statement-p conn e)) 147 | (dbi:free-query-resources query) 148 | (setf query (dbi:prepare-cached conn 149 | (dbi:query-sql query))) 150 | (setf retried t) 151 | (go retry)))))) 152 | (return-from execute-with-retry (dbi:execute query binds)))))) 153 | -------------------------------------------------------------------------------- /src/middleware.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito.middleware 2 | (:nicknames #:lack.middleware.mito) 3 | (:use #:cl) 4 | (:import-from #:mito.core 5 | #:*connection*) 6 | (:import-from #:dbi 7 | #:connect-cached) 8 | (:export #:*lack-middleware-mito*)) 9 | (in-package #:mito.middleware) 10 | 11 | (defparameter *lack-middleware-mito* 12 | (lambda (app db-config) 13 | (if db-config 14 | (lambda (env) 15 | (let ((mito.core:*connection* (apply #'dbi:connect-cached db-config))) 16 | (funcall app env))) 17 | app))) 18 | -------------------------------------------------------------------------------- /src/migration.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:mito.migration 2 | (:use #:cl) 3 | (:use-reexport #:mito.migration.table 4 | #:mito.migration.versions)) 5 | (in-package :mito.migration) 6 | -------------------------------------------------------------------------------- /src/migration/sql-parse.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito.migration.sql-parse 2 | (:use #:cl 3 | #:esrap) 4 | (:shadow #:space) 5 | (:export #:parse-statements)) 6 | (in-package #:mito.migration.sql-parse) 7 | 8 | (defrule end (~ "END")) 9 | 10 | (defrule begin-end (and (~ "BEGIN") (+ (or quoted-symbol quoted-string begin-end case-end if-end (not end))) end) 11 | (:destructure (b content e) 12 | (format nil "~A~{~A~}~A" b content e))) 13 | 14 | (defrule case-end (and (~ "CASE") (+ (or quoted-symbol quoted-string begin-end case-end if-end (not end))) end) 15 | (:destructure (b content e) 16 | (format nil "~A~{~A~}~A" b content e))) 17 | 18 | (defrule if-end (and (~ "IF") (+ (or quoted-symbol quoted-string begin-end case-end if-end (not (~ "END IF")))) (~ "END IF")) 19 | (:destructure (b content e) 20 | (format nil "~A~{~A~}~A" b content e))) 21 | 22 | (defrule quoted-symbol (and #\" (+ (or (not #\") (and #\\ #\"))) #\") 23 | (:destructure (d1 content d2) 24 | (declare (ignore d1 d2)) 25 | (format nil "\"~{~A~}\"" content))) 26 | 27 | (defrule pg-dollar-sign (or (and #\$ (* (not space)) #\$) 28 | (and #\$ #\$))) 29 | 30 | (defrule quoted-string (or (and #\' 31 | (+ (or (not #\') 32 | (and #\\ #\'))) 33 | #\') 34 | (and pg-dollar-sign 35 | (+ (or (not #\$) 36 | (and #\\ #\$))) 37 | pg-dollar-sign)) 38 | (:text t)) 39 | 40 | (defrule space (or #\Space #\Newline #\Return #\Tab)) 41 | 42 | (defrule statement (and (* space) 43 | (+ (or quoted-symbol quoted-string begin-end (not #\;))) (? #\;) 44 | (* space)) 45 | (:destructure (s1 content semicolon s2) 46 | (declare (ignore s1 s2)) 47 | (format nil "~{~A~}~:[~;;~]" content semicolon))) 48 | 49 | (defun parse-statements (content) 50 | (values (esrap:parse '(* statement) content))) 51 | -------------------------------------------------------------------------------- /src/migration/sxql.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.migration.sxql 3 | (:use #:cl) 4 | (:import-from #:sxql 5 | #:yield) 6 | (:import-from #:sxql.sql-type 7 | #:sql-clause 8 | #:expression-clause 9 | #:sql-statement 10 | #:name 11 | #:with-yield-binds) 12 | (:import-from #:sxql.operator 13 | #:detect-and-convert) 14 | (:import-from #:sxql.clause 15 | #:make-clause) 16 | (:import-from #:sxql.statement 17 | #:make-statement) 18 | (:documentation "Extansions of SxQL for Mito.Migration")) 19 | (in-package :mito.migration.sxql) 20 | 21 | (defstruct (set-default (:include expression-clause (name "SET DEFAULT")) 22 | (:constructor make-set-default (expression)))) 23 | (defmethod make-clause ((clause-name (eql :set-default)) &rest args) 24 | (make-set-default (detect-and-convert (first args)))) 25 | 26 | (defstruct (create-sequence (:include sql-statement (name "CREATE SEQUENCE")) 27 | (:constructor make-create-sequence (sequence-name))) 28 | sequence-name) 29 | (defmethod yield ((statement create-sequence)) 30 | (with-yield-binds 31 | (format nil "CREATE SEQUENCE ~A" (yield (create-sequence-sequence-name statement))))) 32 | (defmethod make-statement ((statement-name (eql :create-sequence)) &rest args) 33 | (make-create-sequence (detect-and-convert (first args)))) 34 | 35 | (defstruct (drop-sequence (:include sql-statement (name "DROP SEQUENCE")) 36 | (:constructor make-drop-sequence 37 | (sequence-name &key if-exists))) 38 | sequence-name 39 | if-exists) 40 | (defmethod yield ((statement drop-sequence)) 41 | (with-yield-binds 42 | (format nil "DROP SEQUENCE~:[~; IF EXISTS~] ~A" 43 | (drop-sequence-if-exists statement) 44 | (yield (drop-sequence-sequence-name statement))))) 45 | (defmethod make-statement ((statement-name (eql :drop-sequence)) &rest args) 46 | (destructuring-bind (sequence-name &key if-exists) 47 | args 48 | (make-drop-sequence (detect-and-convert sequence-name) 49 | :if-exists if-exists))) 50 | -------------------------------------------------------------------------------- /src/migration/util.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito.migration.util 2 | (:use #:cl) 3 | (:import-from #:chipz 4 | #:make-crc32 5 | #:update-crc32 6 | #:produce-crc32) 7 | (:export #:generate-advisory-lock-id)) 8 | (in-package #:mito.migration.util) 9 | 10 | (defun ascii-string-to-octets (value) 11 | (check-type value string) 12 | (map '(simple-array (unsigned-byte 8) (*)) #'char-code value)) 13 | 14 | (defun crc32 (string) 15 | (let ((state (make-crc32)) 16 | (octets (ascii-string-to-octets string))) 17 | (update-crc32 state octets 0 (length octets)) 18 | (produce-crc32 state))) 19 | 20 | (defvar +migrator-salt+ 2069753430) 21 | (defun generate-advisory-lock-id (database-name) 22 | (* +migrator-salt+ (crc32 database-name))) 23 | -------------------------------------------------------------------------------- /src/migration/versions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage mito.migration.versions 3 | (:use #:cl 4 | #:sxql) 5 | (:import-from #:mito.migration.table 6 | #:migration-expressions) 7 | (:import-from #:mito.migration.sql-parse 8 | #:parse-statements) 9 | (:import-from #:mito.migration.util 10 | #:generate-advisory-lock-id) 11 | (:import-from #:mito.dao 12 | #:dao-class 13 | #:dao-table-class 14 | #:dao-table-view 15 | #:table-definition) 16 | (:import-from #:mito.connection 17 | #:*connection* 18 | #:check-connected 19 | #:with-quote-char) 20 | (:import-from #:mito.class 21 | #:table-name) 22 | (:import-from #:mito.db 23 | #:execute-sql 24 | #:retrieve-by-sql 25 | #:table-exists-p 26 | #:acquire-advisory-lock 27 | #:release-advisory-lock 28 | #:column-definitions) 29 | (:import-from #:mito.type 30 | #:get-column-real-type) 31 | (:import-from #:cl-dbi 32 | #:connection-driver-type) 33 | (:import-from #:alexandria 34 | #:with-gensyms 35 | #:once-only 36 | #:set-equal) 37 | (:export #:*migration-version-format* 38 | #:all-migration-expressions 39 | #:current-migration-version 40 | #:update-migration-version 41 | #:generate-migrations 42 | #:migrate 43 | #:migration-status)) 44 | (in-package :mito.migration.versions) 45 | 46 | (defvar *migration-version-format* :time) 47 | 48 | (defun schema-migrations-table-definition () 49 | (let ((driver-type (connection-driver-type *connection*))) 50 | (sxql:create-table (:schema_migrations :if-not-exists t) 51 | ((version :type :bigint 52 | :primary-key t) 53 | (applied_at :type (if (eq driver-type :postgres) 54 | :timestamptz 55 | :timestamp) 56 | :not-null t 57 | :default (sxql.sql-type:make-sql-keyword "CURRENT_TIMESTAMP")) 58 | (dirty :type :boolean 59 | :not-null t 60 | :default (if (eq driver-type :postgres) 61 | (sxql.sql-type:make-sql-keyword "false") 62 | 0)))))) 63 | 64 | (defun initialize-migrations-table () 65 | (check-connected) 66 | (let ((*error-output* (make-broadcast-stream)) 67 | (sxql:*use-placeholder* nil) 68 | (driver-type (connection-driver-type *connection*))) 69 | (dbi:with-transaction *connection* 70 | (if (table-exists-p *connection* "schema_migrations") 71 | (let ((db-columns (column-definitions *connection* "schema_migrations"))) 72 | (unless 73 | (and (set-equal (mapcar 'first db-columns) 74 | '("version" "applied_at" "dirty") 75 | :test 'equal) 76 | (equal (getf (cdr (find "version" db-columns :test 'equal :key 'first)) :type) 77 | (get-column-real-type *connection* :bigint))) 78 | (execute-sql 79 | (sxql:alter-table :schema_migrations 80 | (sxql:rename-to :schema_migrations_backup))) 81 | (execute-sql (schema-migrations-table-definition)) 82 | (cond 83 | ((or (not (find "applied_at" db-columns :test 'equal :key 'first)) 84 | (eql 0 (caar (retrieve-by-sql "SELECT COUNT(*) FROM schema_migrations_backup WHERE applied_at IS NOT NULL" :format :values)))) 85 | (execute-sql 86 | (format nil 87 | "INSERT INTO schema_migrations (version) ~ 88 | SELECT CAST(version AS ~A) ~ 89 | FROM schema_migrations_backup ~ 90 | ORDER BY version DESC LIMIT 1" 91 | (case driver-type 92 | (:mysql "UNSIGNED") 93 | (otherwise "BIGINT"))))) 94 | (t 95 | (execute-sql 96 | (format nil 97 | "INSERT INTO schema_migrations (version, applied_at, dirty) ~ 98 | SELECT CAST(version AS ~A), applied_at, CAST(~:[0~;dirty~] AS ~A) ~ 99 | FROM schema_migrations_backup ~ 100 | WHERE applied_at IS NOT NULL" 101 | (case driver-type 102 | (:mysql "UNSIGNED") 103 | (otherwise "BIGINT")) 104 | (find "dirty" db-columns :test 'equal :key 'first) 105 | (case driver-type 106 | (:mysql "UNSIGNED") 107 | (otherwise "BOOLEAN")))))) 108 | (execute-sql 109 | (sxql:drop-table :schema_migrations_backup)))) 110 | (execute-sql (schema-migrations-table-definition)))))) 111 | 112 | (defun all-dao-classes () 113 | (let ((hash (make-hash-table :test 'eq))) 114 | (labels ((new-class-p (class) 115 | (if (gethash class hash) 116 | nil 117 | (setf (gethash class hash) t))) 118 | (depending-classes (class) 119 | (let ((dep-classes (mito.dao:depending-table-classes class))) 120 | (loop for c in dep-classes 121 | if (new-class-p c) 122 | append (depending-classes c) 123 | and collect c))) 124 | (class-subclasses (class) 125 | (let ((subclasses (c2mop:class-direct-subclasses class))) 126 | (loop for class in subclasses 127 | append (cons class (class-subclasses class)))))) 128 | (remove-if-not (lambda (class) 129 | (or (typep class 'dao-table-class) 130 | (typep class 'dao-table-view))) 131 | (mapcan (lambda (class) 132 | (append (depending-classes class) 133 | (if (new-class-p class) 134 | (list class) 135 | '()))) 136 | (class-subclasses (find-class 'dao-class))))))) 137 | 138 | (defun all-migration-expressions () 139 | (check-connected) 140 | (loop for class in (all-dao-classes) 141 | for (up down) = (if (table-exists-p *connection* (table-name class)) 142 | (multiple-value-list (migration-expressions class)) 143 | (list (table-definition class) 144 | (list (sxql:drop-table (sxql:make-sql-symbol (table-name class)))))) 145 | append up into up-expressions 146 | append down into down-expressions 147 | finally (return 148 | (values up-expressions 149 | down-expressions)))) 150 | 151 | (defun current-migration-version () 152 | (initialize-migrations-table) 153 | (let ((row (first (retrieve-by-sql 154 | (sxql:select (:version) 155 | (sxql:from :schema_migrations) 156 | (sxql:order-by (:desc :version)) 157 | (sxql:limit 1)))))) 158 | (getf row :version))) 159 | 160 | (defun update-migration-version (version) 161 | (execute-sql 162 | (sxql:insert-into :schema_migrations 163 | (sxql:set= :version version)))) 164 | 165 | (defun generate-time-version () 166 | (multiple-value-bind (sec min hour day mon year) 167 | (decode-universal-time (get-universal-time) 0) 168 | (parse-integer 169 | (format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D~2,'0D" 170 | year mon day hour min sec)))) 171 | 172 | (defun generate-version (&optional current-version) 173 | (ecase *migration-version-format* 174 | (:time (generate-time-version)) 175 | (:serial 176 | (if current-version 177 | (1+ current-version) 178 | 1)))) 179 | 180 | (defun generate-migrations (directory &key force) 181 | (let ((schema.sql (merge-pathnames #P"schema.sql" directory)) 182 | (directory (merge-pathnames #P"migrations/" directory)) 183 | (current-version (current-migration-version))) 184 | 185 | ;; Warn if there're non-applied migration files. 186 | (let* ((sql-files (sort (uiop:directory-files directory "*.up.sql") 187 | #'string< 188 | :key #'pathname-name)) 189 | (non-applied-files 190 | (if current-version 191 | (remove-if-not (lambda (version) 192 | (and version 193 | (< current-version version))) 194 | sql-files 195 | :key #'migration-file-version) 196 | sql-files))) 197 | (when non-applied-files 198 | (if (y-or-n-p "Found non-applied ~D migration file~:*~P. Will you delete them?" 199 | (length non-applied-files)) 200 | (flet ((delete-migration-file (file) 201 | (format *error-output* "~&Deleting '~A'...~%" file) 202 | (delete-file file))) 203 | (dolist (up-file non-applied-files) 204 | (delete-migration-file up-file) 205 | (let ((down-file 206 | (make-pathname :name (ppcre:regex-replace "\\.up$" (pathname-name up-file) ".down") 207 | :defaults up-file))) 208 | (when (uiop:file-exists-p down-file) 209 | (delete-migration-file down-file))))) 210 | (progn 211 | (format *error-output* "~&Given up.~%") 212 | (return-from generate-migrations nil))))) 213 | 214 | (flet ((write-expressions (expressions destination &key print) 215 | (ensure-directories-exist directory) 216 | (with-open-file (out destination 217 | :direction :output 218 | :if-does-not-exist :create) 219 | (let ((out (if print 220 | (make-broadcast-stream *standard-output* out) 221 | out))) 222 | (with-quote-char 223 | (map nil 224 | (lambda (ex) 225 | (format out "~&~A;~%" (sxql:yield ex))) 226 | expressions)))) 227 | (let ((sxql:*use-placeholder* nil)) 228 | (with-open-file (out schema.sql 229 | :direction :output 230 | :if-exists :supersede 231 | :if-does-not-exist :create) 232 | (with-quote-char 233 | (format out "~{~{~A;~%~}~^~%~}" 234 | (mapcar (lambda (class) 235 | (mapcar #'sxql:yield (table-definition class))) 236 | (all-dao-classes))) 237 | (format out "~2&~A;~%" 238 | (sxql:yield (schema-migrations-table-definition)))))) 239 | destination)) 240 | (multiple-value-bind 241 | (up-expressions down-expressions) 242 | (all-migration-expressions) 243 | (cond 244 | ((or up-expressions force) 245 | (let* ((version (generate-version current-version)) 246 | (up-destination (make-pathname :name (format nil "~A.up" version) 247 | :type "sql" 248 | :defaults directory)) 249 | (down-destination (make-pathname :name (format nil "~A.down" version) 250 | :type "sql" 251 | :defaults directory)) 252 | (sxql:*use-placeholder* nil)) 253 | (write-expressions up-expressions up-destination :print t) 254 | (when down-expressions 255 | (write-expressions down-expressions down-destination)) 256 | (format t "~&Successfully generated: ~A~%" up-destination) 257 | (values up-destination 258 | (when down-expressions 259 | down-destination)))) 260 | (t 261 | (format t "~&Nothing to migrate.~%") 262 | (values))))))) 263 | 264 | (defun migration-file-version (file) 265 | (let* ((name (pathname-name file)) 266 | (pos (position-if (complement #'digit-char-p) name)) 267 | (version 268 | (if pos 269 | (subseq name 0 pos) 270 | name))) 271 | (when (<= 1 (length version)) 272 | (handler-case 273 | (parse-integer version) 274 | (error () 275 | (warn "Invalid version format in a migration file: ~A~%Version must be an integer. Ignored." file)))))) 276 | 277 | (defun migration-files (base-directory &key (sort-by #'<)) 278 | (sort (uiop:directory-files (merge-pathnames #P"migrations/" base-directory) 279 | "*.up.sql") 280 | sort-by 281 | :key #'migration-file-version)) 282 | 283 | (defun %migration-status (directory) 284 | (let ((db-versions 285 | (or (handler-case (retrieve-by-sql 286 | (sxql:select (:version) 287 | (sxql:from :schema_migrations) 288 | (sxql:where (:not-null :applied_at)) 289 | (sxql:order-by :version))) 290 | (dbi: () nil)) 291 | ;; XXX: for backward-compatibility (apply all non-applied files since e18d942ba0e556b1533d5a5ac5a9775e7c6abe93) 292 | (retrieve-by-sql 293 | (sxql:select (:version) 294 | (sxql:from :schema_migrations) 295 | (sxql:order-by (:desc :version)) 296 | (sxql:limit 1))))) 297 | (files (migration-files directory))) 298 | (loop while (and files 299 | db-versions 300 | (< (migration-file-version (first files)) 301 | (getf (first db-versions) :version))) 302 | do (pop files)) 303 | (let (results) 304 | (loop for db-version in db-versions 305 | do (destructuring-bind (&key version) db-version 306 | (loop while (and files (< (migration-file-version (first files)) version)) 307 | for file = (pop files) 308 | do (push (list :down :version (migration-file-version file) :file file) 309 | results)) 310 | (if (and files (= version (migration-file-version (first files)))) 311 | (push (list :up :version version :file (pop files)) 312 | results) 313 | (push (list :up :version version) results)))) 314 | (nconc (nreverse results) 315 | (mapcar (lambda (file) 316 | (list :down :version (migration-file-version file) :file file)) 317 | files))))) 318 | 319 | (defun migration-status (directory) 320 | (initialize-migrations-table) 321 | (format t "~& Status Migration ID~%--------------------------~%") 322 | (dolist (result (%migration-status directory)) 323 | (destructuring-bind (type &key version file) result 324 | (ecase type 325 | (:up (format t "~& up ~A" version)) 326 | (:down (format t "~& down ~A" version))) 327 | (etypecase file 328 | (null (format t " (NO FILE)~%")) 329 | (pathname (format t "~%")))))) 330 | 331 | (defparameter *advisory-lock-drivers* '(:postgres)) 332 | 333 | (defmacro with-advisory-lock ((connection) &body body) 334 | (with-gensyms (lock-id driver) 335 | (once-only (connection) 336 | `(let ((,driver (connection-driver-type ,connection))) 337 | (if (member ,driver *advisory-lock-drivers* :test 'eq) 338 | (let ((,lock-id (generate-advisory-lock-id (dbi:connection-database-name ,connection)))) 339 | (acquire-advisory-lock ,connection ,lock-id) 340 | (unwind-protect (progn ,@body) 341 | (release-advisory-lock ,connection ,lock-id))) 342 | (progn ,@body)))))) 343 | 344 | (defun migrate (directory &key dry-run force) 345 | (check-type directory pathname) 346 | (with-advisory-lock (*connection*) 347 | (let* ((current-version (current-migration-version)) 348 | (schema.sql (merge-pathnames #P"schema.sql" directory)) 349 | (sql-files-to-apply 350 | (if current-version 351 | (mapcar (lambda (result) 352 | (getf (cdr result) :file)) 353 | (remove :up 354 | (%migration-status directory) 355 | :key #'car)) 356 | (and (probe-file schema.sql) 357 | (list schema.sql))))) 358 | (cond 359 | (sql-files-to-apply 360 | (dbi:with-transaction *connection* 361 | (dolist (file sql-files-to-apply) 362 | (unless force 363 | (format t "~&Applying '~A'...~%" file) 364 | (let ((content (uiop:read-file-string file))) 365 | (dolist (stmt (parse-statements content)) 366 | (format t "~&-> ~A~%" stmt) 367 | (let ((mito.logger::*mito-logger-stream* nil)) 368 | (execute-sql stmt))))) 369 | (when current-version 370 | (let ((version (migration-file-version file))) 371 | (update-migration-version version)))) 372 | (let* ((migration-files (migration-files directory)) 373 | (latest-migration-file (first (last (if current-version 374 | sql-files-to-apply 375 | migration-files)))) 376 | (version (if latest-migration-file 377 | (migration-file-version latest-migration-file) 378 | (generate-version)))) 379 | (unless current-version 380 | (if migration-files 381 | ;; Record all versions on the first table creation 382 | (dolist (file migration-files) 383 | (update-migration-version (migration-file-version file))) 384 | (update-migration-version version))) 385 | (if dry-run 386 | (format t "~&No problems were found while migration.~%") 387 | (format t "~&Successfully updated to the version ~S.~%" version))) 388 | (when dry-run 389 | (dbi:rollback *connection*)))) 390 | (current-version 391 | (format t "~&Version ~S is up to date.~%" current-version)) 392 | (t 393 | (format t "~&Nothing to migrate.~%")))))) 394 | -------------------------------------------------------------------------------- /src/mito.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:mito 2 | (:use #:cl) 3 | (:use-reexport #:mito.core 4 | #:mito.migration)) 5 | (in-package #:mito) 6 | -------------------------------------------------------------------------------- /t/class.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.class 2 | (:use #:cl 3 | #:rove 4 | #:mito.class 5 | #:mito-test.util)) 6 | (in-package #:mito-test.class) 7 | 8 | (deftest create-table 9 | (testing "MySQL" 10 | (is-table-class :mysql 11 | (defclass tweet () 12 | ((id :col-type :serial 13 | :primary-key t) 14 | (status :col-type :text) 15 | (user :col-type :integer)) 16 | (:metaclass table-class)) 17 | "CREATE TABLE tweet ( 18 | id INT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 19 | status TEXT NOT NULL, 20 | user INTEGER NOT NULL 21 | )") 22 | (is-table-class :mysql 23 | (defclass tweet () 24 | ((id :col-type :bigserial 25 | :primary-key t) 26 | (status :col-type :text) 27 | (user :col-type :integer)) 28 | (:metaclass table-class)) 29 | "CREATE TABLE tweet ( 30 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 31 | status TEXT NOT NULL, 32 | user INTEGER NOT NULL 33 | )" 34 | "BIGSERIAL") 35 | (is-table-class :mysql 36 | (defclass tweet () 37 | ((status :col-type :text) 38 | (user :col-type :integer) 39 | (created-at :col-type :datetime)) 40 | (:metaclass table-class) 41 | (:primary-key user created-at)) 42 | "CREATE TABLE tweet ( 43 | status TEXT NOT NULL, 44 | user INTEGER NOT NULL, 45 | created_at DATETIME NOT NULL, 46 | PRIMARY KEY (user, created_at) 47 | )" 48 | "PRIMARY KEY") 49 | (is-table-class :mysql 50 | (defclass tweet () 51 | ((status :col-type :text) 52 | (user :col-type :integer) 53 | (created-at :col-type :datetime)) 54 | (:metaclass table-class) 55 | (:unique-keys (user created-at))) 56 | "CREATE TABLE tweet ( 57 | status TEXT NOT NULL, 58 | user INTEGER NOT NULL, 59 | created_at DATETIME NOT NULL, 60 | UNIQUE (user, created_at) 61 | )" 62 | "UNIQUE KEY") 63 | (is-table-class :mysql 64 | (defclass tweet () 65 | ((status :col-type :text) 66 | (user :col-type :integer) 67 | (created-at :col-type :datetime)) 68 | (:metaclass table-class) 69 | (:keys (user created-at))) 70 | "CREATE TABLE tweet ( 71 | status TEXT NOT NULL, 72 | user INTEGER NOT NULL, 73 | created_at DATETIME NOT NULL, 74 | KEY (user, created_at) 75 | )" 76 | "KEY") 77 | (is-table-class :mysql 78 | (defclass tweet () 79 | ((status :col-type :text) 80 | (user :col-type :integer) 81 | (created-at :col-type (or :datetime :null))) 82 | (:metaclass table-class)) 83 | "CREATE TABLE tweet ( 84 | status TEXT NOT NULL, 85 | user INTEGER NOT NULL, 86 | created_at DATETIME 87 | )" 88 | "NULL")) 89 | 90 | (testing "PostgreSQL" 91 | (is-table-class :postgres 92 | (defclass tweet () 93 | ((id :col-type :serial 94 | :primary-key t) 95 | (status :col-type :text) 96 | (user :col-type :integer)) 97 | (:metaclass table-class)) 98 | "CREATE TABLE tweet ( 99 | id SERIAL NOT NULL PRIMARY KEY, 100 | status TEXT NOT NULL, 101 | user INTEGER NOT NULL 102 | )") 103 | (is-table-class :postgres 104 | (defclass tweet () 105 | ((id :col-type :bigserial 106 | :primary-key t) 107 | (status :col-type :text) 108 | (user :col-type :integer)) 109 | (:metaclass table-class)) 110 | "CREATE TABLE tweet ( 111 | id BIGSERIAL NOT NULL PRIMARY KEY, 112 | status TEXT NOT NULL, 113 | user INTEGER NOT NULL 114 | )") 115 | (is-table-class :postgres 116 | (defclass tweet () 117 | ((status :col-type :text) 118 | (user :col-type :integer) 119 | (created-at :col-type :datetime)) 120 | (:metaclass table-class) 121 | (:primary-key user created-at)) 122 | "CREATE TABLE tweet ( 123 | status TEXT NOT NULL, 124 | user INTEGER NOT NULL, 125 | created_at TIMESTAMP NOT NULL, 126 | PRIMARY KEY (user, created_at) 127 | )" 128 | "PRIMARY KEY") 129 | (is-table-class :postgres 130 | (defclass tweet () 131 | ((status :col-type :text) 132 | (user :col-type :integer) 133 | (created-at :col-type :datetime)) 134 | (:metaclass table-class) 135 | (:unique-keys (user created-at))) 136 | '("CREATE TABLE tweet ( 137 | status TEXT NOT NULL, 138 | user INTEGER NOT NULL, 139 | created_at TIMESTAMP NOT NULL 140 | )" 141 | "CREATE UNIQUE INDEX unique_tweet_user_created_at ON tweet (user, created_at)") 142 | "UNIQUE KEY") 143 | (is-table-class :postgres 144 | (defclass tweet () 145 | ((status :col-type :text) 146 | (user :col-type :integer) 147 | (created-at :col-type :datetime)) 148 | (:metaclass table-class) 149 | (:keys (user created-at))) 150 | '("CREATE TABLE tweet ( 151 | status TEXT NOT NULL, 152 | user INTEGER NOT NULL, 153 | created_at TIMESTAMP NOT NULL 154 | )" "CREATE INDEX key_tweet_user_created_at ON tweet (user, created_at)") 155 | "KEY") 156 | (is-table-class :postgres 157 | (defclass tweet () 158 | ((status :col-type :text) 159 | (user :col-type :integer) 160 | (created-at :col-type (or :datetime :null))) 161 | (:metaclass table-class)) 162 | "CREATE TABLE tweet ( 163 | status TEXT NOT NULL, 164 | user INTEGER NOT NULL, 165 | created_at TIMESTAMP 166 | )" 167 | "NULL")) 168 | 169 | (testing "SQLite3" 170 | (is-table-class :sqlite3 171 | (defclass tweet () 172 | ((id :col-type :serial 173 | :primary-key t) 174 | (status :col-type :text) 175 | (user :col-type :integer)) 176 | (:metaclass table-class)) 177 | "CREATE TABLE tweet ( 178 | id INTEGER PRIMARY KEY AUTOINCREMENT, 179 | status TEXT NOT NULL, 180 | user INTEGER NOT NULL 181 | )") 182 | ;; bigserial 183 | (is-table-class :sqlite3 184 | (defclass tweet () 185 | ((id :col-type :bigserial 186 | :primary-key t) 187 | (status :col-type :text) 188 | (user :col-type :integer)) 189 | (:metaclass table-class)) 190 | "CREATE TABLE tweet ( 191 | id INTEGER PRIMARY KEY AUTOINCREMENT, 192 | status TEXT NOT NULL, 193 | user INTEGER NOT NULL 194 | )") 195 | (is-table-class :sqlite3 196 | (defclass tweet () 197 | ((status :col-type :text) 198 | (user :col-type :integer) 199 | (created-at :col-type :datetime)) 200 | (:metaclass table-class) 201 | (:primary-key user created-at)) 202 | "CREATE TABLE tweet ( 203 | status TEXT NOT NULL, 204 | user INTEGER NOT NULL, 205 | created_at DATETIME NOT NULL, 206 | PRIMARY KEY (user, created_at) 207 | )" 208 | "PRIMARY KEY") 209 | (is-table-class :sqlite3 210 | (defclass tweet () 211 | ((status :col-type :text) 212 | (user :col-type :integer) 213 | (created-at :col-type :datetime)) 214 | (:metaclass table-class) 215 | (:unique-keys (user created-at))) 216 | "CREATE TABLE tweet ( 217 | status TEXT NOT NULL, 218 | user INTEGER NOT NULL, 219 | created_at DATETIME NOT NULL, 220 | UNIQUE (user, created_at) 221 | )" 222 | "UNIQUE KEY") 223 | (is-table-class :sqlite3 224 | (defclass tweet () 225 | ((status :col-type :text) 226 | (user :col-type :integer) 227 | (created-at :col-type :datetime)) 228 | (:metaclass table-class) 229 | (:keys (user created-at))) 230 | "CREATE TABLE tweet ( 231 | status TEXT NOT NULL, 232 | user INTEGER NOT NULL, 233 | created_at DATETIME NOT NULL 234 | )" 235 | "KEY (ignored)") 236 | (is-table-class :sqlite3 237 | (defclass tweet () 238 | ((status :col-type :text) 239 | (user :col-type :integer) 240 | (created-at :col-type (or :datetime :null))) 241 | (:metaclass table-class)) 242 | "CREATE TABLE tweet ( 243 | status TEXT NOT NULL, 244 | user INTEGER NOT NULL, 245 | created_at DATETIME 246 | )" 247 | "NULL"))) 248 | 249 | (deftest references 250 | (defclass user () 251 | ((name :col-type (:varchar 64) 252 | :primary-key t)) 253 | (:metaclass table-class)) 254 | (is-table-class :mysql 255 | (defclass tweet () 256 | ((user :col-type user)) 257 | (:metaclass table-class)) 258 | "CREATE TABLE tweet ( 259 | user_name VARCHAR(64) NOT NULL 260 | )") 261 | (is-table-class :mysql 262 | (defclass tweet () 263 | ((user-name :references (user name))) 264 | (:metaclass table-class)) 265 | "CREATE TABLE tweet ( 266 | user_name VARCHAR(64) NOT NULL 267 | )") 268 | (is-table-class :mysql 269 | (defclass tweet () 270 | ((id :col-type :bigserial 271 | :primary-key t) 272 | (user :col-type user)) 273 | (:metaclass table-class) 274 | (:unique-keys user)) 275 | "CREATE TABLE tweet ( 276 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 277 | user_name VARCHAR(64) NOT NULL, 278 | UNIQUE (user_name) 279 | )") 280 | 281 | (is-table-class :mysql 282 | (defclass tweet-tags () 283 | ((tweet1 :col-type tweet) 284 | (tweet2 :col-type tweet) 285 | (uuid :col-type (:varchar 40))) 286 | (:metaclass table-class) 287 | (:unique-keys (tweet1 tweet2 uuid))) 288 | "CREATE TABLE tweet_tags ( 289 | tweet1_id BIGINT UNSIGNED NOT NULL, 290 | tweet2_id BIGINT UNSIGNED NOT NULL, 291 | uuid VARCHAR(40) NOT NULL, 292 | UNIQUE (tweet1_id, tweet2_id, uuid) 293 | )") 294 | 295 | (is-table-class :mysql 296 | (defclass tweet-tags () 297 | ((tweet1 :col-type (or tweet :null))) 298 | (:metaclass table-class)) 299 | "CREATE TABLE tweet_tags ( 300 | tweet1_id BIGINT UNSIGNED 301 | )")) 302 | 303 | (deftest self-reference 304 | (is-table-class :mysql 305 | (defclass category () 306 | ((parent :col-type category 307 | :initarg :parent 308 | :accessor parent)) 309 | (:metaclass mito:dao-table-class)) 310 | "CREATE TABLE category ( 311 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 312 | parent_id BIGINT UNSIGNED NOT NULL, 313 | created_at TIMESTAMP, 314 | updated_at TIMESTAMP 315 | )") 316 | (is-table-class :postgres 317 | (defclass category () 318 | ((parent :col-type category 319 | :initarg :parent 320 | :accessor parent)) 321 | (:metaclass mito:dao-table-class)) 322 | "CREATE TABLE category ( 323 | id BIGSERIAL NOT NULL PRIMARY KEY, 324 | parent_id BIGINT NOT NULL, 325 | created_at TIMESTAMPTZ, 326 | updated_at TIMESTAMPTZ 327 | )")) 328 | -------------------------------------------------------------------------------- /t/dao.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.dao 2 | (:use #:cl 3 | #:rove 4 | #:mito.dao 5 | #:mito.connection 6 | #:mito-test.util 7 | #:sxql) 8 | (:import-from #:alexandria 9 | #:make-keyword 10 | #:compose)) 11 | (in-package #:mito-test.dao) 12 | 13 | (deftest dao-table-class-inheritance 14 | (when (find-class 'tweet nil) 15 | (setf (find-class 'tweet) nil)) 16 | 17 | (defclass tweet () () 18 | (:metaclass dao-table-class)) 19 | 20 | (ok (find (find-class 'dao-class) (c2mop:class-direct-superclasses (find-class 'tweet))) 21 | "dao-table-class inherits dao-table implicitly") 22 | 23 | (defclass my-dao-class (dao-class) ()) 24 | 25 | (defclass tweet (my-dao-class) () 26 | (:metaclass dao-table-class)) 27 | 28 | (ok (not (find (find-class 'dao-class) (c2mop:class-direct-superclasses (find-class 'tweet)))) 29 | "Not inherit dao-class directly") 30 | (ok (find (find-class 'my-dao-class) (c2mop:class-direct-superclasses (find-class 'tweet))) 31 | "Inherit my-dao-class") 32 | 33 | (is-table-class :mysql 34 | (defclass tweet () 35 | ((status :col-type :text) 36 | (user :col-type :integer)) 37 | (:metaclass dao-table-class) 38 | (:record-timestamps nil)) 39 | "CREATE TABLE tweet ( 40 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 41 | status TEXT NOT NULL, 42 | user INTEGER NOT NULL 43 | )" 44 | "auto-pk") 45 | 46 | (is-table-class :mysql 47 | (defclass tweet () 48 | ((id :col-type :serial 49 | :primary-key t) 50 | (status :col-type :text) 51 | (user :col-type :integer)) 52 | (:metaclass dao-table-class) 53 | (:record-timestamps nil)) 54 | "CREATE TABLE tweet ( 55 | id INT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 56 | status TEXT NOT NULL, 57 | user INTEGER NOT NULL 58 | )" 59 | "add original PK") 60 | 61 | (is-table-class :mysql 62 | (defclass tweet () 63 | ((status :col-type :text) 64 | (user :col-type :integer)) 65 | (:metaclass dao-table-class) 66 | (:record-timestamps nil)) 67 | "CREATE TABLE tweet ( 68 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 69 | status TEXT NOT NULL, 70 | user INTEGER NOT NULL 71 | )" 72 | "redefinition w/o PK") 73 | 74 | (is-table-class :mysql 75 | (defclass tweet () 76 | ((status :col-type :text) 77 | (user :col-type :integer)) 78 | (:metaclass dao-table-class) 79 | (:auto-pk nil) 80 | (:record-timestamps nil)) 81 | "CREATE TABLE tweet ( 82 | status TEXT NOT NULL, 83 | user INTEGER NOT NULL 84 | )" 85 | "auto-pk is nil") 86 | 87 | (setf (find-class 'tweet) nil)) 88 | 89 | (deftest relation 90 | (setf *connection* (connect-to-testdb :mysql)) 91 | (when (find-class 'user nil) 92 | (setf (find-class 'user) nil)) 93 | (when (find-class 'user-setting nil) 94 | (setf (find-class 'user-setting) nil)) 95 | (when (find-class 'tweet nil) 96 | (setf (find-class 'tweet) nil)) 97 | 98 | (defclass user-setting () 99 | () 100 | (:metaclass dao-table-class)) 101 | 102 | (defclass user () 103 | ((id :col-type :serial 104 | :primary-key t) 105 | (name :col-type :text 106 | :initarg :name 107 | :accessor user-name) 108 | (setting :col-type (or user-setting :null) 109 | :initarg :setting 110 | :accessor user-setting)) 111 | (:metaclass dao-table-class) 112 | (:record-timestamps nil)) 113 | 114 | (defclass tweet () 115 | ((status :col-type :text 116 | :initarg :status 117 | :accessor tweet-status) 118 | (user :col-type user 119 | :initarg :user 120 | :accessor tweet-user)) 121 | (:metaclass dao-table-class) 122 | (:record-timestamps nil)) 123 | 124 | (ok (equal (mapcar #'sxql:yield (table-definition 'tweet)) 125 | '("CREATE TABLE tweet ( 126 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 127 | status TEXT NOT NULL, 128 | user_id INT UNSIGNED NOT NULL 129 | )"))) 130 | (mito:execute-sql "DROP TABLE IF EXISTS tweet") 131 | (mito:execute-sql "DROP TABLE IF EXISTS user") 132 | (mito:execute-sql "DROP TABLE IF EXISTS user_setting") 133 | (mito:ensure-table-exists 'user-setting) 134 | (mito:ensure-table-exists 'user) 135 | (mito:ensure-table-exists 'tweet) 136 | (let ((user (mito:create-dao 'user 137 | :name "Eitaro"))) 138 | (mito:create-dao 'tweet :status "Hello" :user user)) 139 | (let ((user (mito:create-dao 'user 140 | :name "Yoshimi" 141 | :setting (mito:create-dao 'user-setting)))) 142 | (mito:create-dao 'tweet :status "こんにちは" :user user)) 143 | 144 | (ok (= (mito:count-dao 'tweet) 2)) 145 | 146 | (dbi:with-transaction mito:*connection* 147 | (let ((tweet (first (mito:select-dao 'tweet (sxql:limit 1))))) 148 | (setf (tweet-status tweet) "Goodbye, World") 149 | (setf (tweet-user tweet) (mito:find-dao 'user :name "Yoshimi")) 150 | (mito:update-dao tweet :columns '(:status)) 151 | (ok (equal (user-name (tweet-user (first (mito:select-dao 'tweet (sxql:limit 1))))) 152 | "Eitaro")) 153 | (mito:update-dao tweet) 154 | (ok (equal (user-name (tweet-user (first (mito:select-dao 'tweet (sxql:limit 1))))) 155 | "Yoshimi"))) 156 | (dbi:rollback mito:*connection*)) 157 | 158 | (let ((tweets (mito:select-dao 'tweet))) 159 | (ok (= (length tweets) 2)) 160 | (ok (typep (first tweets) 'tweet)) 161 | (ok (typep (tweet-user (first tweets)) 'user)) 162 | 163 | (diag "deleting the related foreign object") 164 | (dbi:with-transaction mito:*connection* 165 | (mito:delete-dao (tweet-user (first tweets))) 166 | (slot-makunbound (first tweets) 'user) 167 | ;; related foreign object is nil 168 | (ok (null (tweet-user (first tweets)))) 169 | (slot-makunbound (first tweets) 'user) 170 | (setf (tweet-status (first tweets)) "Hello, World") 171 | 172 | ;; can update 173 | (mito:update-dao (first tweets)) 174 | (ok (slot-value (mito:find-dao 'tweet :id (mito:object-id (first tweets))) 'user-id)) 175 | (dbi:rollback mito:*connection*))) 176 | 177 | (ok (every (lambda (tweet) 178 | (not (slot-boundp tweet 'user))) 179 | (mito:select-dao 'tweet)) 180 | "foreign slots are not loaded") 181 | (ok (every (lambda (tweet) 182 | (slot-boundp tweet 'user)) 183 | (mito:select-dao 'tweet 184 | (mito:includes 'user))) 185 | "foreign slots are loaded eagerly with 'includes'.") 186 | 187 | (defclass friend-relationship () 188 | ((user-a :col-type user 189 | :initarg :user-a) 190 | (user-b :col-type user 191 | :initarg :user-b)) 192 | (:metaclass dao-table-class)) 193 | (mito:execute-sql "DROP TABLE IF EXISTS friend_relationshiop") 194 | (mito:ensure-table-exists 'friend-relationship) 195 | (mito:create-dao 'friend-relationship 196 | :user-a (mito:create-dao 'user :name "userA") 197 | :user-b (mito:create-dao 'user :name "userB")) 198 | 199 | (ok (every (lambda (rel) 200 | (and (slot-boundp rel 'user-a) 201 | (slot-boundp rel 'user-b))) 202 | (mito:select-dao 'friend-relationship 203 | (mito:includes 'user))) 204 | "foreign slots are loaded eagerly with 'includes'.") 205 | 206 | (let ((user (mito:find-dao 'user))) 207 | (ok user) 208 | (ok (typep (mito:find-dao 'tweet :user user) 209 | 'tweet) 210 | "Can find an object by a foreign object") 211 | (ok 212 | (mito.dao:select-dao 'tweet 213 | (where (:= :user user)))) 214 | (ok 215 | (mito.dao:select-dao 'tweet 216 | (where (:in :user (list user)))))) 217 | (testing "Can generate IS NULL query by find-dao" 218 | (ok (mito:find-dao 'user :name "Eitaro" :setting nil)) 219 | (ok (eql 4 (mito:count-dao 'user))) 220 | (ok (eql 3 (mito:count-dao 'user :setting nil)))) 221 | 222 | (ok (null (user-setting (mito:find-dao 'user :name "Eitaro")))) 223 | 224 | (defclass tweet2 (tweet) () 225 | (:metaclass dao-table-class) 226 | (:record-timestamps nil)) 227 | (mito:execute-sql "DROP TABLE IF EXISTS tweet2") 228 | (mito:ensure-table-exists 'tweet2) 229 | 230 | (let ((user (mito:find-dao 'user :name "Eitaro"))) 231 | (ok (mito:create-dao 'tweet2 :status "Hello" :user user))) 232 | 233 | (let ((tweet (mito:find-dao 'tweet :id 1))) 234 | (ok (= (mito:count-dao 'tweet) 2)) 235 | (ok tweet) 236 | (mito:delete-dao tweet) 237 | (ok (= (mito:count-dao 'tweet) 1)) 238 | (mito:delete-by-values 'tweet :id 2) 239 | (ok (= (mito:count-dao 'tweet) 0))) 240 | 241 | (dolist (class-name '(user-setting user tweet friend-relationship tweet2)) 242 | (setf (find-class class-name) nil)) 243 | 244 | (disconnect-toplevel)) 245 | 246 | (deftest cursor 247 | (setf *connection* (connect-to-testdb :postgres)) 248 | (when (find-class 'user nil) 249 | (setf (find-class 'user) nil)) 250 | (defclass user () 251 | ((name :col-type :text 252 | :initarg :name)) 253 | (:metaclass dao-table-class)) 254 | (mito:execute-sql "DROP TABLE IF EXISTS \"user\"") 255 | (mito:ensure-table-exists 'user) 256 | (mito:create-dao 'user :name "Eitaro") 257 | (mito:create-dao 'user :name "Btaro") 258 | (mito:create-dao 'user :name "Charlie") 259 | (dbi:with-transaction *connection* 260 | (let* ((mito.dao::*want-cursor* t) 261 | (cursor (mito.dao:select-dao 'user 262 | (where (:like :name "%aro"))))) 263 | (ok (typep cursor 'mito.dao::mito-cursor)) 264 | (let ((row (mito.dao::fetch-dao-from-cursor cursor))) 265 | (ok (typep row 'user)) 266 | (ok (equal (slot-value row 'name) "Eitaro"))) 267 | (let ((row (mito.dao::fetch-dao-from-cursor cursor))) 268 | (ok (typep row 'user)) 269 | (ok (equal (slot-value row 'name) "Btaro"))) 270 | (ok (null (mito.dao::fetch-dao-from-cursor cursor))))) 271 | 272 | (let ((records '())) 273 | (do-select (user (mito.dao:select-dao 'user) i) 274 | (push (cons i user) records) 275 | (when (<= 1 i) 276 | (return))) 277 | (ok (= (length records) 2)) 278 | (ok (every (lambda (record) 279 | (typep (cdr record) 'user)) 280 | records))) 281 | 282 | (when (find-class 'user nil) 283 | (setf (find-class 'user) nil)) 284 | (disconnect-toplevel)) 285 | 286 | (deftest foreign-slots 287 | (setf *connection* (connect-to-testdb :mysql)) 288 | (defclass user () 289 | () 290 | (:metaclass dao-table-class)) 291 | (defclass tweet () 292 | () 293 | (:metaclass dao-table-class)) 294 | (defclass tweet-tag () 295 | ((user :col-type user) 296 | (tweet :col-type tweet)) 297 | (:metaclass dao-table-class) 298 | (:primary-key user tweet)) 299 | (ok (equal (mapcar #'sxql:yield (table-definition 'tweet-tag)) 300 | '("CREATE TABLE tweet_tag ( 301 | user_id BIGINT UNSIGNED NOT NULL, 302 | tweet_id BIGINT UNSIGNED NOT NULL, 303 | created_at TIMESTAMP, 304 | updated_at TIMESTAMP, 305 | PRIMARY KEY (user_id, tweet_id) 306 | )"))) 307 | (defclass tweet-tag () 308 | ((user :col-type user) 309 | (tweet :col-type tweet)) 310 | (:metaclass dao-table-class) 311 | (:keys (user tweet))) 312 | (ok (equal (mapcar #'sxql:yield (table-definition 'tweet-tag)) 313 | '("CREATE TABLE tweet_tag ( 314 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 315 | user_id BIGINT UNSIGNED NOT NULL, 316 | tweet_id BIGINT UNSIGNED NOT NULL, 317 | created_at TIMESTAMP, 318 | updated_at TIMESTAMP, 319 | KEY (user_id, tweet_id) 320 | )"))) 321 | 322 | (dolist (class-name '(user tweet tweet-tag)) 323 | (setf (find-class class-name) nil)) 324 | (disconnect-toplevel)) 325 | 326 | (deftest inflate-deflate 327 | (dolist (driver '(:mysql :postgres :sqlite3)) 328 | (testing (format nil "inflate & deflate (~A)" driver) 329 | (setf *connection* (connect-to-testdb driver)) 330 | (defclass user () 331 | ((id :col-type :serial 332 | :primary-key t) 333 | (name :col-type :text 334 | :initarg :name) 335 | (is-admin :col-type :boolean 336 | :initform nil 337 | :initarg :is-admin) 338 | (role :col-type (:varchar 12) 339 | :initarg :role 340 | :deflate #'string-downcase 341 | :inflate (compose #'make-keyword #'string-upcase))) 342 | (:metaclass dao-table-class)) 343 | (mito:execute-sql 344 | (sxql:drop-table :user :if-exists t)) 345 | (mito:ensure-table-exists 'user) 346 | 347 | (let ((mito:*mito-logger-stream* t)) 348 | (mito:create-dao 'user 349 | :name "Admin User A" 350 | :is-admin t 351 | :role :manager) 352 | (mito:create-dao 'user 353 | :name "User B" 354 | :is-admin nil 355 | :role :end-user) 356 | 357 | (let ((user (mito:find-dao 'user :id 1))) 358 | (ok (slot-value user 'is-admin)) 359 | (ok (typep (mito:object-created-at user) 'local-time:timestamp))) 360 | (let ((user (mito:find-dao 'user :id 2))) 361 | (ok (null (slot-value user 'is-admin))) 362 | (ok (typep (mito:object-created-at user) 'local-time:timestamp))) 363 | (let ((user (mito:find-dao 'user :role :manager))) 364 | (ok user))) 365 | 366 | (setf (find-class 'user) nil) 367 | (disconnect-toplevel)))) 368 | 369 | (deftest timestamp-with-milliseconds 370 | (setf *connection* (connect-to-testdb :postgres)) 371 | (defclass user () 372 | ((registered-at :col-type :timestamp)) 373 | (:metaclass dao-table-class) 374 | (:record-timestamps nil)) 375 | (mito:execute-sql 376 | (sxql:drop-table :user :if-exists t)) 377 | (mito:ensure-table-exists 'user) 378 | 379 | (let ((now (local-time:now))) 380 | (mito:create-dao 'user :registered-at now) 381 | (let ((user (mito:find-dao 'user :id 1))) 382 | (ok (typep (slot-value user 'registered-at) 'local-time:timestamp)) 383 | (ok (/= 0 (local-time:nsec-of (slot-value user 'registered-at)))))) 384 | (setf (find-class 'user) nil) 385 | (disconnect-toplevel)) 386 | 387 | (deftest accessor 388 | (defclass parent () 389 | () 390 | (:metaclass dao-table-class)) 391 | 392 | (defclass child () 393 | ((parent :col-type parent 394 | :initarg :parent 395 | :accessor child-parent)) 396 | (:metaclass dao-table-class)) 397 | 398 | (setf *connection* (connect-to-testdb :postgres)) 399 | (mito:execute-sql (sxql:drop-table :parent :if-exists t)) 400 | (mito:execute-sql (sxql:drop-table :child :if-exists t)) 401 | (mito:ensure-table-exists 'parent) 402 | (mito:ensure-table-exists 'child) 403 | (mito:create-dao 'child :parent (mito:create-dao 'parent)) 404 | (child-parent (mito:find-dao 'child)) 405 | (ok (object= (child-parent (mito:find-dao 'child)) 406 | (mito:find-dao 'parent))) 407 | 408 | (dolist (class-name '(parent child)) 409 | (setf (find-class class-name) nil))) 410 | -------------------------------------------------------------------------------- /t/db/main.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.db.main 2 | (:use #:cl 3 | #:rove 4 | #:mito-test.util 5 | #:mito.db) 6 | (:export #:run-db-tests)) 7 | (in-package #:mito-test.db.main) 8 | 9 | (defun run-db-tests (conn) 10 | (testing "column-definitions" 11 | (ok (equal (column-definitions conn "tweets") 12 | (ecase (dbi:connection-driver-type conn) 13 | (:mysql 14 | '(("id" :type "int" :auto-increment t :primary-key t :not-null t :default nil) 15 | ("status" :type "text" :auto-increment nil :primary-key nil :not-null t :default nil) 16 | ("user" :type "varchar(64)" :auto-increment nil :primary-key nil :not-null t :default nil))) 17 | (:postgres 18 | '(("id" :type "integer" :auto-increment t :primary-key t :not-null t :default nil) 19 | ("status" :type "text" :auto-increment nil :primary-key nil :not-null t :default nil) 20 | ("user" :type "character varying(64)" :auto-increment nil :primary-key nil :not-null t :default nil))) 21 | (:sqlite3 22 | '(("id" :type "INTEGER" :auto-increment t :primary-key t :not-null t :default nil) 23 | ("status" :type "TEXT" :auto-increment nil :primary-key nil :not-null t :default nil) 24 | ("user" :type "VARCHAR(64)" :auto-increment nil :primary-key nil :not-null t :default nil))))) 25 | "tweets")) 26 | 27 | (testing "table-indices" 28 | (ok (equal (mapcar #'cdr (table-indices conn "tweets")) 29 | '((:unique-key t :primary-key t :columns ("id")) 30 | (:unique-key t :primary-key nil :columns ("id" "user")))) 31 | "tweets") 32 | 33 | (ok (equal (mapcar #'cdr (table-indices conn "users")) 34 | '((:unique-key t :primary-key t :columns ("id")) 35 | (:unique-key t :primary-key nil :columns ("first_name" "family_name")))) 36 | "users")) 37 | 38 | (testing "last-insert-id" 39 | (ok (eql (last-insert-id conn "users" "id") 0) 40 | "Should be 0 when there's no record") 41 | (dbi:do-sql conn "INSERT INTO users (first_name, family_name) VALUES ('Eitaro', 'Fukamachi')") 42 | (ok (eql (last-insert-id conn "users" "id") 1) 43 | "Should be 1 after inserting") 44 | (dbi:do-sql conn "INSERT INTO users (first_name, family_name) VALUES ('Rudolph', 'Miller')") 45 | (ok (eql (last-insert-id conn "users" "id") 2) 46 | "Should be 2 after inserting once more.")) 47 | 48 | (testing "Retry DBI:DBI-DATABASE-ERROR when using prepared cache" 49 | (let ((mito:*connection* conn)) 50 | (mito:execute-sql 51 | "DROP TABLE IF EXISTS prepared_cache_retry") 52 | (mito:execute-sql 53 | "CREATE TABLE IF NOT EXISTS prepared_cache_retry (id VARCHAR(32))") 54 | (let ((mito:*use-prepare-cached* t)) 55 | (ok (null (mito:retrieve-by-sql 56 | "SELECT * FROM prepared_cache_retry"))) 57 | (mito:execute-sql 58 | "ALTER TABLE prepared_cache_retry ADD COLUMN name VARCHAR(64)") 59 | (ok (null (mito:retrieve-by-sql 60 | "SELECT * FROM prepared_cache_retry"))))))) 61 | -------------------------------------------------------------------------------- /t/db/mysql.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.db.mysql 2 | (:use #:cl 3 | #:dbi 4 | #:rove 5 | #:mito-test.util 6 | #:mito-test.db.main)) 7 | (in-package #:mito-test.db.mysql) 8 | 9 | (defvar *conn* nil) 10 | 11 | (setup 12 | (setf *conn* (connect-to-testdb :mysql)) 13 | 14 | (dbi:do-sql *conn* "DROP TABLE IF EXISTS tweets") 15 | (dbi:do-sql *conn* 16 | "CREATE TABLE tweets ( 17 | id INTEGER AUTO_INCREMENT PRIMARY KEY NOT NULL, 18 | status TEXT NOT NULL, 19 | user VARCHAR(64) NOT NULL, 20 | UNIQUE (id, user) 21 | )") 22 | 23 | (dbi:do-sql *conn* "DROP TABLE IF EXISTS users") 24 | (dbi:do-sql *conn* 25 | "CREATE TABLE users ( 26 | id INTEGER AUTO_INCREMENT PRIMARY KEY NOT NULL, 27 | first_name VARCHAR(64) NOT NULL, 28 | family_name VARCHAR(64) NOT NULL, 29 | UNIQUE(first_name, family_name) 30 | )")) 31 | 32 | (deftest mysql-tests 33 | (run-db-tests *conn*)) 34 | 35 | (teardown 36 | (disconnect-from-testdb *conn*)) 37 | -------------------------------------------------------------------------------- /t/db/postgres.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.db.postgres 2 | (:use #:cl 3 | #:dbi 4 | #:rove 5 | #:mito-test.util 6 | #:mito-test.db.main)) 7 | (in-package #:mito-test.db.postgres) 8 | 9 | (defvar *conn* nil) 10 | 11 | (setup 12 | (setf *conn* (connect-to-testdb :postgres)) 13 | 14 | (dbi:do-sql *conn* "DROP TABLE IF EXISTS tweets") 15 | (dbi:do-sql *conn* 16 | "CREATE TABLE tweets ( 17 | id SERIAL PRIMARY KEY, 18 | status TEXT NOT NULL, 19 | \"user\" VARCHAR(64) NOT NULL, 20 | UNIQUE (id, \"user\") 21 | )") 22 | 23 | (dbi:do-sql *conn* "DROP TABLE IF EXISTS users") 24 | (dbi:do-sql *conn* 25 | "CREATE TABLE users ( 26 | id SERIAL PRIMARY KEY, 27 | first_name VARCHAR(64) NOT NULL, 28 | family_name VARCHAR(64) NOT NULL, 29 | UNIQUE(first_name, family_name) 30 | )")) 31 | 32 | (deftest postgres-tests 33 | (run-db-tests *conn*)) 34 | 35 | (teardown 36 | (disconnect-from-testdb *conn*)) 37 | -------------------------------------------------------------------------------- /t/db/sqlite3.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.db.sqlite3 2 | (:use #:cl 3 | #:dbi 4 | #:rove 5 | #:mito-test.util 6 | #:mito-test.db.main)) 7 | (in-package #:mito-test.db.sqlite3) 8 | 9 | (defvar *conn* nil) 10 | 11 | (setup 12 | (setf *conn* (reconnect-to-testdb (connect-to-testdb :sqlite3))) 13 | 14 | (dbi:do-sql *conn* 15 | "CREATE TABLE tweets ( 16 | id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, 17 | status TEXT NOT NULL, 18 | user VARCHAR(64) NOT NULL, 19 | UNIQUE (id, user) 20 | )") 21 | 22 | (dbi:do-sql *conn* 23 | "CREATE TABLE users ( 24 | id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, 25 | first_name VARCHAR(64) NOT NULL, 26 | family_name VARCHAR(64) NOT NULL, 27 | UNIQUE(first_name, family_name) 28 | )")) 29 | 30 | (deftest sqlite3-tests 31 | (run-db-tests *conn*)) 32 | 33 | (teardown 34 | (disconnect-from-testdb *conn*)) 35 | -------------------------------------------------------------------------------- /t/migration/mysql.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.migration.mysql 2 | (:use #:cl 3 | #:rove 4 | #:mito 5 | #:mito.migration 6 | #:mito-test.util)) 7 | (in-package #:mito-test.migration.mysql) 8 | 9 | (setup 10 | (setf *connection* (connect-to-testdb :mysql)) 11 | 12 | (when (find-class 'tweets nil) 13 | (setf (find-class 'tweets) nil)) 14 | (execute-sql "DROP TABLE IF EXISTS tweets")) 15 | 16 | (deftest mysql-migration-tests 17 | (testing "first definition (no explicit primary key)" 18 | (defclass tweets () 19 | ((user :col-type (:varchar 128) 20 | :accessor tweet-user)) 21 | (:metaclass dao-table-class) 22 | (:record-timestamps nil)) 23 | (mapc #'execute-sql (table-definition 'tweets)) 24 | 25 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 26 | '(nil nil nil nil nil)) 27 | "No migration at first") 28 | 29 | (defclass tweets () 30 | ((user :col-type (:varchar 128) 31 | :accessor tweet-user)) 32 | (:metaclass dao-table-class) 33 | (:table-name "tweets") 34 | (:record-timestamps nil)) 35 | 36 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 37 | '(nil nil nil nil nil)) 38 | "No migration at first")) 39 | 40 | (testing "redefinition with :auto-pk nil" 41 | (defclass tweets () 42 | ((user :col-type (:varchar 128) 43 | :accessor tweet-user)) 44 | (:metaclass dao-table-class) 45 | (:auto-pk nil) 46 | (:record-timestamps nil)) 47 | 48 | (destructuring-bind (add-columns 49 | drop-columns 50 | change-columns 51 | add-indices 52 | drop-indices) 53 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 54 | (ok (null add-columns) 55 | "No columns to add") 56 | (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN id")) 57 | "Drop column id") 58 | (ok (null change-columns) 59 | "No columns to change") 60 | (ok (null add-indices) 61 | "No indices to add") 62 | (ok (null drop-indices) 63 | "No indices to drop"))) 64 | 65 | (testing "redefinition (with explicit primary key)" 66 | (defclass tweets () 67 | ((tweet-id :col-type :serial 68 | :primary-key t 69 | :reader tweet-id) 70 | (status :col-type :text 71 | :accessor tweet-status) 72 | (user :col-type (:varchar 128) 73 | :accessor tweet-user)) 74 | (:metaclass dao-table-class) 75 | (:record-timestamps nil)) 76 | 77 | (destructuring-bind (add-columns 78 | drop-columns 79 | change-columns 80 | add-indices 81 | drop-indices) 82 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 83 | (ok (equal (mapcar #'sxql:yield add-columns) 84 | '("ALTER TABLE tweets ADD COLUMN status text NOT NULL, ADD COLUMN tweet_id int unsigned NOT NULL AUTO_INCREMENT PRIMARY KEY")) 85 | "Add id and status") 86 | (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN id")) 87 | "Drop id") 88 | (ok (null change-columns) 89 | "No columns to change") 90 | (ok (null add-indices) 91 | "No indices to add (added when adding column)") 92 | (ok (null drop-indices) 93 | "No indices to drop (will remove when dropping column)")) 94 | 95 | (migrate-table (find-class 'tweets)) 96 | 97 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 98 | '(nil nil nil nil nil)) 99 | "No migration after migrating")) 100 | 101 | (testing "redefinition of primary key" 102 | (defclass tweets () 103 | ((tweet-id :col-type :bigserial 104 | :primary-key t 105 | :reader tweet-id) 106 | (status :col-type :text 107 | :accessor tweet-status) 108 | (user :col-type (:varchar 128) 109 | :accessor tweet-user)) 110 | (:metaclass dao-table-class) 111 | (:record-timestamps nil)) 112 | 113 | (destructuring-bind (add-columns 114 | drop-columns 115 | change-columns 116 | add-indices 117 | drop-indices) 118 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 119 | (ok (null add-columns)) 120 | (ok (null drop-columns)) 121 | (ok (equal (format nil "~{~A~^~%~}" 122 | (mapcar #'sxql:yield change-columns)) 123 | "ALTER TABLE tweets MODIFY COLUMN tweet_id bigint unsigned NOT NULL AUTO_INCREMENT")) 124 | (ok (null add-indices)) 125 | (ok (null drop-indices))) 126 | 127 | (migrate-table (find-class 'tweets)) 128 | 129 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 130 | '(nil nil nil nil nil)) 131 | "No migration after migrating")) 132 | 133 | (testing "Change to the serial primary key again" 134 | (defclass tweets () 135 | ((tweet-id :col-type :bigint 136 | :reader tweet-id) 137 | (status :col-type :text 138 | :accessor tweet-status) 139 | (user :col-type (:varchar 128) 140 | :accessor tweet-user)) 141 | (:metaclass dao-table-class) 142 | (:record-timestamps nil) 143 | (:unique-keys (tweet-id))) 144 | 145 | (destructuring-bind (add-columns 146 | drop-columns 147 | change-columns 148 | add-indices 149 | drop-indices) 150 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 151 | (ok (equal (mapcar #'sxql:yield add-columns) 152 | '("ALTER TABLE tweets ADD COLUMN id bigint unsigned NOT NULL AUTO_INCREMENT PRIMARY KEY")) 153 | "Add id") 154 | (ok (null drop-columns) 155 | "No columns to drop") 156 | (ok (equal (mapcar #'sxql:yield change-columns) 157 | '("ALTER TABLE tweets MODIFY COLUMN tweet_id bigint NOT NULL")) 158 | "Change the type of tweet_id") 159 | (ok (equal (mapcar #'sxql:yield add-indices) 160 | '("CREATE UNIQUE INDEX unique_tweets_tweet_id ON tweets (tweet_id)")) 161 | "Add a unique index") 162 | (ok (equal (mapcar #'sxql:yield drop-indices) 163 | '("ALTER TABLE tweets MODIFY COLUMN tweet_id bigint unsigned NOT NULL" 164 | "DROP INDEX PRIMARY ON tweets")) 165 | "Drop the primary key")) 166 | 167 | (migrate-table (find-class 'tweets)) 168 | 169 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 170 | '(nil nil nil nil nil)) 171 | "No migration after migrating")) 172 | 173 | (testing "redefinition" 174 | (defclass tweets () 175 | ((tweet-id :col-type :bigint 176 | :reader tweet-id) 177 | (user :col-type (:varchar 64) 178 | :accessor tweet-user) 179 | (created-at :col-type (:char 8))) 180 | (:metaclass dao-table-class) 181 | (:record-timestamps nil) 182 | (:unique-keys (tweet-id))) 183 | 184 | (destructuring-bind (add-columns 185 | drop-columns 186 | change-columns 187 | add-indices 188 | drop-indices) 189 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 190 | (ok (equal (mapcar #'sxql:yield add-columns) 191 | '("ALTER TABLE tweets ADD COLUMN created_at char(8) NOT NULL"))) 192 | (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN status"))) 193 | (ok (equal (format nil "~{~A~^~%~}" 194 | (mapcar #'sxql:yield change-columns)) 195 | "ALTER TABLE tweets MODIFY COLUMN user varchar(64) NOT NULL")) 196 | (ok (null add-indices)) 197 | (ok (null drop-indices))) 198 | 199 | (migrate-table (find-class 'tweets)) 200 | 201 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 202 | '(nil nil nil nil nil)) 203 | "No migration after migrating")) 204 | 205 | (testing "redefinition (modifying the column type)" 206 | (defclass tweets () 207 | ((tweet-id :col-type :bigint 208 | :reader tweet-id) 209 | (user :col-type (:varchar 128) 210 | :accessor tweet-user) 211 | (created-at :col-type (:char 8))) 212 | (:metaclass dao-table-class) 213 | (:record-timestamps nil) 214 | (:unique-keys (tweet-id))) 215 | 216 | (destructuring-bind (add-columns 217 | drop-columns 218 | change-columns 219 | add-indices 220 | drop-indices) 221 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 222 | (ok (null add-columns)) 223 | (ok (null drop-columns)) 224 | (ok (equal (format nil "~{~A~^~%~}" 225 | (mapcar #'sxql:yield change-columns)) 226 | "ALTER TABLE tweets MODIFY COLUMN user varchar(128) NOT NULL")) 227 | (ok (null add-indices)) 228 | (ok (null drop-indices))) 229 | 230 | (migrate-table (find-class 'tweets)) 231 | 232 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 233 | '(nil nil nil nil nil)) 234 | "No migration after migrating")) 235 | 236 | (testing "add :unique-keys" 237 | (defclass tweets () 238 | ((tweet-id :col-type :bigint 239 | :reader tweet-id) 240 | (user :col-type (:varchar 128) 241 | :accessor tweet-user) 242 | (created-at :col-type (:char 8))) 243 | (:metaclass dao-table-class) 244 | (:record-timestamps nil) 245 | (:unique-keys (tweet-id) (user created-at))) 246 | 247 | (destructuring-bind (add-columns 248 | drop-columns 249 | change-columns 250 | add-indices 251 | drop-indices) 252 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 253 | (ok (null add-columns)) 254 | (ok (null drop-columns)) 255 | (ok (null change-columns)) 256 | (ok (= (length add-indices) 1)) 257 | (ok (ppcre:scan "^CREATE UNIQUE INDEX [^ ]+ ON tweets \\(user, created_at\\)$" 258 | (sxql:yield (first add-indices)))) 259 | (ok (null drop-indices))) 260 | 261 | (migrate-table (find-class 'tweets)) 262 | 263 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 264 | '(nil nil nil nil nil)) 265 | "No migration after migrating")) 266 | 267 | (testing "modify :unique-keys" 268 | (defclass tweets () 269 | ((tweet-id :col-type :bigint 270 | :reader tweet-id) 271 | (user :col-type (:varchar 128) 272 | :accessor tweet-user) 273 | (created-at :col-type (:char 8))) 274 | (:metaclass dao-table-class) 275 | (:record-timestamps nil) 276 | (:unique-keys (tweet-id) 277 | (tweet-id user created-at))) 278 | 279 | (destructuring-bind (add-columns 280 | drop-columns 281 | change-columns 282 | add-indices 283 | drop-indices) 284 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 285 | (ok (null add-columns)) 286 | (ok (null drop-columns)) 287 | (ok (null change-columns)) 288 | (ok (= (length add-indices) 1)) 289 | (ok (ppcre:scan "^CREATE UNIQUE INDEX [^ ]+ ON tweets \\(tweet_id, user, created_at\\)$" 290 | (sxql:yield (first add-indices)))) 291 | (ok (= (length drop-indices) 1)) 292 | (ok (ppcre:scan "^DROP INDEX [^ ]+ ON tweets$" (sxql:yield (first drop-indices))))) 293 | 294 | (migrate-table (find-class 'tweets)) 295 | 296 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 297 | '(nil nil nil nil nil)) 298 | "No migration after migrating")) 299 | 300 | (testing "delete :unique-keys and add :keys" 301 | (defclass tweets () 302 | ((tweet-id :col-type :bigint 303 | :reader tweet-id) 304 | (user :col-type (:varchar 128) 305 | :accessor tweet-user) 306 | (created-at :col-type (:char 8))) 307 | (:metaclass dao-table-class) 308 | (:record-timestamps nil) 309 | (:unique-keys (tweet-id)) 310 | (:keys (user created-at))) 311 | 312 | (destructuring-bind (add-columns 313 | drop-columns 314 | change-columns 315 | add-indices 316 | drop-indices) 317 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 318 | (ok (null add-columns)) 319 | (ok (null drop-columns)) 320 | (ok (null change-columns)) 321 | (ok (= (length add-indices) 1)) 322 | (ok (ppcre:scan "^CREATE INDEX [^ ]+ ON tweets \\(user, created_at\\)$" 323 | (sxql:yield (first add-indices)))) 324 | (ok (= (length drop-indices) 1)) 325 | (ok (ppcre:scan "^DROP INDEX [^ ]+ ON tweets$" 326 | (sxql:yield (first drop-indices))))) 327 | 328 | (migrate-table (find-class 'tweets)) 329 | 330 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :mysql) 331 | '(nil nil nil nil nil)) 332 | "No migration after migrating")) 333 | 334 | (testing "composite primary keys" 335 | (when (find-class 'tag nil) 336 | (setf (find-class 'tag) nil)) 337 | (execute-sql "DROP TABLE IF EXISTS tag") 338 | (when (find-class 'tweets-tag nil) 339 | (setf (find-class 'tweets-tag) nil)) 340 | (execute-sql "DROP TABLE IF EXISTS tweets_tag") 341 | 342 | (defclass tag () 343 | ((name :col-type (:varchar 10) 344 | :initarg :name)) 345 | (:metaclass dao-table-class)) 346 | (ensure-table-exists 'tag) 347 | (defclass tweets-tag () 348 | ((tweet :col-type tweets 349 | :initarg :tweet) 350 | (tag :col-type tag 351 | :initarg :tag)) 352 | (:metaclass dao-table-class) 353 | (:record-timestamps nil) 354 | (:auto-pk nil) 355 | (:primary-key tweet tag)) 356 | (ensure-table-exists 'tweets-tag) 357 | 358 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets-tag) :mysql) 359 | '(nil nil nil nil nil)) 360 | "No migration after migrating"))) 361 | 362 | (teardown 363 | (disconnect-toplevel)) 364 | -------------------------------------------------------------------------------- /t/migration/postgres.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.migration.postgres 2 | (:use #:cl 3 | #:rove 4 | #:mito 5 | #:mito.migration 6 | #:mito.migration.table 7 | #:mito-test.util)) 8 | (in-package #:mito-test.migration.postgres) 9 | 10 | (setup 11 | (setf *connection* (connect-to-testdb :postgres)) 12 | 13 | (when (find-class 'tweets nil) 14 | (setf (find-class 'tweets) nil)) 15 | (execute-sql "DROP TABLE IF EXISTS tweets")) 16 | 17 | (deftest postgres-migration-tests 18 | (testing "first definition (no explicit primary key)" 19 | (defclass tweets () 20 | ((user :col-type (:varchar 128) 21 | :accessor tweet-user)) 22 | (:metaclass dao-table-class) 23 | (:record-timestamps nil)) 24 | (mapc #'execute-sql (table-definition 'tweets)) 25 | 26 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 27 | '(nil nil nil nil nil)) 28 | "No migration at first") 29 | 30 | (defclass tweets () 31 | ((user :col-type (:varchar 128) 32 | :accessor tweet-user)) 33 | (:metaclass dao-table-class) 34 | (:table-name "tweets") 35 | (:record-timestamps nil)) 36 | 37 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 38 | '(nil nil nil nil nil)) 39 | "No migration at first")) 40 | 41 | (testing "redefinition with :auto-pk nil" 42 | (defclass tweets () 43 | ((user :col-type (:varchar 128) 44 | :accessor tweet-user)) 45 | (:metaclass dao-table-class) 46 | (:auto-pk nil) 47 | (:record-timestamps nil)) 48 | 49 | (destructuring-bind (add-columns 50 | drop-columns 51 | change-columns 52 | add-indices 53 | drop-indices) 54 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 55 | (ok (null add-columns) 56 | "No columns to add") 57 | (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN id")) 58 | "Drop column id") 59 | (ok (null change-columns) 60 | "No columns to change") 61 | (ok (null add-indices) 62 | "No indices to add") 63 | (ok (null drop-indices) 64 | "No indices to drop"))) 65 | 66 | (testing "redefinition (with explicit primary key)" 67 | (defclass tweets () 68 | ((tweet-id :col-type :serial 69 | :primary-key t 70 | :reader tweet-id) 71 | (status :col-type :text 72 | :accessor tweet-status) 73 | (user :col-type (:varchar 128) 74 | :accessor tweet-user)) 75 | (:metaclass dao-table-class) 76 | (:record-timestamps nil)) 77 | 78 | (destructuring-bind (add-columns 79 | drop-columns 80 | change-columns 81 | add-indices 82 | drop-indices) 83 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 84 | (ok (equal (mapcar #'sxql:yield add-columns) 85 | '("ALTER TABLE tweets ADD COLUMN status text NOT NULL, ADD COLUMN tweet_id serial NOT NULL PRIMARY KEY")) 86 | "Add id and status") 87 | (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN id")) 88 | "Drop id") 89 | (ok (null change-columns) 90 | "No columns to change") 91 | (ok (null add-indices) 92 | "No indices to add (added when adding column)") 93 | (ok (null drop-indices) 94 | "No indices to drop (will remove when dropping column)")) 95 | 96 | (migrate-table (find-class 'tweets)) 97 | 98 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 99 | '(nil nil nil nil nil)) 100 | "No migration after migrating")) 101 | 102 | (testing "Change to the serial primary key again" 103 | (defclass tweets () 104 | ((tweet-id :col-type :serial 105 | :reader tweet-id) 106 | (status :col-type :text 107 | :accessor tweet-status) 108 | (user :col-type (:varchar 128) 109 | :accessor tweet-user)) 110 | (:metaclass dao-table-class) 111 | (:record-timestamps nil) 112 | (:unique-keys (tweet-id))) 113 | 114 | (destructuring-bind (add-columns 115 | drop-columns 116 | change-columns 117 | add-indices 118 | drop-indices) 119 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 120 | (ok (equal (mapcar #'sxql:yield add-columns) 121 | '("ALTER TABLE tweets ADD COLUMN id bigserial NOT NULL PRIMARY KEY")) 122 | "Add id") 123 | (ok (null drop-columns) 124 | "No columns to drop") 125 | (ok (null change-columns) 126 | "No columns to change") 127 | (ok (equal (mapcar #'sxql:yield add-indices) 128 | '("CREATE UNIQUE INDEX unique_tweets_tweet_id ON tweets (tweet_id)")) 129 | "Create a unique index") 130 | (ok (equal (mapcar #'sxql:yield drop-indices) 131 | '("ALTER TABLE tweets DROP CONSTRAINT tweets_pkey")) 132 | "Drop the primary key")) 133 | 134 | (migrate-table (find-class 'tweets)) 135 | 136 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 137 | '(nil nil nil nil nil)) 138 | "No migration after migrating")) 139 | 140 | (testing "redefinition" 141 | (defclass tweets () 142 | ((tweet-id :col-type :serial 143 | :reader tweet-id) 144 | (user :col-type (:varchar 64) 145 | :accessor tweet-user) 146 | (created-at :col-type (:char 8))) 147 | (:metaclass dao-table-class) 148 | (:record-timestamps nil) 149 | (:unique-keys (tweet-id))) 150 | 151 | (destructuring-bind (add-columns 152 | drop-columns 153 | change-columns 154 | add-indices 155 | drop-indices) 156 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 157 | (ok (equal (mapcar #'sxql:yield add-columns) 158 | '("ALTER TABLE tweets ADD COLUMN created_at character(8) NOT NULL"))) 159 | (ok (equal (mapcar #'sxql:yield drop-columns) '("ALTER TABLE tweets DROP COLUMN status"))) 160 | (ok (equal (format nil "~{~A~^~%~}" 161 | (mapcar #'sxql:yield change-columns)) 162 | "ALTER TABLE tweets ALTER COLUMN user TYPE character varying(64)")) 163 | (ok (null add-indices)) 164 | (ok (null drop-indices))) 165 | 166 | (migrate-table (find-class 'tweets)) 167 | 168 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 169 | '(nil nil nil nil nil)) 170 | "No migration after migrating")) 171 | 172 | (testing "redefinition (modifying the column type)" 173 | (defclass tweets () 174 | ((tweet-id :col-type :serial 175 | :reader tweet-id) 176 | (user :col-type (:varchar 128) 177 | :accessor tweet-user) 178 | (created-at :col-type (:char 8))) 179 | (:metaclass dao-table-class) 180 | (:record-timestamps nil) 181 | (:unique-keys (tweet-id))) 182 | 183 | (destructuring-bind (add-columns 184 | drop-columns 185 | change-columns 186 | add-indices 187 | drop-indices) 188 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 189 | (ok (null add-columns)) 190 | (ok (null drop-columns)) 191 | (ok (equal (format nil "~{~A~^~%~}" 192 | (mapcar #'sxql:yield change-columns)) 193 | "ALTER TABLE tweets ALTER COLUMN user TYPE character varying(128)")) 194 | (ok (null add-indices)) 195 | (ok (null drop-indices))) 196 | 197 | (migrate-table (find-class 'tweets)) 198 | 199 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 200 | '(nil nil nil nil nil)) 201 | "No migration after migrating")) 202 | 203 | (testing "redefinition of primary key" 204 | (defclass tweets () 205 | ((tweet-id :col-type :bigserial 206 | :reader tweet-id) 207 | (user :col-type (:varchar 128) 208 | :accessor tweet-user) 209 | (created-at :col-type (:char 8))) 210 | (:metaclass dao-table-class) 211 | (:record-timestamps nil) 212 | (:unique-keys (tweet-id))) 213 | 214 | (destructuring-bind (add-columns 215 | drop-columns 216 | change-columns 217 | add-indices 218 | drop-indices) 219 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 220 | (ok (null add-columns)) 221 | (ok (null drop-columns)) 222 | (ok (equal (format nil "~{~A~^~%~}" 223 | (mapcar #'sxql:yield change-columns)) 224 | "ALTER TABLE tweets ALTER COLUMN tweet_id TYPE bigint")) 225 | (ok (null add-indices)) 226 | (ok (null drop-indices))) 227 | 228 | (migrate-table (find-class 'tweets)) 229 | 230 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 231 | '(nil nil nil nil nil)) 232 | "No migration after migrating")) 233 | 234 | (testing "add :unique-keys" 235 | (defclass tweets () 236 | ((tweet-id :col-type :bigserial 237 | :reader tweet-id) 238 | (user :col-type (:varchar 128) 239 | :accessor tweet-user) 240 | (created-at :col-type (:char 8))) 241 | (:metaclass dao-table-class) 242 | (:record-timestamps nil) 243 | (:unique-keys (tweet-id) (user created-at))) 244 | 245 | (destructuring-bind (add-columns 246 | drop-columns 247 | change-columns 248 | add-indices 249 | drop-indices) 250 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 251 | (ok (null add-columns)) 252 | (ok (null drop-columns)) 253 | (ok (null change-columns)) 254 | (ok (= (length add-indices) 1)) 255 | (ok (ppcre:scan "^CREATE UNIQUE INDEX [^ ]+ ON tweets \\(user, created_at\\)$" 256 | (sxql:yield (first add-indices)))) 257 | (ok (null drop-indices))) 258 | 259 | (migrate-table (find-class 'tweets)) 260 | 261 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 262 | '(nil nil nil nil nil)) 263 | "No migration after migrating")) 264 | 265 | (testing "modify :unique-keys" 266 | (defclass tweets () 267 | ((tweet-id :col-type :bigserial 268 | :reader tweet-id) 269 | (user :col-type (:varchar 128) 270 | :accessor tweet-user) 271 | (created-at :col-type (:char 8))) 272 | (:metaclass dao-table-class) 273 | (:record-timestamps nil) 274 | (:unique-keys (tweet-id) 275 | (tweet-id user created-at))) 276 | 277 | (destructuring-bind (add-columns 278 | drop-columns 279 | change-columns 280 | add-indices 281 | drop-indices) 282 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 283 | (ok (null add-columns)) 284 | (ok (null drop-columns)) 285 | (ok (null change-columns)) 286 | (ok (= (length add-indices) 1)) 287 | (ok (ppcre:scan "^CREATE UNIQUE INDEX [^ ]+ ON tweets \\(tweet_id, user, created_at\\)$" 288 | (sxql:yield (first add-indices)))) 289 | (ok (= (length drop-indices) 1)) 290 | (ok (ppcre:scan "^DROP INDEX [^ ]+$" 291 | (sxql:yield (first drop-indices))))) 292 | 293 | (migrate-table (find-class 'tweets)) 294 | 295 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 296 | '(nil nil nil nil nil)) 297 | "No migration after migrating")) 298 | 299 | (testing "delete :unique-keys and add :keys" 300 | (defclass tweets () 301 | ((tweet-id :col-type :bigserial 302 | :reader tweet-id) 303 | (user :col-type (:varchar 128) 304 | :accessor tweet-user) 305 | (created-at :col-type (:char 8))) 306 | (:metaclass dao-table-class) 307 | (:record-timestamps nil) 308 | (:unique-keys (tweet-id)) 309 | (:keys (user created-at))) 310 | 311 | (destructuring-bind (add-columns 312 | drop-columns 313 | change-columns 314 | add-indices 315 | drop-indices) 316 | (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 317 | (ok (null add-columns)) 318 | (ok (null drop-columns)) 319 | (ok (null change-columns)) 320 | (ok (= (length add-indices) 1)) 321 | (ok (ppcre:scan "^CREATE INDEX [^ ]+ ON tweets \\(user, created_at\\)$" 322 | (sxql:yield (first add-indices)))) 323 | (ok (= (length drop-indices) 1)) 324 | (ok (ppcre:scan "^DROP INDEX [^ ]+$" 325 | (sxql:yield (first drop-indices))))) 326 | 327 | (migrate-table (find-class 'tweets)) 328 | 329 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets) :postgres) 330 | '(nil nil nil nil nil)) 331 | "No migration after migrating")) 332 | 333 | (testing "composite primary keys" 334 | (when (find-class 'tweets-tag nil) 335 | (setf (find-class 'tweets-tag) nil)) 336 | (execute-sql "DROP TABLE IF EXISTS tweets_tag") 337 | (when (find-class 'tag nil) 338 | (setf (find-class 'tag) nil)) 339 | (execute-sql "DROP TABLE IF EXISTS tag") 340 | 341 | (defclass tag () 342 | ((name :col-type (:varchar 10) 343 | :initarg :name)) 344 | (:metaclass dao-table-class)) 345 | (ensure-table-exists 'tag) 346 | (defclass tweets-tag () 347 | ((tweet :col-type tweets 348 | :initarg :tweet) 349 | (tag :col-type tag 350 | :initarg :tag)) 351 | (:metaclass dao-table-class) 352 | (:record-timestamps nil) 353 | (:auto-pk nil) 354 | (:primary-key tweet tag)) 355 | (ensure-table-exists 'tweets-tag) 356 | 357 | (ok (equal (mito.migration.table::migration-expressions-aux (find-class 'tweets-tag) :postgres) 358 | '(nil nil nil nil nil)) 359 | "No migration after migrating"))) 360 | 361 | (teardown 362 | (disconnect-toplevel)) 363 | -------------------------------------------------------------------------------- /t/migration/sqlite3.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.migration.sqlite3 2 | (:use #:cl 3 | #:rove 4 | #:mito 5 | #:mito.migration 6 | #:mito-test.util)) 7 | (in-package #:mito-test.migration.sqlite3) 8 | 9 | (setup 10 | (setf *connection* (reconnect-to-testdb (connect-to-testdb :sqlite3))) 11 | 12 | (when (find-class 'tweets nil) 13 | (setf (find-class 'tweets) nil)) 14 | (execute-sql "DROP TABLE IF EXISTS tweets")) 15 | 16 | (defclass tweets () 17 | ((id :col-type :serial 18 | :primary-key t) 19 | (status :col-type (or :text :null)) 20 | (user :col-type (:varchar 64))) 21 | (:metaclass dao-table-class) 22 | (:unique-keys (id user))) 23 | 24 | (deftest sqlite3-migration-tests 25 | (testing "first definition (no explicit primary key)" 26 | (defclass tweets () 27 | ((user :col-type (:varchar 128) 28 | :accessor tweet-user)) 29 | (:metaclass dao-table-class)) 30 | (mapc #'execute-sql (table-definition 'tweets)) 31 | 32 | (ok (null (migration-expressions (find-class 'tweets) :sqlite3)) 33 | "No migration at first") 34 | 35 | (defclass tweets () 36 | ((user :col-type (:varchar 128) 37 | :accessor tweet-user)) 38 | (:metaclass dao-table-class) 39 | (:table-name "tweets")) 40 | 41 | (ok (null (migration-expressions (find-class 'tweets) :sqlite3)) 42 | "No migration at first")) 43 | 44 | (testing "redefinition with :auto-pk nil" 45 | (defclass tweets () 46 | ((user :col-type (:varchar 128) 47 | :accessor tweet-user)) 48 | (:metaclass dao-table-class) 49 | (:auto-pk nil)) 50 | 51 | (ok (migration-expressions (find-class 'tweets) :sqlite3))) 52 | 53 | (testing "redefinition (with explicit primary key)" 54 | (defclass tweets () 55 | ((id :col-type :serial 56 | :primary-key t 57 | :reader tweet-id) 58 | (status :col-type :text 59 | :accessor tweet-status) 60 | (user :col-type (:varchar 128) 61 | :accessor tweet-user)) 62 | (:metaclass dao-table-class)) 63 | 64 | (ok (migration-expressions (find-class 'tweets) :sqlite3)) 65 | 66 | (migrate-table (find-class 'tweets)) 67 | 68 | (ok (null (migration-expressions (find-class 'tweets) :sqlite3)) 69 | "No migration after migrating")) 70 | 71 | (testing "redefinition" 72 | (defclass tweets () 73 | ((id :col-type :serial 74 | :primary-key t 75 | :reader tweet-id) 76 | (user :col-type (:varchar 64) 77 | :accessor tweet-user)) 78 | (:metaclass dao-table-class)) 79 | 80 | (ok (migration-expressions (find-class 'tweets) :sqlite3)) 81 | 82 | (migrate-table (find-class 'tweets)) 83 | 84 | (ok (null (migration-expressions (find-class 'tweets) :sqlite3)) 85 | "No migration after migrating")) 86 | 87 | (testing "redefinition (modifying the column type)" 88 | (defclass tweets () 89 | ((id :col-type :serial 90 | :primary-key t 91 | :reader tweet-id) 92 | (user :col-type (:varchar 128) 93 | :accessor tweet-user)) 94 | (:metaclass dao-table-class)) 95 | 96 | (ok (migration-expressions (find-class 'tweets) :sqlite3)) 97 | 98 | (migrate-table (find-class 'tweets)) 99 | 100 | (ok (null (migration-expressions (find-class 'tweets) :sqlite3)) 101 | "No migration after migrating")) 102 | 103 | (testing "redefinition of primary key (bigserial)" 104 | (defclass tweets () 105 | ((id :col-type :bigserial 106 | :primary-key t 107 | :reader tweet-id) 108 | (user :col-type (:varchar 128) 109 | :accessor tweet-user)) 110 | (:metaclass dao-table-class)) 111 | 112 | (ok (null (migration-expressions (find-class 'tweets) :sqlite3)) 113 | "BIGSERIAL is same as SERIAL on SQLite3")) 114 | 115 | (testing "add :unique-keys" 116 | (defclass tweets () 117 | ((id :col-type :bigserial 118 | :primary-key t 119 | :reader tweet-id) 120 | (user :col-type (:varchar 128) 121 | :accessor tweet-user)) 122 | (:metaclass dao-table-class) 123 | (:unique-keys user)) 124 | 125 | (ok (migration-expressions (find-class 'tweets) :sqlite3)) 126 | 127 | (migrate-table (find-class 'tweets)) 128 | 129 | (ok (null (migration-expressions (find-class 'tweets) :sqlite3)) 130 | "No migration after migrating")) 131 | 132 | (testing "modify :unique-keys" 133 | (defclass tweets () 134 | ((id :col-type :bigserial 135 | :primary-key t 136 | :reader tweet-id) 137 | (user :col-type (:varchar 128) 138 | :accessor tweet-user)) 139 | (:metaclass dao-table-class) 140 | (:unique-keys (id user))) 141 | 142 | (ok (migration-expressions (find-class 'tweets) :sqlite3)) 143 | 144 | (migrate-table (find-class 'tweets)) 145 | 146 | (ok (null (migration-expressions (find-class 'tweets) :sqlite3)) 147 | "No migration after migrating")) 148 | 149 | (testing "delete :unique-keys and add :keys" 150 | (defclass tweets () 151 | ((id :col-type :bigserial 152 | :primary-key t 153 | :reader tweet-id) 154 | (user :col-type (:varchar 128) 155 | :accessor tweet-user)) 156 | (:metaclass dao-table-class) 157 | (:keys user)) 158 | 159 | (ok (migration-expressions (find-class 'tweets) :sqlite3)) 160 | 161 | (migrate-table (find-class 'tweets)) 162 | 163 | (ok (null (migration-expressions (find-class 'tweets) :sqlite3)) 164 | "No migration after migrating")) 165 | 166 | (testing "composite primary keys" 167 | (defclass tag () 168 | ((name :col-type (:varchar 10) 169 | :initarg :name)) 170 | (:metaclass dao-table-class)) 171 | (ensure-table-exists 'tag) 172 | (defclass tweets-tag () 173 | ((tweet :col-type tweets 174 | :initarg :tweet) 175 | (tag :col-type tag 176 | :initarg :tag)) 177 | (:metaclass dao-table-class) 178 | (:record-timestamps nil) 179 | (:auto-pk nil) 180 | (:primary-key tweet tag)) 181 | (ensure-table-exists 'tweets-tag) 182 | 183 | (ok (null (migration-expressions (find-class 'tweets-tag) :sqlite3)) 184 | "No migration after migrating"))) 185 | 186 | (teardown 187 | (disconnect-toplevel)) 188 | -------------------------------------------------------------------------------- /t/mixin.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.mixin 2 | (:use #:cl 3 | #:rove 4 | #:mito-test.util 5 | #:mito.connection 6 | #:mito.class 7 | #:mito.dao.mixin 8 | #:mito.dao.view 9 | #:mito.dao.table)) 10 | (in-package #:mito-test.mixin) 11 | 12 | (deftest record-timestamps 13 | (setf *connection* (connect-to-testdb :mysql)) 14 | (when (find-class 'tweet nil) 15 | (setf (find-class 'tweet) nil)) 16 | 17 | (defclass tweet (record-timestamps-mixin) 18 | ((status :col-type (:varchar 140) 19 | :initarg :status 20 | :accessor tweet-status)) 21 | (:metaclass dao-table-class)) 22 | 23 | (ok (equal (mapcar #'sxql:yield (table-definition 'tweet)) 24 | '("CREATE TABLE tweet ( 25 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 26 | status VARCHAR(140) NOT NULL, 27 | created_at TIMESTAMP, 28 | updated_at TIMESTAMP 29 | )"))) 30 | 31 | (mito:execute-sql "DROP TABLE IF EXISTS tweet") 32 | (mito:ensure-table-exists 'tweet) 33 | 34 | (let ((obj (mito:create-dao 'tweet :status "Hi"))) 35 | (ok (= (object-id obj) 1)) 36 | (let ((obj (mito:find-dao 'tweet :id 1))) 37 | (ok (typep (object-created-at obj) 'local-time:timestamp)) 38 | (ok (typep (object-updated-at obj) 'local-time:timestamp)) 39 | (ok (local-time:timestamp= (object-created-at obj) 40 | (object-updated-at obj))) 41 | (ok (<= (local-time:timestamp-to-universal (object-created-at obj)) 42 | (+ (local-time:timestamp-to-universal (local-time:now)) 1))) 43 | (setf (tweet-status obj) "Hi, again") 44 | (sleep 2) 45 | (mito:save-dao obj)) 46 | (let ((obj (mito:find-dao 'tweet :id 1))) 47 | (ok (local-time:timestamp/= (object-created-at obj) 48 | (object-updated-at obj))))) 49 | 50 | (disconnect-toplevel)) 51 | 52 | (deftest custom-mixin 53 | (setf *connection* (connect-to-testdb :mysql)) 54 | (when (find-class 'tweet nil) 55 | (setf (find-class 'tweet) nil)) 56 | 57 | (defclass user () 58 | () 59 | (:metaclass dao-table-class)) 60 | (defclass base-tweet () 61 | ((user :col-type user 62 | :initarg :user 63 | :accessor tweet-user) 64 | (status :col-type (:varchar 140) 65 | :initarg :status 66 | :accessor tweet-status)) 67 | (:metaclass dao-table-mixin)) 68 | (defclass tweet (base-tweet) 69 | () 70 | (:metaclass dao-table-class)) 71 | 72 | (ok (equal (mapcar #'sxql:yield (table-definition 'tweet)) 73 | '("CREATE TABLE tweet ( 74 | id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY, 75 | user_id BIGINT UNSIGNED NOT NULL, 76 | status VARCHAR(140) NOT NULL, 77 | created_at TIMESTAMP, 78 | updated_at TIMESTAMP 79 | )"))) 80 | 81 | (disconnect-toplevel)) 82 | -------------------------------------------------------------------------------- /t/postgres-types.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.postgres-types 2 | (:use #:cl 3 | #:rove 4 | #:mito.dao 5 | #:mito.connection 6 | #:mito-test.util)) 7 | (in-package #:mito-test.postgres-types) 8 | 9 | (deftest retrieve-by-sql 10 | (setf *connection* (connect-to-testdb :postgres)) 11 | (ok (equal (mito:retrieve-by-sql "select row(1,NULL);") 12 | '((:ROW "(1,)")))) 13 | 14 | (ok (equal (mito:retrieve-by-sql "select NULL;") 15 | '((:?COLUMN? NIL)))) 16 | 17 | (ok (equal (mito:retrieve-by-sql "select row(NULL, 'a', NULL);") 18 | '((:ROW "(,a,)")))) 19 | 20 | (ok (equalp (mito:retrieve-by-sql "select row(ARRAY[NULL, NULL]);") 21 | '((:ROW "(\"{NULL,NULL}\")")))) 22 | 23 | (ok (equalp (mito:retrieve-by-sql "select row(ARRAY['bogus', NULL]);") 24 | '((:ROW "(\"{bogus,NULL}\")"))))) 25 | 26 | (deftest retrieve-by-sql-binary 27 | (setf *connection* (connect-to-testdb :postgres)) 28 | (cl-postgres:with-binary-row-values 29 | (ok (equal (mito:retrieve-by-sql "select row(1,NULL);") 30 | '((:ROW (1 NIL))))) 31 | 32 | (ok (equal (mito:retrieve-by-sql "select NULL;") 33 | '((:?COLUMN? NIL)))) 34 | 35 | (ok (equal (mito:retrieve-by-sql "select row(NULL, 'a', NULL);") 36 | '((:ROW (NIL "a" NIL))))) 37 | 38 | (ok (equalp (mito:retrieve-by-sql "select row(ARRAY[NULL, NULL]);") 39 | '((:ROW (#(NIL NIL)))))) 40 | 41 | (ok (equalp (mito:retrieve-by-sql "select row(ARRAY['bogus', NULL]);") 42 | '((:ROW (#("bogus" NIL)))))))) 43 | -------------------------------------------------------------------------------- /t/util.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:mito-test.util 2 | (:use #:cl 3 | #:sxql) 4 | (:import-from #:mito.class 5 | #:create-table-sxql) 6 | (:import-from #:dbi 7 | #:disconnect 8 | #:connect 9 | #:connection-driver-type 10 | #:connection-database-name) 11 | (:export #:disconnect-from-testdb 12 | #:connect-to-testdb 13 | #:reconnect-to-testdb 14 | #:is-table-class)) 15 | (in-package #:mito-test.util) 16 | 17 | (defun sqlite3-disconnect-from-testdb (conn) 18 | (when conn 19 | (ignore-errors (dbi:disconnect conn)) 20 | (let ((db-path (dbi:connection-database-name conn))) 21 | (when (probe-file db-path) 22 | (delete-file db-path))))) 23 | 24 | (defun sqlite3-connect-to-testdb () 25 | (dbi:connect :sqlite3 :database-name (asdf:system-relative-pathname :mito #P"t/test.db"))) 26 | 27 | (defun postgres-disconnect-from-testdb (conn) 28 | (dbi:disconnect conn)) 29 | 30 | (defun postgres-connect-to-testdb () 31 | (dbi:connect :postgres 32 | :database-name "mito" 33 | :host (or (uiop:getenv "POSTGRES_HOST") "localhost") 34 | :port (parse-integer 35 | (or (uiop:getenv "POSTGRES_PORT") 36 | "5432")) 37 | :username (or (uiop:getenv "POSTGRES_USER") "mito") 38 | :password (or (uiop:getenv "POSTGRES_PASS") "mito") 39 | :microsecond-precision t)) 40 | 41 | (defun mysql-disconnect-from-testdb (conn) 42 | (dbi:disconnect conn)) 43 | 44 | (defun mysql-connect-to-testdb () 45 | (dbi:connect :mysql 46 | :database-name "mito" 47 | :host (or (uiop:getenv "MYSQL_HOST") "0.0.0.0") 48 | :port (parse-integer 49 | (or (uiop:getenv "MYSQL_PORT") 50 | "3306")) 51 | :username (or (uiop:getenv "MYSQL_USER") "root") 52 | :password (or (uiop:getenv "MYSQL_PASS") "mito"))) 53 | 54 | (defun disconnect-from-testdb (conn) 55 | (funcall 56 | (ecase (connection-driver-type conn) 57 | (:sqlite3 #'sqlite3-disconnect-from-testdb) 58 | (:mysql #'mysql-disconnect-from-testdb) 59 | (:postgres #'postgres-disconnect-from-testdb)) 60 | conn)) 61 | 62 | (defun connect-to-testdb (driver-type) 63 | (funcall 64 | (ecase driver-type 65 | (:sqlite3 #'sqlite3-connect-to-testdb) 66 | (:mysql #'mysql-connect-to-testdb) 67 | (:postgres #'postgres-connect-to-testdb)))) 68 | 69 | (defun reconnect-to-testdb (conn) 70 | (disconnect-from-testdb conn) 71 | (connect-to-testdb (connection-driver-type conn))) 72 | 73 | (defmacro is-table-class (driver class-definition create-table &optional desc) 74 | (let ((class (gensym "CLASS"))) 75 | `(let ((,class ,class-definition)) 76 | (rove:ok (equal (let ((sxql:*use-placeholder* nil)) 77 | (mapcar #'sxql:yield (create-table-sxql ,class ,driver))) 78 | (alexandria:ensure-list ,create-table)) 79 | (format nil "~A (~S)~:[~;~:* ~A~]" (class-name ,class) ,driver ,desc))))) 80 | --------------------------------------------------------------------------------