Builder_db: use foreign key for build.main_binary

bin/migrations/builder_migrations.ml

@@ -125,6 +125,16 @@ let r20210531 =
   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 help_cmd =
   let topic =
     let doc = "Migration to get help on" in
@@ -150,5 +160,6 @@ let () =
       f20210308;
       m20210427; r20210427;
       m20210531; r20210531;
+      m20210602; r20210602;
     ]
   |> Cmdliner.Term.exit

bin/migrations/m20210602.ml

@@ -0,0 +1,143 @@
+let old_version = 4L and new_version = 5L
+
+let new_build =
+    Caqti_request.exec
+      Caqti_type.unit
+      {| CREATE TABLE new_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,
+           main_binary INTEGER,
+           job INTEGER NOT NULL,
+
+           FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
+           FOREIGN KEY(job) REFERENCES job(id)
+         )
+      |}
+
+let old_build = 
+    Caqti_request.exec
+      Caqti_type.unit
+      {| CREATE TABLE new_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,
+           main_binary TEXT,
+           job INTEGER NOT NULL,
+
+           FOREIGN KEY(job) REFERENCES job(id)
+         )
+      |}
+
+let collect_old_build =
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    Caqti_type.(tup3 Builder_db.Rep.id
+      (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option string)))
+      Builder_db.Rep.id)
+    {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg,
+              console, script, main_binary, job
+       FROM build |}
+
+let insert_new_build =
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.(tup3 Builder_db.Rep.id
+      (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option Builder_db.Rep.id)))
+      Builder_db.Rep.id)
+    {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind,
+                              result_code, result_msg, console, script, main_binary, job)
+       VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |}
+
+let drop_build =
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "DROP TABLE build"
+
+let rename_build =
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    "ALTER TABLE new_build RENAME TO build"
+
+let find_main_artifact_id =
+  Caqti_request.find ~oneshot:true
+    Caqti_type.(tup2 Builder_db.Rep.id string)
+    Builder_db.Rep.id
+    "SELECT id FROM build_artifact WHERE build = ?1 AND filepath = ?2"
+
+let find_main_artifact_filepath =
+  Caqti_request.find ~oneshot:true
+    Builder_db.Rep.id
+    Caqti_type.string
+    "SELECT filepath FROM build_artifact WHERE id = ?"
+
+let collect_new_build =
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    Caqti_type.(tup3 Builder_db.Rep.id
+      (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option Builder_db.Rep.id)))
+      Builder_db.Rep.id)
+    {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg,
+              console, script, main_binary, job
+       FROM build |}
+  
+let insert_old_build =
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.(tup3 Builder_db.Rep.id
+      (tup3 (tup4 string int64 int64 int64) (tup4 int64 int (option int) (option string)) (tup3 octets string (option string)))
+      Builder_db.Rep.id)
+    {| INSERT INTO new_build (id, uuid, start_d, start_ps, finish_d, finish_ps, result_kind,
+                              result_code, result_msg, console, script, main_binary, job)
+       VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |}
+
+let migrate _ (module Db : Caqti_blocking.CONNECTION) =
+  let open Rresult.R.Infix in
+  Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
+  Db.exec new_build () >>= fun () ->
+  Db.rev_collect_list collect_old_build () >>= fun builds ->
+  Grej.list_iter_result
+    (fun (id, ((uuid, start_d, start_ps, finish_d), (finish_ps, result_kind, result_code, result_msg), (console, script, main_binary)), job) ->
+       (match main_binary with
+         | None -> Ok None
+         | Some path -> Db.find find_main_artifact_id (id, path) >>| fun id -> Some id)
+       >>= fun main_binary_id ->
+       Db.exec insert_new_build
+         (id, ((uuid, start_d, start_ps, finish_d), (finish_ps, result_kind, result_code, result_msg), (console, script, main_binary_id)), job)) 
+    builds >>= fun () ->
+  Db.exec drop_build () >>= fun () ->
+  Db.exec rename_build () >>= fun () ->
+  Db.exec (Grej.set_version new_version) ()
+
+ 
+let rollback _ (module Db : Caqti_blocking.CONNECTION) =
+  let open Rresult.R.Infix in
+  Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
+  Db.exec old_build () >>= fun () ->
+  Db.rev_collect_list collect_new_build () >>= fun builds ->
+  Grej.list_iter_result
+    (fun (id, ((uuid, start_d, start_ps, finish_d), (finish_ps, result_kind, result_code, result_msg), (console, script, main_binary)), job) ->
+       (match main_binary with
+         | None -> Ok None
+         | Some main_binary_id -> Db.find find_main_artifact_filepath main_binary_id >>| fun filepath -> Some filepath)
+       >>= fun filepath ->
+       Db.exec insert_old_build
+         (id, ((uuid, start_d, start_ps, finish_d), (finish_ps, result_kind, result_code, result_msg), (console, script, filepath)), job)) 
+    builds >>= fun () ->
+  Db.exec drop_build () >>= fun () ->
+  Db.exec rename_build () >>= fun () ->
+  Db.exec (Grej.set_version old_version) ()

