Migration code, model aware of main binary

Sqlite3 application_id and user_version are now set to identify the
database is a builder-web database, and the user_version represents the
schema version.

The 'build' table is extended with a 'main_binary' column. This
represents the main binary artifact from the build. This is decided by
there being exactly one file in bin/.

A migration tool is written that does both migrations and rollbacks, and
migration and rollback is implemented for the above mentioned change.

bin/migrations/builder_migrations.ml

@@ -0,0 +1,87 @@
+open Rresult.R.Infix
+
+let pp_error ppf = function
+  | #Caqti_error.load_or_connect | #Caqti_error.call_or_retrieve as e ->
+    Caqti_error.pp ppf e
+  | `Wrong_version (application_id, user_version) ->
+    Format.fprintf ppf "wrong version { application_id: %ld, user_version: %Ld }"
+      application_id user_version
+
+let or_die exit_code = function
+  | Ok r -> r
+  | Error e ->
+    Format.eprintf "Database error: %a" pp_error e;
+    exit exit_code
+
+let do_database_action action () dbpath =
+  Logs.debug (fun m -> m "Connecting to database...");
+  let ((module Db : Caqti_blocking.CONNECTION) as conn) =
+    Caqti_blocking.connect
+      (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
+    |> or_die 1
+  in
+  Logs.debug (fun m -> m "Connected!");
+  let r =
+    Db.start () >>= fun () ->
+    Logs.debug (fun m -> m "Started database transaction");
+    match action conn with
+    | Ok () ->
+      Logs.debug (fun m -> m "Committing database transaction");
+      Db.commit ()
+    | Error _ as e ->
+      Logs.debug (fun m -> m "Rolling back database transaction");
+      Db.rollback () >>= fun () ->
+      e
+  in
+  or_die 2 r
+
+let help man_format migrations = function
+  | None -> `Help (man_format, None)
+  | Some migration ->
+    if List.mem migration migrations
+    then `Help (man_format, Some migration)
+    else `Error (true, "Unknown migration: " ^ migration)
+
+let dbpath =
+  let doc = "sqlite3 database path" in
+  Cmdliner.Arg.(value &
+                opt non_dir_file "/var/db/builder-web/builder.sqlite3" &
+                info ~doc ["dbpath"])
+
+let setup_log =
+  let setup_log level =
+    Logs.set_level level;
+    Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ());
+  in
+  Cmdliner.Term.(const setup_log $ Logs_cli.level ())
+
+let m20210126 =
+  let doc = "Adds a column 'main_binary' in 'build' (2021-01-26)" in
+  Cmdliner.Term.(const do_database_action $ const M20210126.migrate $ setup_log $ dbpath),
+  Cmdliner.Term.info ~doc "migrate-2021-01-26"
+
+let r20210126 =
+  let doc = "Rollback 'main_binary' in 'build' (2021-01-26)" in
+  Cmdliner.Term.(const do_database_action $ const M20210126.rollback $ setup_log $ dbpath),
+  Cmdliner.Term.info ~doc "rollback-2021-01-26"
+
+let help_cmd =
+  let topic =
+    let doc = "Migration to get help on" in
+    Cmdliner.Arg.(value & pos 0 (some string) None & info ~doc ~docv:"MIGRATION" [])
+  in
+  let doc = "Builder migration help" in
+  Cmdliner.Term.(ret (const help $ man_format $ choice_names $ topic)),
+  Cmdliner.Term.info ~doc "help"
+
+let default_cmd =
+  let doc = "Builder migration command" in
+  Cmdliner.Term.(ret (const help $ man_format $ choice_names $ const None)),
+  Cmdliner.Term.info ~doc "builder-migrations"
+
+let () =
+  Cmdliner.Term.eval_choice
+    default_cmd
+    [help_cmd;
+     m20210126; r20210126]
+  |> Cmdliner.Term.exit

bin/migrations/dune

@@ -0,0 +1,4 @@
+(executable
+ (public_name builder-migrations)
+ (name builder_migrations)
+ (libraries builder_db caqti caqti-driver-sqlite3 caqti.blocking cmdliner logs logs.cli logs.fmt ))

