# HG changeset patch # User Steve Losh # Date 1712243458 14400 # Node ID 6878b5690d2e1a14c83a9640a26785db53d3df53 # Parent 002f47d3452381f96214a896304259986876fa93 Sketch out first version with sqlite diff -r 002f47d34523 -r 6878b5690d2e .hgignore --- a/.hgignore Thu Mar 28 10:41:20 2024 -0400 +++ b/.hgignore Thu Apr 04 11:10:58 2024 -0400 @@ -3,3 +3,4 @@ scratch.lisp *.png docs/build +*.sqlite diff -r 002f47d34523 -r 6878b5690d2e dbvolve.asd --- a/dbvolve.asd Thu Mar 28 10:41:20 2024 -0400 +++ b/dbvolve.asd Thu Apr 04 11:10:58 2024 -0400 @@ -6,9 +6,19 @@ :license "MIT" :version "0.0.1" - :depends-on () + :depends-on (:uiop) :serial t :components ((:module "src" :serial t :components ((:file "package") (:file "main"))))) + +(asdf:defsystem :dbvolve/sqlite + :description "DBvolve for sqlite." + :author "Steve Losh " + + :depends-on (:dbvolve :sqlite) + + :serial t + :components ((:module "src" :serial t + :components ((:file "sqlite"))))) diff -r 002f47d34523 -r 6878b5690d2e src/main.lisp --- a/src/main.lisp Thu Mar 28 10:41:20 2024 -0400 +++ b/src/main.lisp Thu Apr 04 11:10:58 2024 -0400 @@ -1,1 +1,138 @@ (in-package :dbvolve) + +;;;; Data --------------------------------------------------------------------- +(defclass evolution () + ((id :initarg :id :accessor id) + (name :initarg :name :accessor name) + (path :initarg :path :accessor path))) + +(defclass evolution/sql (evolution) + ()) + +(defmethod print-object ((o evolution) s) + (print-unreadable-object (o s :type t) + (format s "~D ~A" (id o) (name o)))) + + +;;;; Parsing ------------------------------------------------------------------ +(defun evolution-type-p (type) + (cond ((string-equal "sql" type) :sql))) + +(defun parse-evolution-path (path) + (let ((type (evolution-type-p (pathname-type path)))) + (when type + (or (let* ((name (pathname-name path)) + (sep (position-if (lambda (ch) (member ch '(#\- #\_))) name))) + (when (and sep (plusp sep)) + (let ((id (parse-integer name :end sep :junk-allowed t))) + (when id + (make-instance (ecase type + (:sql 'evolution/sql)) + :id id + :name (subseq name (1+ sep)) + :path path))))) + (error "Could not parse evolution filename ~S." path))))) + +(defun check-evolutions (evolutions) + (let ((by-id (make-hash-table))) + (loop :for e :across evolutions :do (push e (gethash (id e) by-id))) + (let ((start (id (aref evolutions 0))) + (end (id (aref evolutions (1- (length evolutions)))))) + (when (not (zerop start)) + (error "Evolution number must start at 0, but first (~S) has ID ~D." + (path (aref evolutions 0)) start)) + (loop :for id :from start :to end + :for es = (gethash id by-id) + :for n = (length es) + :when (> n 1) + :do (error "Multiple evolutions found for ID ~D:~{~% ~S~}" + id (mapcar #'path es)) + :when (zerop n) + :do (error "Gap in evolution numbering, IDs range from ~D to ~D but no evolution found for ~D." + start end id))))) + +(defun find-evolutions (path) + (let* ((parsed (remove nil (mapcar #'parse-evolution-path (uiop:directory-files path)))) + (result (sort (coerce parsed 'vector) #'< :key #'id))) + (if (plusp (length result)) + (check-evolutions result) + (warn "Could not find any evolutions in ~S." path)) + result)) + + +;;;; Protocol ----------------------------------------------------------------- +(defgeneric call-with-new-transaction (db thunk)) +(defgeneric create-metadata-table (db)) +(defgeneric lock-metadata-table (db)) +(defgeneric find-current-number (db)) +(defgeneric dump-current-state (db)) +(defgeneric run-evolution (db evolution)) +(defgeneric record-evolution (db evolution)) +(defgeneric commit (db)) + + +;;;; Stub Implementation ------------------------------------------------------ +(defmethod call-with-new-transaction ((db null) thunk) + (funcall thunk)) + +(defmethod create-metadata-table ((db null)) + (write-line " + CREATE TABLE IF NOT EXISTS dbvolve ( + id BIGINT PRIMARY KEY, + name TEXT NOT NULL, + created TIMESTAMPTZ NOT NULL DEFAULT now() + ); + ")) + +(defmethod lock-metadata-table ((db null)) + (write-line "LOCK TABLE dvolve;") + ) + +(defmethod find-current-number ((db null)) + (write-line "SELECT max(id) FROM dbvolve;") + 1) + +(defmethod dump-current-state ((db null)) + (write-line "SELECT * FROM dbvolve;")) + +(defmethod run-evolution ((db null) (evolution evolution/sql)) + (write-line (uiop:read-file-string (path evolution)))) + +(defmethod record-evolution ((db null) evolution) + (write-line (format nil "INSERT INTO dbvolve (id, name, file) VALUES (~S, ~S);" + (id evolution) + (name evolution)))) + +(defmethod commit ((db null))) + + +;;;; API ---------------------------------------------------------------------- +(defun evolve% (database evolutions) + (dolist (evolution evolutions) + (format t "~%Running ~A.~%" evolution) + (run-evolution database evolution) + (record-evolution database evolution) + (format t "Finished ~A.~%" evolution))) + +(defun evolve (database evolutions-path) + (let* ((path (uiop:parse-native-namestring evolutions-path :ensure-directory t)) + (evolutions (find-evolutions path))) + (if (zerop (length evolutions)) + (warn "No evolutions found in ~S, doing nothing." evolutions-path) + (let ((n (length evolutions))) + (call-with-new-transaction + database + (lambda () + (create-metadata-table database) + (lock-metadata-table database) + (let* ((current (find-current-number database)) + (start (1+ current))) + (format t "Found ~D evolution~:P, DB has ~D, running ~D evolution~:P.~%" + n (1+ current) (- n start)) + (evolve% database (subseq evolutions start)) + (commit) + (format t "Finished running ~D evolution~:P successfully.~%" n)))))))) + +#; Scratch -------------------------------------------------------------------- + + diff -r 002f47d34523 -r 6878b5690d2e src/sqlite.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/sqlite.lisp Thu Apr 04 11:10:58 2024 -0400 @@ -0,0 +1,49 @@ +(defpackage :dbvolve/sqlite + (:use :cl) + (:export)) + +(in-package :dbvolve/sqlite) + +;;;; Implementation ----------------------------------------------------------- + +(defmethod dbvolve::call-with-new-transaction ((db sqlite:sqlite-handle) thunk) + (let ((ok nil)) + (sqlite:execute-non-query db "BEGIN TRANSACTION EXCLUSIVE") + (unwind-protect (progn (funcall thunk) + (setf ok t)) + (if ok + (sqlite:execute-non-query db "COMMIT TRANSACTION") + (sqlite:execute-non-query db "ROLLBACK TRANSACTION"))))) + +(defmethod dbvolve::create-metadata-table ((db sqlite:sqlite-handle)) + (sqlite:execute-non-query db + "CREATE TABLE IF NOT EXISTS dbvolve ( + id BIGINT PRIMARY KEY, + name TEXT NOT NULL, + created TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP + )")) + +(defmethod dbvolve::lock-metadata-table ((db sqlite:sqlite-handle)) + ;; noop due to transaction-based locking + (values)) + +(defmethod dbvolve::find-current-number ((db sqlite:sqlite-handle)) + (or (sqlite:execute-single db "SELECT max(id) FROM dbvolve;") -1)) + +(defmethod dbvolve::dump-current-state ((db sqlite:sqlite-handle)) + (sqlite:execute-to-list db "SELECT * FROM dbvolve;")) + +(defmethod dbvolve::run-evolution + ((db sqlite:sqlite-handle) (evolution dbvolve::evolution/sql)) + (sqlite:execute-script db + (uiop:read-file-string (dbvolve::path evolution)))) + +(defmethod dbvolve::record-evolution ((db sqlite:sqlite-handle) evolution) + (sqlite:execute-non-query db + "INSERT INTO dbvolve (id, name) VALUES (?, ?);" + (dbvolve::id evolution) (dbvolve::name evolution))) + +(defmethod dbvolve::commit ((db sqlite:sqlite-handle)) + ;; noop, handled by transaction wrapper + (values)) +