Refactor migrations and don't enable foreign keys

Each migration is, for the most part, a module that exposes expected
database version numbers, command identifier and documentation. This
results in all information about the migration and rollback are
found in the module itself, and builder_migrations.ml only has to
reference the module.

Some migrations require foreign keys constraints are disabled. It is not
possible to enable or disable foreign key constraints inside a
transaction.

bin/migrations/builder_migrations.ml

@@ -1,5 +1,18 @@
 open Rresult.R.Infix
 
+type action = Fpath.t -> Caqti_blocking.connection ->
+  (unit, [ Caqti_error.call_or_retrieve | `Wrong_version of int32 * int64 | `Msg of string ]) result
+
+module type MIGRATION = sig
+  val new_version : int64
+  val old_version : int64
+  val identifier : string
+  val migrate_doc : string
+  val rollback_doc : string
+  val migrate : action
+  val rollback : action
+end
+
 let pp_error ppf = function
   | #Caqti_error.load_or_connect | #Caqti_error.call_or_retrieve as e ->
     Caqti_error.pp ppf e
@@ -15,11 +28,6 @@ let or_die exit_code = function
     Format.eprintf "Database error: %a" pp_error e;
     exit exit_code
 
-let foreign_keys =
-  Caqti_request.exec
-    Caqti_type.unit
-    "PRAGMA foreign_keys = ON"
-
 let do_database_action action () datadir =
   let datadir = Fpath.v datadir in
   let dbpath = Fpath.(datadir / "builder.sqlite3") in
@@ -31,7 +39,6 @@ let do_database_action action () datadir =
   in
   Logs.debug (fun m -> m "Connected!");
   let r =
-    Db.exec foreign_keys () >>= fun () ->
     Db.start () >>= fun () ->
     Logs.debug (fun m -> m "Started database transaction");
     match action datadir conn with
@@ -65,45 +72,17 @@ let setup_log =
   in
   Cmdliner.Term.(const setup_log $ Logs_cli.level ())
 