bin/migrations/m20210126.ml

@@ -0,0 +1,110 @@
+let new_user_version =
+  1L
+
+let set_application_id =
+  Caqti_request.exec
+    Caqti_type.unit
+    (Printf.sprintf "PRAGMA application_id = %ld" Builder_db.application_id)
+
+let set_version version =
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    (Printf.sprintf "PRAGMA user_version = %Ld" version)
+
+let alter_build =
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "ALTER TABLE build ADD COLUMN main_binary TEXT"
+
+let all_builds =
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    Caqti_type.int64
+    "SELECT id FROM build"
+
+let bin_artifact =
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.int64
+    Caqti_type.(tup2 int64 string)
+    "SELECT id, filepath FROM build_artifact WHERE build = ? AND filepath LIKE 'bin/%'"
+
+let set_main_binary =
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.(tup2 int64 (option string))
+    "UPDATE build SET main_binary = ?2 WHERE id = ?1"
+
+let migrate (module Db : Caqti_blocking.CONNECTION) =
+  let open Rresult.R.Infix in
+  Db.find Builder_db.get_application_id () >>= fun application_id ->
+  Db.find Builder_db.get_version () >>= fun user_version ->
+  if application_id <> 0l || user_version <> 0L
+  then
+    Error (`Wrong_version (application_id, user_version))
+  else
+    Db.exec alter_build () >>= fun () ->
+    Db.collect_list all_builds () >>= fun builds ->
+    List.fold_left (fun r build ->
+        r >>= fun () ->
+        Db.collect_list bin_artifact build >>= function
+        | [_id, main_binary] ->
+          Db.exec set_main_binary (build, Some main_binary)
+        | [] ->
+          Logs.debug (fun m -> m "No binaries for build id %Ld" build);
+          Ok ()
+        | binaries ->
+          Logs.warn (fun m -> m "More than one binary for build id %Ld" build);
+          Logs.debug (fun m -> m "binaries: [%a]" Fmt.(list ~sep:(any ";") string)
+                         (List.map snd binaries));
+          Ok ())
+      (Ok ())
+      builds >>= fun () ->
+    Db.exec Builder_db.set_application_id () >>= fun () ->
+    Db.exec (set_version new_user_version) ()
+
+let rename_build =
+  Caqti_request.exec
+    Caqti_type.unit
+    "ALTER TABLE build RENAME TO __tmp_build"
+
+let create_build =
+  Caqti_request.exec
+    Caqti_type.unit
+    {| CREATE TABLE build (
+         id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
+         uuid VARCHAR(36) NOT NULL UNIQUE,
+         start_d INTEGER NOT NULL,
+         start_ps INTEGER NOT NULL,
+         finish_d INTEGER NOT NULL,
+         finish_ps INTEGER NOT NULL,
+         result_kind TINYINT NOT NULL,
+         result_code INTEGER,
+         result_msg TEXT,
+         console BLOB NOT NULL,
+         script TEXT NOT NULL,
+         job INTEGER NOT NULL,
+
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+       |}
+
+let rollback_data =
+  Caqti_request.exec
+    Caqti_type.unit
+    {| INSERT INTO build
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
+         result_kind, result_code, result_msg, console, script, job
+       FROM __tmp_build
+    |}
+
+let rollback (module Db : Caqti_blocking.CONNECTION) =
+  let open Rresult.R.Infix in
+  Db.find Builder_db.get_application_id () >>= fun application_id ->
+  Db.find Builder_db.get_version () >>= fun user_version ->
+  if application_id <> Builder_db.application_id || user_version <> new_user_version
+  then
+    Error (`Wrong_version (application_id, user_version))
+  else
+    Db.exec rename_build () >>= fun () ->
+    Db.exec create_build () >>= fun () ->
+    Db.exec rollback_data () >>= fun () ->
+    Db.exec (set_version 0L) ()

db/builder_db.ml

