remove result_kind from build table (de-duplicate information), add some indexes

bin/migrations/builder_migrations.ml

@@ -148,5 +148,6 @@ let () =
         [ f20210707b ];
         [ f20210707c ];
         [ f20210707d ];
+        actions (module M20210712);
       ])
   |> Cmdliner.Term.exit

bin/migrations/m20210712.ml

@@ -0,0 +1,172 @@
+let new_version = 13L and old_version = 12L
+and identifier = "2021-07-12"
+and migrate_doc = "remove result_kind from build, add indexes idx_build_failed and idx_build_artifact_sha256"
+and rollback_doc = "add result_kind to build, remove indexes idx_build_failed and idx_build_artifact_sha256"
+
+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_code INTEGER NOT NULL,
+         result_msg TEXT,
+         console BLOB NOT NULL,
+         script TEXT NOT NULL,
+         main_binary INTEGER,
+         user INTEGER NOT NULL,
+         job INTEGER NOT NULL,
+         input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
+
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
+         FOREIGN KEY(user) REFERENCES user(id),
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+    |}
+
+let copy_old_build =
+  Caqti_request.exec
+    Caqti_type.unit
+    {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
+         result_code, result_msg, console, script, main_binary, user, job, input_id)
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, 0, result_msg,
+         console, script, main_binary, user, job, input_id
+       FROM build
+    |}
+
+let old_build_execution_result =
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int))
+    "SELECT id, result_kind, result_code FROM build"
+
+let update_new_build_execution_result =
+  Caqti_request.exec
+    Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int)
+    "UPDATE new_build SET result_code = ?2 WHERE id = ?1"
+
+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 INTEGER NOT NULL,
+         result_code INTEGER,
+         result_msg TEXT,
+         console BLOB NOT NULL,
+         script TEXT NOT NULL,
+         main_binary INTEGER,
+         user INTEGER NOT NULL,
+         job INTEGER NOT NULL,
+         input_id BLOB, -- sha256 (sha256<opam-switch> || sha256<build-environment> || sha256<system-packages>)
+
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED,
+         FOREIGN KEY(user) REFERENCES user(id),
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+    |}
+
+let copy_new_build =
+  Caqti_request.exec
+    Caqti_type.unit
+    {| INSERT INTO new_build(id, uuid, start_d, start_ps, finish_d, finish_ps,
+         result_kind, result_msg, console, script, main_binary, user, job, input_id)
+       SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, 0, result_msg,
+         console, script, main_binary, user, job, input_id
+       FROM build
+    |}
+
+let new_build_execution_result =
+  Caqti_request.collect
+    Caqti_type.unit
+    Caqti_type.(tup2 (Builder_db.Rep.id (`build : [ `build ])) int)
+    "SELECT id, result_code FROM build"
+
+let update_old_build_execution_result =
+  Caqti_request.exec
+    Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) int (option int))
+    "UPDATE new_build SET result_kind = ?2, result_code = ?3 WHERE id = ?1"
+
+let drop_build =
+  Caqti_request.exec
+    Caqti_type.unit
+    "DROP TABLE build"
+
+let rename_build =
+  Caqti_request.exec
+    Caqti_type.unit
+    "ALTER TABLE new_build RENAME TO build"
+
+let execution_new_of_old kind code =
+  match kind, code with
+  | 0, Some v -> Ok v
+  | 1, Some v -> Ok (v lsl 8)
+  | 2, Some v -> Ok (v lsl 16)
+  | 3, None -> Ok 65536
+  | _ -> Error (`Msg "bad encoding")
+
+let execution_old_of_new code =
+  if code <= 0xFF
+  then Ok (0, Some code)
+  else if code <= 0xFFFF
+  then Ok (1, Some (code lsr 8))
+  else if code <= 0xFFFFFF
+  then Ok (2, Some (code lsr 16))
+  else if code = 65536
+  then Ok (3, None)
+  else Error (`Msg "bad encoding")
+
+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_build () >>= fun () ->
+  Db.exec copy_old_build () >>= fun () ->
+  Db.collect_list old_build_execution_result () >>= fun results ->
+  Grej.list_iter_result (fun (id, kind, code) ->
+    execution_new_of_old kind code >>= fun code' ->
+    Db.exec update_new_build_execution_result (id, code'))
+    results >>= fun () ->
+  Db.exec drop_build () >>= fun () ->
+  Db.exec rename_build () >>= fun () ->
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
+    () >>= fun () ->
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0")
+    () >>= fun () ->
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_input_id ON build(input_id)")
+    () >>= fun () ->
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_main_binary ON build(main_binary)")
+    () >>= fun () ->
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_artifact_sha256 ON build_artifact(sha256)")
+    () >>= fun () ->
+  Db.exec (Grej.set_version new_version) ()
+
+let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
+  Grej.check_version ~user_version:new_version (module Db) >>= fun () ->
+  Db.exec old_build () >>= fun () ->
+  Db.exec copy_new_build () >>= fun () ->
+  Db.collect_list new_build_execution_result () >>= fun results ->
+  Grej.list_iter_result (fun (id, code) ->
+    execution_old_of_new code >>= fun (kind, code') ->
+    Db.exec update_old_build_execution_result (id, kind, code'))
+    results >>= fun () ->
+  Db.exec drop_build () >>= fun () ->
+  Db.exec rename_build () >>= fun () ->
+  Db.exec (Caqti_request.exec Caqti_type.unit
+      "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)")
+    () >>= 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 = 12L
+let current_version = 13L
 
 type 'a id = 'a Rep.id
 
@@ -319,8 +319,7 @@ module Build = struct
            start_ps INTEGER NOT NULL,
            finish_d INTEGER NOT NULL,
            finish_ps INTEGER NOT NULL,
-           result_kind TINYINT NOT NULL,
+           result_code INTEGER NOT NULL,
-           result_code INTEGER,
            result_msg TEXT,
            console BLOB NOT NULL,
            script TEXT NOT NULL,
@@ -345,7 +344,7 @@ module Build = struct
       (id `build)
       t
       {| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
-                result_kind, result_code, result_msg,
+                result_code, result_msg,
                 console, script, main_binary, input_id, user, job
            FROM build
            WHERE id = ?
@@ -356,7 +355,7 @@ module Build = struct
       Rep.uuid
       (Caqti_type.tup2 (id `build) t)
       {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
-                  result_kind, result_code, result_msg,
+                  result_code, result_msg,
                   console, script, main_binary, input_id, user, job
            FROM build
            WHERE uuid = ?
@@ -367,7 +366,7 @@ module Build = struct
       (id `job)
       (Caqti_type.tup2 (id `build) t)
       {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
-                  result_kind, result_code, result_msg, console,
+                  result_code, result_msg, console,
                   script, main_binary, input_id, user, job
            FROM build
            WHERE job = ?
@@ -381,7 +380,7 @@ module Build = struct
          (id `build) Meta.t file_opt)
       {| 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.result_code, build.result_msg,
                 build.main_binary, build.input_id, build.user, build.job,
                 build_artifact.filepath, build_artifact.localpath, build_artifact.sha256, build_artifact.size
            FROM build, job
@@ -406,10 +405,10 @@ module Build = struct
       (id `job)
       Meta.t
       {| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
-                result_kind, result_code, result_msg,
+                result_code, result_msg,
                 main_binary, input_id, user, job
          FROM build
-         WHERE job = ? AND result_kind <> 0 OR result_code <> 0
+         WHERE job = ? AND result_code <> 0
          ORDER BY start_d DESC, start_ps DESC
          LIMIT 1
       |}
@@ -423,7 +422,7 @@ module Build = struct
                    file_opt)
       {| SELECT b.id,
            b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
-           b.result_kind, b.result_code, b.result_msg,
+           b.result_code, b.result_msg,
            b.main_binary, b.input_id, b.user, b.job,
            a.filepath, a.localpath, a.sha256, a.size
          FROM build b
@@ -451,7 +450,7 @@ module Build = struct
       Rep.uuid
       {| SELECT b.uuid
          FROM build b
-         WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0
+         WHERE b.job = ? AND b.result_code = 0
          ORDER BY b.start_d DESC, b.start_ps DESC
          LIMIT 1
       |}
@@ -462,11 +461,11 @@ module Build = struct
       Caqti_type.(tup2 (id `build) Meta.t)
       {| SELECT b.id,
            b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
-           b.result_kind, b.result_code, b.result_msg,
+           b.result_code, b.result_msg,
            b.main_binary, b.input_id, b.user, b.job
          FROM build b, build b0
          WHERE b0.id = ? AND b0.job = b.job AND
-           b.result_kind = 0 AND b.result_code = 0 AND
+           b.result_code = 0 AND
            (b0.start_d > b.start_d OR b0.start_d = b.start_d AND b0.start_ps > b.start_ps)
          ORDER BY b.start_d DESC, b.start_ps DESC
          LIMIT 1
@@ -477,7 +476,7 @@ module Build = struct
       (id `build)
       Meta.t
       {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
-           b.result_kind, b.result_code, b.result_msg,
+           b.result_code, b.result_msg,
            b.main_binary, b.input_id, b.user, b.job
          FROM build b0, build_artifact a0, build b, build_artifact a
          WHERE b0.id = ? AND a0.id = b0.main_binary AND a0.sha256 = a.sha256
@@ -511,7 +510,7 @@ module Build = struct
       Rep.cstruct
       Meta.t
       {| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
-          result_kind, result_code, result_msg,
+          result_code, result_msg,
           main_binary, input_id, user, job
          FROM build
          WHERE input_id = ?
@@ -524,9 +523,9 @@ module Build = struct
       t
       {| INSERT INTO build
            (uuid, start_d, start_ps, finish_d, finish_ps,
-           result_kind, result_code, result_msg, console, script, main_binary, input_id, user, job)
+           result_code, result_msg, console, script, main_binary, input_id, user, job)
            VALUES
-           (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
+           (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
         |}
 
   let get_meta_by_hash =
@@ -535,7 +534,7 @@ module Build = struct
       Meta.t
       {| SELECT
            b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
-           b.result_kind, b.result_code, b.result_msg,
+           b.result_code, b.result_msg,
            b.main_binary, b.input_id, b.user, b.job
          FROM build_artifact a
          INNER JOIN build b ON b.id = a.build
@@ -549,7 +548,7 @@ module Build = struct
       Rep.cstruct
       (Caqti_type.tup2 Meta.t file_opt)
       {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
-                b.result_kind, b.result_code, b.result_msg,
+                b.result_code, b.result_msg,
                 b.main_binary, b.input_id, b.user, b.job,
                 a.filepath, a.localpath, a.sha256, a.size
            FROM build_artifact a
@@ -567,7 +566,7 @@ module Build = struct
          t)
       {| SELECT job.name,
            b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
-           b.result_kind, b.result_code, b.result_msg,
+           b.result_code, b.result_msg,
            b.console, b.script, b.main_binary, b.input_id, b.user, b.job
          FROM build_artifact a
          INNER JOIN build b ON b.id = a.build
@@ -710,6 +709,14 @@ let migrate = [
   Job_tag.migrate;
   Caqti_request.exec Caqti_type.unit
     "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)";
+  Caqti_request.exec Caqti_type.unit
+    "CREATE INDEX idx_build_failed ON build(job, start_d DESC, start_ps DESC) WHERE result_code <> 0";
+  Caqti_request.exec Caqti_type.unit
+    "CREATE INDEX idx_build_input_id ON build(input_id)";
+  Caqti_request.exec Caqti_type.unit
+    "CREATE INDEX idx_build_main_binary ON build(main_binary)";
+  Caqti_request.exec Caqti_type.unit
+    "CREATE INDEX idx_build_artifact_sha256 ON build_artifact(sha256)";
   set_current_version;
   set_application_id;
 ]
@@ -722,6 +729,14 @@ let rollback = [
   Build_artifact.rollback;
   Build.rollback;
   Job.rollback;
+  Caqti_request.exec Caqti_type.unit
+    "DROP INDEX IF EXISTS idx_build_artifact_sha256";
+  Caqti_request.exec Caqti_type.unit
+    "DROP INDEX IF EXISTS idx_build_failed";
+  Caqti_request.exec Caqti_type.unit
+    "DROP INDEX IF EXISTS idx_build_input_id";
+  Caqti_request.exec Caqti_type.unit
+    "DROP INDEX IF EXISTS idx_build_main_binary";
   Caqti_request.exec Caqti_type.unit
     "DROP INDEX IF EXISTS idx_build_job_start";
   Caqti_request.exec Caqti_type.unit

db/representation.ml

@@ -88,20 +88,26 @@ let file_opt =
 
 let execution_result =
   let encode = function
-    | Builder.Exited v -> Ok (0, Some v, None)
+    | Builder.Exited v -> Ok (v, None)
-    | Builder.Signalled v -> Ok (1, Some v, None)
+    | Builder.Signalled v -> Ok (v lsl 8, None)
-    | Builder.Stopped v -> Ok (2, Some v, None)
+    | Builder.Stopped v -> Ok (v lsl 16, None)
-    | Builder.Msg msg -> Ok (3, None, Some msg)
+    | Builder.Msg msg -> Ok (65536, Some msg)
   in
-  let decode (kind, code, msg) =
+  let decode (code, msg) =
-    match kind, code, msg with
+    if code <= 0xFF then
-    | 0, Some v, None -> Ok (Builder.Exited v)
+       Ok (Builder.Exited code)
-    | 1, Some v, None -> Ok (Builder.Signalled v)
+    else if code <= 0xFFFF then
-    | 2, Some v, None -> Ok (Builder.Stopped v)
+       Ok (Builder.Signalled (code lsr 8))
-    | 3, None, Some msg -> Ok (Builder.Msg msg)
+    else if code <= 0xFFFFFF then
-    | _ -> Error "bad encoding"
+       Ok (Builder.Stopped (code lsr 16))
+    else if code = 65536 then
+       match msg with
+       | None -> Error "bad encoding"
+       | Some m -> Ok (Builder.Msg m)
+    else
+      Error "bad encoding (unknown number)"
   in
-  let rep = Caqti_type.(tup3 int (option int) (option string)) in
+  let rep = Caqti_type.(tup2 int (option string)) in
   Caqti_type.custom ~encode ~decode rep
 
 let console =