-let m20210126 =
+let actions (module M : MIGRATION) =
-  let doc = "Adds a column 'main_binary' in 'build' (2021-01-26)" in
+  let c s = s ^ "-" ^ M.identifier in
-  Cmdliner.Term.(const do_database_action $ const M20210126.migrate $ setup_log $ datadir),
+  let v doc from_ver to_ver = Printf.sprintf "%s (DB version %Ld -> %Ld)" doc from_ver to_ver in
-  Cmdliner.Term.info ~doc "migrate-2021-01-26"
+  [
-
+    (Cmdliner.Term.(const do_database_action $ const M.migrate $ setup_log $ datadir),
-let r20210126 =
+     Cmdliner.Term.info ~doc:(v M.migrate_doc M.old_version M.new_version)
-  let doc = "Rollback 'main_binary' in 'build' (2021-01-26)" in
+       (c "migrate"));
-  Cmdliner.Term.(const do_database_action $ const M20210126.rollback $ setup_log $ datadir),
+    (Cmdliner.Term.(const do_database_action $ const M.rollback $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "rollback-2021-01-26"
+     Cmdliner.Term.info ~doc:(v M.rollback_doc M.new_version M.old_version)
-
+       (c "rollback"));
-let m20210202 =
+  ]
-  let doc = "Adds an index 'job_build_idx' on 'build' (2021-02-02)" in
-  Cmdliner.Term.(const do_database_action $ const M20210202.migrate $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "migrate-2021-02-02"
-
-let r20210202 =
-  let doc = "Rollback index 'job_build_idx' on 'build' (2021-02-02)" in
-  Cmdliner.Term.(const do_database_action $ const M20210202.rollback $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "rollback-2021-02-02"
-
-let m20210216 =
-  let doc = "Changes 'user' for scrypt hashed passwords (NB: Destructive!!) (2021-02-16)" in
-  Cmdliner.Term.(const do_database_action $ const M20210216.migrate $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "migrate-2021-02-16"
-
-let r20210216 =
-  let doc = "Rollback scrypt hashed passwords (NB: Destructive!!) (2021-02-16)" in
-  Cmdliner.Term.(const do_database_action $ const M20210216.rollback $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "rollback-2021-02-16"
-
-let m20210218 =
-  let doc = "Adds column 'size' to 'build_file' and 'build_artifact' (2021-02-18)" in
-  Cmdliner.Term.(const do_database_action $ const M20210218.migrate $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "migrate-2021-02-18"
-
-let r20210218 =
-  let doc = "Roll back column 'size' in 'build_file' and 'build_artifact' (2021-02-18)" in
-  Cmdliner.Term.(const do_database_action $ const M20210218.rollback $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "rollback-2021-02-18"
 
 let f20210308 =
   let doc = "Remove broken builds as fixed in commit a57798f4c02eb4d528b90932ec26fb0b718f1a13. \
@@ -111,56 +90,6 @@ let f20210308 =
   Cmdliner.Term.(const do_database_action $ const M20210308.fixup $ setup_log $ datadir),
   Cmdliner.Term.info ~doc "fixup-2021-03-08"
 
-let m20210427 =
-  let doc = "Adds an index 'idx_build_job_start' on 'build' (2021-04-27)" in
-  Cmdliner.Term.(const do_database_action $ const M20210427.migrate $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "migrate-2021-04-27"
-
-let r20210427 =
-  let doc = "Rollback index 'idx_build_job_start'' on 'build' (2021-04-27)" in
-  Cmdliner.Term.(const do_database_action $ const M20210427.rollback $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "rollback-2021-04-27"
-
-let m20210531 =
-  let doc = "Remove datadir from build_artifact.localpath" in
-  Cmdliner.Term.(const do_database_action $ const M20210531.migrate $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "migrate-2021-05-31"
-
-let r20210531 =
-  let doc = "Add datadir to build_artifact.localpath" in
-  Cmdliner.Term.(const do_database_action $ const M20210531.rollback $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "rollback-2021-05-31"
-
-let m20210602 =
-  let doc = "build.main_binary foreign key" in
-  Cmdliner.Term.(const do_database_action $ const M20210602.migrate $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "migrate-2021-06-02"
-
-let r20210602 =
-  let doc = "build.main_binary filepath" in
-  Cmdliner.Term.(const do_database_action $ const M20210602.rollback $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "rollback-2021-06-02"
-
-let m20210608 =
-  let doc = "add access list" in
-  Cmdliner.Term.(const do_database_action $ const M20210608.migrate $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "migrate-2021-06-08"
-
-let r20210608 =
-  let doc = "remove access list" in
-  Cmdliner.Term.(const do_database_action $ const M20210608.rollback $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "rollback-2021-06-08"
-
-let m20210609 =
-  let doc = "add user column to build" in
-  Cmdliner.Term.(const do_database_action $ const M20210609.migrate $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "migrate-2021-06-09"
-
-let r20210609 =
-  let doc = "remove user column to build" in
-  Cmdliner.Term.(const do_database_action $ const M20210609.rollback $ setup_log $ datadir),
-  Cmdliner.Term.info ~doc "rollback-2021-06-09"
-
 let help_cmd =
   let topic =
     let doc = "Migration to get help on" in
@@ -178,16 +107,17 @@ let default_cmd =
 let () =
   Cmdliner.Term.eval_choice
     default_cmd
-    [ help_cmd;
+    (List.concat [
-      m20210126; r20210126;
+        [ help_cmd ];
-      m20210202; r20210202;
+        actions (module M20210126);
-      m20210216; r20210216;
+        actions (module M20210202);
-      m20210218; r20210218;
+        actions (module M20210216);
-      f20210308;
+        actions (module M20210218);
-      m20210427; r20210427;
+        [ f20210308 ];
-      m20210531; r20210531;
+        actions (module M20210427);
-      m20210602; r20210602;
+        actions (module M20210531);
-      m20210608; r20210608;
+        actions (module M20210602);
-      m20210609; r20210609;
+        actions (module M20210608);
-    ]
+        actions (module M20210609);
+      ])
   |> Cmdliner.Term.exit

bin/migrations/grej.ml

@@ -21,3 +21,9 @@ let list_iter_result f xs =
     (fun r x -> r >>= fun () -> f x)
     (Ok ())
     xs
+
+let foreign_keys on =
+  let on = if on then "ON" else "OFF" in
+  Caqti_request.exec
+    Caqti_type.unit
+    (Printf.sprintf "PRAGMA foreign_keys = %s" on)

bin/migrations/m20210126.ml

@@ -1,5 +1,7 @@
-let new_user_version =
+let new_version = 1L and old_version = 0L
-  1L
+let identifier = "2021-01-26"
+let migrate_doc = "add column main_binary to build"
+let rollback_doc = "remove column main_binary from build"
 
 let set_application_id =
   Caqti_request.exec
@@ -47,7 +49,7 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
         Ok ())
     builds >>= fun () ->
   Db.exec Builder_db.set_application_id () >>= fun () ->
-  Db.exec (Grej.set_version new_user_version) ()
+  Db.exec (Grej.set_version new_version) ()
 
 let rename_build =
   Caqti_request.exec
@@ -86,8 +88,8 @@ let rollback_data =
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   let open Rresult.R.Infix in
-  Grej.check_version ~user_version:new_user_version (module Db) >>= fun () ->
+  Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
   Db.exec rename_build () >>= fun () ->
   Db.exec create_build () >>= fun () ->
   Db.exec rollback_data () >>= fun () ->
-  Db.exec (Grej.set_version 0L) ()
+  Db.exec (Grej.set_version old_version) ()

bin/migrations/m20210202.ml

@@ -1,3 +1,8 @@
+let old_version = 1L and new_version = 1L
+let identifier = "2021-02-02"
+let migrate_doc = "add index job_build_idx on build"
+let rollback_doc = "rollback index job_build_idx on build"
+
 open Rresult.R.Infix
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =

bin/migrations/m20210216.ml

@@ -1,5 +1,8 @@
-let old_user_version = 1L
+let old_version = 1L
-let new_user_version = 2L
+let new_version = 2L
+let identifier = "2021-02-16"
+let migrate_doc = "change to scrypt hashed passwords (NB: destructive!!)"
+let rollback_doc = "rollback scrypt hashed passwords (NB: destructive!!)"
 
 let drop_user =
   Caqti_request.exec ~oneshot:true
@@ -34,14 +37,14 @@ let old_user =
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   let open Rresult.R.Infix in
-  Grej.check_version ~user_version:old_user_version (module Db) >>= fun () ->
+  Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.exec drop_user () >>= fun () ->
   Db.exec new_user () >>= fun () ->
-  Db.exec (Grej.set_version new_user_version) ()
+  Db.exec (Grej.set_version new_version) ()
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   let open Rresult.R.Infix in
-  Grej.check_version ~user_version:new_user_version (module Db) >>= fun () ->
+  Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
   Db.exec drop_user () >>= fun () ->
   Db.exec old_user () >>= fun () ->
-  Db.exec (Grej.set_version old_user_version) ()
+  Db.exec (Grej.set_version old_version) ()

bin/migrations/m20210218.ml

@@ -1,5 +1,8 @@
-let old_user_version = 2L
+let old_version = 2L
-let new_user_version = 3L
+let new_version = 3L
+let identifier = "2021-02-18"
+let migrate_doc = "add column size to build_file and build_artifact"
+let rollback_doc = "remove column size to build_file and build_artifact"
 
 let new_build_artifact =
   Caqti_request.exec ~oneshot:true
@@ -81,7 +84,7 @@ let rename_build_file =
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   let open Rresult.R.Infix in
-  Grej.check_version ~user_version:old_user_version (module Db) >>= fun () ->
+  Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.exec new_build_artifact () >>= fun () ->
   Db.rev_collect_list collect_build_artifact () >>= fun build_artifacts ->
   Grej.list_iter_result
@@ -104,7 +107,7 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Db.exec drop_build_file () >>= fun () ->
   Db.exec rename_build_file () >>= fun () ->
 
-  Db.exec (Grej.set_version new_user_version) ()
+  Db.exec (Grej.set_version new_version) ()
 
 let old_build_artifact =
   Caqti_request.exec ~oneshot:true
@@ -148,7 +151,7 @@ let copy_build_file =
 
 let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   let open Rresult.R.Infix in
-  Grej.check_version ~user_version:new_user_version (module Db) >>= fun () ->
+  Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
   Db.exec old_build_artifact () >>= fun () ->
   Db.exec copy_build_artifact () >>= fun () ->
   Db.exec drop_build_artifact () >>= fun () ->
@@ -159,4 +162,4 @@ let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   Db.exec drop_build_file () >>= fun () ->
   Db.exec rename_build_file () >>= fun () ->
 
-  Db.exec (Grej.set_version old_user_version) ()
+  Db.exec (Grej.set_version old_version) ()

bin/migrations/m20210427.ml

@@ -1,3 +1,8 @@
+let old_version = 3L and new_version = 3L
+let identifier = "2021-04-27"
+let migrate_doc = "add index idx_build_job_start on build"
+let rollback_doc = "rollback index idx_build_job_start on build"
+
 open Rresult.R.Infix
 
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
@@ -11,7 +16,7 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
       Caqti_type.unit
       "DROP INDEX IF EXISTS job_build_idx"
   in
-  Grej.check_version ~user_version:3L (module Db) >>= fun () ->
+  Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.exec rm_job_build_idx () >>= fun () ->
   Db.exec idx_build_job_start ()
 
@@ -26,6 +31,6 @@ let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
       Caqti_type.unit
       "DROP INDEX IF EXISTS idx_build_job_start"
   in
-  Grej.check_version ~user_version:3L (module Db) >>= fun () ->
+  Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
   Db.exec rm_idx_build_job_start () >>= fun () ->
   Db.exec job_build_idx ()

bin/migrations/m20210531.ml

@@ -1,5 +1,8 @@
 let old_version = 3L
 let new_version = 4L
+let identifier = "2021-05-31"
+let migrate_doc = "remove datadir prefix from build_artifact.localpath"
+let rollback_doc = "add datadir prefix to build_artifact.localpath"
 
 let build_artifacts =
   Caqti_request.collect ~oneshot:true

bin/migrations/m20210602.ml

@@ -1,4 +1,7 @@
 let old_version = 4L and new_version = 5L
+let identifier = "2021-06-02"
+let migrate_doc = "build.main_binary foreign key"
+let rollback_doc = "build.main_binary filepath"
 
 let idx_build_job_start =
   Caqti_request.exec Caqti_type.unit

bin/migrations/m20210608.ml

@@ -1,6 +1,7 @@
-open Rresult.R.Infix
-
 let new_version = 6L and old_version = 5L
+let identifier = "2021-06-08"
+let migrate_doc = "add access list"
+let rollback_doc = "remove access list"
 
 let new_user =
   Caqti_request.exec
@@ -82,6 +83,8 @@ let rollback_access_list =
    Caqti_type.unit
    "DROP TABLE IF EXISTS access_list"
 
+open Rresult.R.Infix
+
 let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
   Db.exec new_user () >>= fun () ->

bin/migrations/m20210609.ml

@@ -1,4 +1,7 @@
 let new_version = 7L and old_version = 6L
+let identifier = "2021-06-09"
+let migrate_doc = "add user column to build"
+let rollback_doc = "remove user column from build"
 
 let idx_build_job_start =
   Caqti_request.exec Caqti_type.unit