@@ -1,6 +1,11 @@
 module Rep = Representation
 open Rep
 
+let application_id = 1234839235l
+
+(* Please update this when making changes! *)
+let current_version = 1L
+
 type id = Rep.id
 
 type file = {
@@ -22,6 +27,29 @@ let last_insert_rowid =
     id
     "SELECT last_insert_rowid()"
 
+
+let get_application_id =
+  Caqti_request.find
+    Caqti_type.unit
+    Caqti_type.int32
+    "PRAGMA application_id"
+
+let get_version =
+  Caqti_request.find
+    Caqti_type.unit
+    Caqti_type.int64
+    "PRAGMA user_version"
+
+let set_application_id =
+  Caqti_request.exec
+    Caqti_type.unit
+    (Printf.sprintf "PRAGMA application_id = %ld" application_id)
+
+let set_current_version =
+  Caqti_request.exec
+    Caqti_type.unit
+    (Printf.sprintf "PRAGMA user_version = %Ld" current_version)
+
 module Job = struct
   let migrate =
     Caqti_request.exec
@@ -87,11 +115,21 @@ module Build_artifact = struct
       Caqti_type.unit
       "DROP TABLE IF EXISTS build_artifact"
 
+  let get_by_build =
+    Caqti_request.find
+      (Caqti_type.tup2 id fpath)
+      (Caqti_type.tup2 id file)
+      {| SELECT id, filepath, localpath, sha256
+         FROM build_artifact
+         WHERE build = ? AND filepath = ?
+      |}
+
   let get_by_build_uuid =
     Caqti_request.find_opt
       (Caqti_type.tup2 uuid fpath)
-      (Caqti_type.tup2 fpath cstruct)
+      (Caqti_type.tup2 id file)
-      {| SELECT build_artifact.localpath, build_artifact.sha256
+      {| SELECT build_artifact.id, build_artifact.filepath,
+           build_artifact.localpath, build_artifact.sha256
          FROM build_artifact
          INNER JOIN build ON build.id = build_artifact.build
          WHERE build.uuid = ? AND build_artifact.filepath = ?
@@ -176,6 +214,7 @@ module Build = struct
     result : Builder.execution_result;
     console : (int * string) list;
     script : string;
+    main_binary : Fpath.t option;
     job_id : id;
   }
 
@@ -190,14 +229,16 @@ module Build = struct
                        (tup2
                           execution_result
                           console)
-                       string)
+                       (tup2
+                          string
+                          (option Rep.fpath)))
                     id)
     in
-    let encode { uuid; start; finish; result; console; script; job_id } =
+    let encode { uuid; start; finish; result; console; script; main_binary; job_id } =
-      Ok ((uuid, (start, finish), (result, console), script), job_id)
+      Ok ((uuid, (start, finish), (result, console), (script, main_binary)), job_id)
     in
-    let decode ((uuid, (start, finish), (result, console), script), job_id) =
+    let decode ((uuid, (start, finish), (result, console), (script, main_binary)), job_id) =
-      Ok { uuid; start; finish; result; console; script; job_id }
+      Ok { uuid; start; finish; result; console; script; main_binary; job_id }
     in
     Caqti_type.custom ~encode ~decode rep
 
@@ -207,6 +248,7 @@ module Build = struct
       start : Ptime.t;
       finish : Ptime.t;
       result : Builder.execution_result;
+      main_binary : Fpath.t option;
       job_id : id;
     }
 
@@ -215,16 +257,18 @@ module Build = struct
         Caqti_type.(tup2
                      (tup4
                        uuid
+                       (tup2
                           Rep.ptime
-                       Rep.ptime
+                          Rep.ptime)
-                       execution_result)
+                       execution_result
+                       (option Rep.fpath))
                      id)
       in
-      let encode { uuid; start; finish; result; job_id } =
+      let encode { uuid; start; finish; result; main_binary; job_id } =
-        Ok ((uuid, start, finish, result), job_id)
+        Ok ((uuid, (start, finish), result, main_binary), job_id)
       in
