6878b5690d2e

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

--- 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 <steve@stevelosh.com>"
+
+  :depends-on (:dbvolve :sqlite)
+
+  :serial t
+  :components ((:module "src" :serial t
+                :components ((:file "sqlite")))))

--- 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 --------------------------------------------------------------------
+
+

--- /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))
+