mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(web/panettone): Add a system for database migrations

Browse source 
Add a system for writing, running, and tracking database
migrations (changes to the database schema) over time, inspired by but
significantly simpler than postmodern-passenger-pigeon.

Migrations can be generated by
running (PANETTONE.MODEL:GENERATE-MIGRATION "name"), and are numerically
ordered lisp files that define (at least) a function called UP, which
runs the migration. The migrations that have been run against the
database are tracked in the `migrations` table, and when the
`(PANETTONE.MODEL:MIGRATE)` function is called (as it is on startup),
all migrations that have not yet been run are run within a transaction.

This includes one migration `1-init-schema.lisp`, which migrates the
database (idempotently) to the current state of the schema.

Change-Id: Id243a47763abea649784b12f25a6d05c2267381c
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11253
Tested-by: BuildkiteCI
Reviewed-by: sterni <sternenseemann@systemli.org>
This commit is contained in:
Aspen Smith 2024-03-24 10:32:15 -04:00 committed by aspen
parent d5f57ac6e6
commit a1a29f7c0b
5 changed files with 228 additions and 37 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
web/panettone/default.nix
View file

@ -1,4 +1,4 @@
{ depot, ... }:
{ depot, pkgs, ... }:
depot.nix.buildLisp.program {
name = "panettone";
@ -9,6 +9,7 @@ depot.nix.buildLisp.program {
cl-ppcre
cl-smtp
cl-who
str
defclass-std
drakma
easy-routes
@ -23,6 +24,14 @@ depot.nix.buildLisp.program {
srcs = [
./panettone.asd
./src/packages.lisp
(pkgs.writeText "build.lisp" ''
(defpackage build
(:use :cl :alexandria)
(:export :*migrations-dir*))
(in-package :build)
(declaim (optimize (safety 3)))
(defvar *migrations-dir* "${./src/migrations}")
'')
./src/util.lisp
./src/css.lisp
./src/email.lisp

23
web/panettone/src/migrations/1-init-schema.lisp Normal file
View file

@ -0,0 +1,23 @@
"Initialize the database schema from before migrations were added"
(defun ddl/create-issue-status ()
"Issue DDL to create the `issue-status' type, if it doesn't exist"
(unless (query (:select (:exists (:select 1
:from 'pg_type
:where (:= 'typname "issue_status"))))
:single)
(query (sql-compile
`(:create-enum issue-status ,panettone.model:+issue-statuses+)))))
(defun ddl/create-tables ()
"Issue DDL to create all tables, if they don't already exist."
(dolist (table '(panettone.model:issue
panettone.model:issue-comment
panettone.model:issue-event
panettone.model:user-settings))
(unless (table-exists-p (dao-table-name table))
(create-table table))))
(defun up ()
(ddl/create-issue-status)
(ddl/create-tables))

211
web/panettone/src/model.lisp
View file

@ -20,6 +20,19 @@ initialised at launch time.")
"Initialises the connection spec used for all Postgres connections."
(setq *pg-spec* (make-pg-spec)))
(defun connect-to-db ()
"Connect using *PG-SPEC* at the top-level, for use during development"
(apply #'connect-toplevel
(loop for v in *pg-spec*
until (eq v :pooled-p)
collect v)))
(defun pg-spec->url (&optional (spec *pg-spec*))
(destructuring-bind (db user password host &key port &allow-other-keys) spec
(format nil
"postgres://~A:~A@~A:~A/~A"
user password host port db)))
;;;
;;; Schema
;;;
@ -77,15 +90,6 @@ initialised at launch time.")
"Type specifier for the status of an `issue'"
(cons 'member +issue-statuses+))
(defun ddl/create-issue-status ()
"Issue DDL to create the `issue-status' type, if it doesn't exist"
(unless (query (:select (:exists (:select 1
:from 'pg_type
:where (:= 'typname "issue_status"))))
:single)
(query (sql-compile
`(:create-enum issue-status ,+issue-statuses+)))))
(defclass has-created-at ()
((created-at :col-type timestamp
:col-default (local-time:now)
@ -192,23 +196,168 @@ its new value will be formatted using ~A into NEW-VALUE"))
(!dao-def)
(!foreign 'issues 'issue-id 'id :on-delete :cascade :on-update :cascade))
(define-constant +all-tables+
'(issue
issue-comment
issue-event
user-settings)
:test #'equal)
(defclass migration ()
((version
:col-type bigint
:primary-key t
:initarg :version
:accessor version)
(name :col-type string :initarg :name :accessor name)
(docstring :col-type string :initarg :docstring :accessor docstring)
(path :col-type string
:type pathname
:initarg :path
:accessor path
:col-export namestring
:col-import parse-namestring)
(package :type keyword :initarg :package :accessor migration-package))
(:metaclass dao-class)
(:keys version)
(:table-name migrations)
(:documentation "Migration scripts that have been run on the database"))
(deftable migration (!dao-def))
(defun ddl/create-tables ()
"Issue DDL to create all tables, if they don't already exist."
(dolist (table +all-tables+)
(unless (table-exists-p (dao-table-name table))
(create-table table))))
;;;
;;; Migrations
;;;
(defun ddl/init ()
"Idempotently initialize the full database schema for Panettone"
(ddl/create-issue-status)
(ddl/create-tables))
(defun ensure-migrations-table ()
"Ensure the migrations table exists"
(unless (table-exists-p (dao-table-name 'migration))
(create-table 'migration)))
(defvar *migrations-dir*
;; Let the nix build override the migrations dir for us
(or (when-let ((package (find-package :build)))
(let ((sym (find-symbol "*MIGRATIONS-DIR*" package)))
(when (boundp sym)
(symbol-value sym))))
"migrations/")
"The directory where migrations are stored")
(defun load-migration-docstring (migration-path)
"If the first form in the file pointed to by `migration-pathname` is
a string, return it, otherwise return NIL."
(handler-case
(with-open-file (s migration-path)
(when-let ((form (read s)))
(when (stringp form) form)))
(t () nil)))
(defun load-migration (path)
(let* ((parts (str:split #\- (pathname-name path) :limit 2))
(version (parse-integer (car parts)))
(name (cadr parts))
(docstring (load-migration-docstring path))
(package (intern (format nil "MIGRATION-~A" version)
:keyword))
(migration (make-instance 'migration
:version version
:name name
:docstring docstring
:path path
:package package)))
(uiop/package:ensure-package package
:use '(#:common-lisp
#:postmodern
#:panettone.model))
(let ((*package* (find-package package)))
(load path))
migration))
(defun run-migration (migration)
(declare (type migration migration))
(with-transaction ()
(format t "Running migration ~A (version ~A)"
(name migration)
(version migration))
(query
(sql-compile
`(:delete-from migrations
:where (= version ,(version migration)))))
(uiop:symbol-call (migration-package migration) :up)
(insert-dao migration)))
(defun list-migration-files ()
(let ((dir (if (char-equal (uiop:last-char *migrations-dir*) #\/)
*migrations-dir*
(concatenate 'string *migrations-dir* "/"))))
(remove-if-not
(lambda (pn) (string= "lisp" (pathname-type pn)))
(uiop:directory-files dir))))
(defun load-migrations ()
(mapcar #'load-migration (list-migration-files)))
(defun generate-migration (name &key documentation)
"Generate a new database migration with the given NAME, optionally
prepopulated with the given DOCUMENTATION.
Returns the file that the migration is located at, as a `pathname'. Write Lisp
code in this migration file to define a function called `up', which will be run
in the context of a database transaction and should perform the migration."
(let* ((version (get-universal-time))
(filename (format nil "~A-~A.lisp"
version
name))
(pathname
(merge-pathnames filename *migrations-dir*)))
(with-open-file (stream pathname
:direction :output
:if-does-not-exist :create)
(when documentation
(format stream "~S~%~%" documentation))
(format stream "(defun up ()~%)"))
pathname))
(defun migrations-already-run ()
"Query the database for a list of migrations that have already been run"
(query-dao 'migration (sql-compile '(:select * :from migrations))))
(define-condition migration-name-mismatch ()
((version :type integer :initarg :version)
(name-in-database :type string :initarg :name-in-database)
(name-in-code :type string :initarg :name-in-code))
(:report
(lambda (cond stream)
(format stream "Migration mismatch: Migration version ~A has name ~S in the database, but we have name ~S"
(slot-value cond 'version)
(slot-value cond 'name-in-database)
(slot-value cond 'name-in-code)))))
(defun migrate ()
"Migrate the database, running all migrations that have not yet been run"
(ensure-migrations-table)
(let* ((all-migrations (load-migrations))
(already-run (migrations-already-run))
(num-migrations-run 0))
(iter (for migration in all-migrations)
(if-let ((existing (find-if (lambda (existing)
(= (version existing)
(version migration)))
already-run)))
(progn
(unless (string= (name migration)
(name existing))
(restart-case
(error 'migration-name-mismatch
:version (version existing)
:name-in-database (name existing)
:name-in-code (name migration))
(skip ()
:report "Skip this migration"
(next-iteration))
(run-and-overwrite ()
:report "Run this migration anyway, overwriting the previous migration"
(run-migration migration))))
(next-iteration))
;; otherwise, run the migration
(run-migration migration))
(incf num-migrations-run))
(format nil "Ran ~A migration~:P" num-migrations-run)))
;;;
;;; Querying
@ -409,12 +558,22 @@ explicitly subscribing to / unsubscribing from individual issues."
(comment
(ddl/init)
(make-instance 'issue :subject "test")
(with-connection *pg-spec*
(create-issue :subject "test"
:author-dn "cn=grfn,ou=users,dc=tvl,dc=fyi")
:author-dn "cn=aspen,ou=users,dc=tvl,dc=fyi"))
(issue-commenter-dns 1)
(issue-subscribers 1)
;; Creating new migrations
(setq *migrations-dir* (merge-pathnames "migrations/"))
(generate-migration "init-schema"
:documentation "Initialize the database schema")
;; Running migrations
(with-connection *pg-spec*
(migrate))
)

6
web/panettone/src/packages.lisp
View file

@ -36,16 +36,16 @@
(:import-from :alexandria :if-let :when-let :define-constant)
(:export
:prepare-db-connections
:ddl/init
:migrate
:*pg-spec*
:user-settings
:user-dn :enable-email-notifications-p :settings-for-user
:update-user-settings :enable-email-notifications
:issue :issue-comment :issue-event
:issue :issue-comment :issue-event :migration
:id :subject :body :author-dn :issue-id :status :created-at :acting-user-dn
:field :previous-value :new-value
:field :previous-value :new-value :+issue-statuses+
:get-issue :issue-exists-p :list-issues :create-issue :set-issue-status
:update-issue :delete-issue :issue-not-found :not-found-id

2
web/panettone/src/panettone.lisp
View file

@ -606,7 +606,7 @@ given subject an body (in a thread, to avoid blocking)"
(defun migrate-db ()
"Migrate the database to the latest version of the schema"
(pomo:with-connection *pg-spec*
(model:ddl/init)))
(model:migrate)))
(defun start-panettone (&key port session-secret)
(authn:initialise-oauth2)