-      let decode ((uuid, start, finish, result), job_id) =
+      let decode ((uuid, (start, finish), result, main_binary), job_id) =
-        Ok { uuid; start; finish; result; job_id }
+        Ok { uuid; start; finish; result; main_binary; job_id }
       in
       Caqti_type.custom ~encode ~decode rep
   end
@@ -244,6 +288,7 @@ module Build = struct
            result_msg TEXT,
            console BLOB NOT NULL,
            script TEXT NOT NULL,
+           main_binary TEXT,
            job INTEGER NOT NULL,
 
            FOREIGN KEY(job) REFERENCES job(id)
@@ -261,7 +306,7 @@ module Build = struct
       t
       {| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
                 result_kind, result_code, result_msg,
-                console, script, job
+                console, script, main_binary, job
            FROM build
            WHERE id = ?
         |}
@@ -272,7 +317,7 @@ module Build = struct
       (Caqti_type.tup2 id t)
       {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
                   result_kind, result_code, result_msg,
-                  console, script, job
+                  console, script, main_binary, job
            FROM build
            WHERE uuid = ?
         |}
@@ -283,7 +328,7 @@ module Build = struct
       (Caqti_type.tup2 id t)
       {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
                   result_kind, result_code, result_msg, console,
-                  script, job
+                  script, main_binary, job
            FROM build
            WHERE job = ?
            ORDER BY start_d DESC, start_ps DESC
@@ -295,7 +340,7 @@ module Build = struct
       (Caqti_type.tup2
          id Meta.t)
       {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
-                  result_kind, result_code, result_msg, job
+                  result_kind, result_code, result_msg, main_binary, job
            FROM build
            WHERE job = ?
            ORDER BY start_d DESC, start_ps DESC
@@ -308,7 +353,8 @@ module Build = struct
          id Meta.t)
       {| SELECT build.id, build.uuid,
                   build.start_d, build.start_ps, build.finish_d, build.finish_ps,
-                  build.result_kind, build.result_code, build.result_msg, build.job
+                  build.result_kind, build.result_code, build.result_msg,
+                  build.main_binary, build.job
            FROM build, job
            WHERE job.name = ? AND build.job = job.id
            ORDER BY start_d DESC, start_ps DESC
@@ -320,7 +366,7 @@ module Build = struct
       t
       {| INSERT INTO build
            (uuid, start_d, start_ps, finish_d, finish_ps,
-           result_kind, result_code, result_msg, console, script, job)
+           result_kind, result_code, result_msg, console, script, main_binary, job)
            VALUES
            (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
         |}
@@ -394,6 +440,8 @@ let migrate = [
   Build_artifact.migrate;
   Build_file.migrate;
   User.migrate;
+  set_current_version;
+  set_application_id;
 ]
 
 let rollback = [
@@ -402,4 +450,8 @@ let rollback = [
   Build_artifact.rollback;
   Build.rollback;
   Job.rollback;
+  Caqti_request.exec Caqti_type.unit
+    "PRAGMA user_version = 0";
+  Caqti_request.exec Caqti_type.unit
+    "PRAGMA application_id = 0";
 ]

db/builder_db.mli

@@ -7,6 +7,22 @@ type file = {
 }
 val file : file Caqti_type.t
 
+val application_id : int32
+
+val current_version : int64
+
+val get_application_id :
+  (unit, int32, [< `Many | `One | `Zero > `One ]) Caqti_request.t
+
+val set_application_id :
+  (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+
+val get_version :
+  (unit, int64, [< `Many | `One | `Zero > `One ]) Caqti_request.t
+
+val set_current_version :
+  (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
+
 val last_insert_rowid :
   (unit, id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
 
@@ -35,8 +51,12 @@ module Build_artifact : sig
   val rollback :
     (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
 
+  val get_by_build :
+    (id * Fpath.t, id * file,
+     [< `Many | `One | `Zero > `One ]) Caqti_request.t
+
   val get_by_build_uuid :
-    (Uuidm.t * Fpath.t, Fpath.t * Cstruct.t,
+    (Uuidm.t * Fpath.t, id * file,
      [< `Many | `One | `Zero > `One `Zero ])
       Caqti_request.t
   val get_all_by_build :
@@ -74,6 +94,7 @@ sig
     result : Builder.execution_result;
     console : (int * string) list;
     script : string;
+    main_binary : Fpath.t option;
     job_id : id;
   }
   module Meta :
@@ -83,6 +104,7 @@ sig
       start : Ptime.t;
       finish : Ptime.t;
       result : Builder.execution_result;
+      main_binary : Fpath.t option;
       job_id : id;
     }
   end

lib/model.ml

@@ -32,8 +32,8 @@ let read_file filepath =
 let build_artifact build filepath (module Db : CONN) =
   Db.find_opt Builder_db.Build_artifact.get_by_build_uuid (build, filepath)
   >>= function
-  | Some (localpath, sha256) ->
+  | Some (_id, file) ->
-    read_file localpath >|= fun data -> data, sha256
+    read_file file.Builder_db.localpath >|= fun data -> data, file.Builder_db.sha256
   | None ->
     Lwt.return_error `Not_found
 
@@ -49,6 +49,13 @@ let build_exists uuid (module Db : CONN) =
   Db.find_opt Builder_db.Build.get_by_uuid uuid >|=
   Option.is_some
 
+let main_binary id { Builder_db.Build.main_binary; _ } (module Db : CONN) =
+  match main_binary with
+  | None -> Lwt_result.return None
+  | Some main_binary ->
+    Db.find Builder_db.Build_artifact.get_by_build (id, main_binary) >|= fun (_id, file) ->
+    Some file
+
 let job job (module Db : CONN) =
   Db.collect_list Builder_db.Build.get_all_meta_by_name job
 
@@ -115,10 +122,28 @@ let add_build
   let open Builder_db in
   let job_name = job.Builder.name in
   save_all basedir exec >>= fun (artifacts, input_files) ->
+  let main_binary =
+    match List.find_all
+            (fun file ->
+               Fpath.is_prefix
+                 (Fpath.v "bin/")
+                 file.Builder_db.filepath)
+            artifacts with
+    | [ main_binary ] -> Some main_binary.localpath
+    | [] ->
+      Log.debug (fun m -> m "Zero binaries for build %a" Uuidm.pp uuid);
+      None
+    | binaries ->
+      Log.debug (fun m -> m "Multiple binaries for build %a: %a" Uuidm.pp uuid
+                    Fmt.(list ~sep:(any ",") Fpath.pp)
+                    (List.map (fun f -> f.filepath) binaries));
+      None
+  in
   Db.exec Job.try_add job_name >>= fun () ->
   Db.find Job.get_id_by_name job_name >>= fun job_id ->
   Db.exec Build.add { Build.uuid; start; finish; result;
-                      console; script = job.Builder.script; job_id } >>= fun () ->
+                      console; script = job.Builder.script;
+                      main_binary; job_id } >>= fun () ->
   Db.find last_insert_rowid () >>= fun id ->
   List.fold_left
     (fun r file ->

lib/model.mli

@@ -14,6 +14,9 @@ val build : Uuidm.t -> Caqti_lwt.connection ->
 val build_exists : Uuidm.t -> Caqti_lwt.connection ->
   (bool, [> error ]) result Lwt.t
 
+val main_binary : Builder_db.id -> Builder_db.Build.t -> Caqti_lwt.connection ->
+  (Builder_db.file option, [> error ]) result Lwt.t
+
 val job : string -> Caqti_lwt.connection ->
   ((Builder_db.id * Builder_db.Build.Meta.t) list, [> error ]) result Lwt.t
 

lib/views.ml

@@ -116,7 +116,7 @@ let job name builds =
 
 let job_build
   name
-  { Builder_db.Build.uuid = _; start; finish; result; console; script; job_id = _ }
+  { Builder_db.Build.uuid = _; start; finish; result; console; script; main_binary = _; job_id = _ }
   artifacts
   =
   let ptime_pp = Ptime.pp_human () in