db/builder_db.ml

@@ -4,7 +4,7 @@ open Rep
 let application_id = 1234839235l
 
 (* Please update this when making changes! *)
-let current_version = 4L
+let current_version = 5L
 
 type id = Rep.id
 
@@ -211,7 +211,7 @@ module Build = struct
     result : Builder.execution_result;
     console : (int * string) list;
     script : string;
-    main_binary : Fpath.t option;
+    main_binary : id option;
     job_id : id;
   }
 
@@ -228,7 +228,7 @@ module Build = struct
                           console)
                        (tup2
                           string
-                          (option Rep.fpath)))
+                          (option Rep.id)))
                     id)
     in
     let encode { uuid; start; finish; result; console; script; main_binary; job_id } =
@@ -245,7 +245,7 @@ module Build = struct
       start : Ptime.t;
       finish : Ptime.t;
       result : Builder.execution_result;
-      main_binary : Fpath.t option;
+      main_binary : id option;
       job_id : id;
     }
 
@@ -258,7 +258,7 @@ module Build = struct
                           Rep.ptime
                           Rep.ptime)
                        execution_result
-                       (option Rep.fpath))
+                       (option Rep.id))
                      id)
       in
       let encode { uuid; start; finish; result; main_binary; job_id } =
@@ -285,9 +285,10 @@ module Build = struct
            result_msg TEXT,
            console BLOB NOT NULL,
            script TEXT NOT NULL,
-           main_binary TEXT,
+           main_binary INTEGER,
            job INTEGER NOT NULL,
 
+           FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
            FOREIGN KEY(job) REFERENCES job(id)
          )
       |}
@@ -357,7 +358,7 @@ module Build = struct
                 build_artifact.filepath, build_artifact.localpath, build_artifact.sha256, build_artifact.size
            FROM build, job
            LEFT JOIN build_artifact ON
-             build_artifact.build = build.id AND build.main_binary = build_artifact.filepath
+             build.main_binary = build_artifact.id
            WHERE job.name = ? AND build.job = job.id
            ORDER BY start_d DESC, start_ps DESC
         |}
@@ -376,7 +377,7 @@ module Build = struct
            a.filepath, a.localpath, a.sha256, a.size
          FROM build b
          LEFT JOIN build_artifact a ON
-           a.build = b.id AND b.main_binary = a.filepath
+           b.main_binary = a.id
          WHERE b.job = ?
          ORDER BY start_d DESC, start_ps DESC
          LIMIT 1
@@ -436,6 +437,11 @@ module Build = struct
          LIMIT 1
       |}
 
+  let set_main_binary =
+    Caqti_request.exec
+      (Caqti_type.tup2 id id)
+      "UPDATE build SET main_binary = ?2 WHERE id = ?1"
+
   let remove =
     Caqti_request.exec
       id

db/builder_db.mli

@@ -112,7 +112,7 @@ sig
     result : Builder.execution_result;
     console : (int * string) list;
     script : string;
-    main_binary : Fpath.t option;
+    main_binary : id option;
     job_id : id;
   }
   module Meta :
@@ -122,7 +122,7 @@ sig
       start : Ptime.t;
       finish : Ptime.t;
       result : Builder.execution_result;
-      main_binary : Fpath.t option;
+      main_binary : id option;
       job_id : id;
     }
   end
@@ -155,6 +155,7 @@ sig
   val add : (t, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val get_by_hash :
     (Cstruct.t, string * t, [< `Many | `One | `Zero > `One `Zero]) Caqti_request.t
+  val set_main_binary : (id * id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
   val remove : (id, unit, [< `Many | `One | `Zero > `Zero]) Caqti_request.t
 end
 

lib/model.ml

@@ -196,30 +196,13 @@ let add_build
       x
   in
   or_cleanup (save_all staging_dir 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.filepath
-    | [] ->
-      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
   let r =
     Db.start () >>= fun () ->
     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;
-                        main_binary; job_id } >>= fun () ->
+                        main_binary = None; job_id } >>= fun () ->
     Db.find last_insert_rowid () >>= fun id ->
     List.fold_left
       (fun r file ->
@@ -233,6 +216,17 @@ let add_build
          Db.exec Build_file.add (file, id))
       (Lwt_result.return ())
       input_files >>= fun () ->
+    Db.collect_list Build_artifact.get_all_by_build id >>= fun artifacts ->
+    (match List.filter (fun (_, p) -> Fpath.(is_prefix (v "bin/") p.filepath)) artifacts with
+     | [ (build_artifact_id, _) ] -> Db.exec Build.set_main_binary (id, build_artifact_id)
+     | [] ->
+       Log.debug (fun m -> m "Zero binaries for build %a" Uuidm.pp uuid);
+       Lwt_result.return ()
+     | xs ->
+       Log.warn (fun m -> m "Multiple binaries for build %a: %a" Uuidm.pp uuid
+                    Fmt.(list ~sep:(any ",") Fpath.pp)
+                    (List.map (fun (_, a) -> a.filepath) xs));
+       Lwt_result.return ()) >>= fun () ->
     Db.commit () >>= fun () ->
     commit_files datadir staging_dir job_name uuid
   in

test/builder_db.ml

@@ -153,10 +153,12 @@ let add_test_build (module Db : CONN) =
     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;
-                        main_binary = Some main_binary.filepath;
+                        main_binary = None;
                         job_id } >>= fun () ->
     Db.find last_insert_rowid () >>= fun id ->
     Db.exec Build_artifact.add (main_binary, id) >>= fun () ->
+    Db.find last_insert_rowid () >>= fun main_binary_id ->
+    Db.exec Build.set_main_binary (id, main_binary_id) >>= fun () ->
     Db.commit ()
   in
   Rresult.R.kignore_error
@@ -218,10 +220,12 @@ let add_second_build (module Db : CONN) =
   Db.start () >>= fun () ->
   Db.find Job.get_id_by_name job_name >>= fun job_id ->
   Db.exec Build.add { Build.uuid; start; finish; result; console; script;
-                      main_binary = Some main_binary.filepath; job_id;
+                      main_binary = None; job_id;
                     } >>= fun () ->
   Db.find last_insert_rowid () >>= fun id ->
   Db.exec Build_artifact.add (main_binary, id) >>= fun () ->
+  Db.find last_insert_rowid () >>= fun main_binary_id ->
+  Db.exec Build.set_main_binary (id, main_binary_id) >>= fun () ->
   Db.commit ()
 
 let test_build_get_latest (module Db : CONN) =