Add user column to build

We want to track who uploaded what builds.
A `nologin` user is created in the migration that owns all preexisting builds.

bin/migrations/builder_migrations.ml

@@ -145,6 +145,16 @@ let r20210608 =
   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
@@ -172,5 +182,6 @@ let () =
       m20210531; r20210531;
       m20210602; r20210602;
       m20210608; r20210608;
+      m20210609; r20210609;
     ]
   |> Cmdliner.Term.exit

bin/migrations/m20210602.ml

@@ -1,5 +1,9 @@
 let old_version = 4L and new_version = 5L
 
+let idx_build_job_start =
+  Caqti_request.exec Caqti_type.unit
+    "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
+
 let new_build =
     Caqti_request.exec
       Caqti_type.unit
@@ -121,6 +125,7 @@ let migrate _ (module Db : Caqti_blocking.CONNECTION) =
     builds >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->
+  Db.exec idx_build_job_start () >>= fun () ->
   Db.exec (Grej.set_version new_version) ()
 
  
@@ -140,4 +145,5 @@ let rollback _ (module Db : Caqti_blocking.CONNECTION) =
     builds >>= fun () ->
   Db.exec drop_build () >>= fun () ->
   Db.exec rename_build () >>= fun () ->
+  Db.exec idx_build_job_start () >>= fun () ->
   Db.exec (Grej.set_version old_version) ()

bin/migrations/m20210609.ml

@@ -0,0 +1,119 @@
+let new_version = 7L and old_version = 6L
+
+let idx_build_job_start =
+  Caqti_request.exec Caqti_type.unit
+    "CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)"
+
+let nologin_user =
+  Caqti_request.exec
+    Caqti_type.unit
+    "INSERT INTO user (username, password_hash, password_salt, scrypt_n, scrypt_r, scrypt_p, restricted) \
+     VALUES ('nologin', '', '', 16384, 8, 1, true)"
+
+let remove_nologin_user =
+  Caqti_request.exec
+    Caqti_type.unit
+    "DELETE FROM user WHERE username = 'nologin'"
+
+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,
+         user INTEGER NOT NULL,
+         job INTEGER NOT NULL,
+
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
+         FOREIGN KEY(job) REFERENCES job(id),
+         FOREIGN KEY(user) REFERENCES user(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 INTEGER,
+         job INTEGER NOT NULL,
+
+         FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
+         FOREIGN KEY(job) REFERENCES job(id)
+       )
+    |}
+
+let insert_from_old_build =
+  Caqti_request.exec ~oneshot:true
+    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, user)
+       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_from_new_build =
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.unit
+    {| 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)
+       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 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"
+
+open Rresult.R.Infix
+
+let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
+  Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
+  Db.exec nologin_user () >>= fun () ->
+  Db.find Builder_db.last_insert_rowid () >>= fun user_id ->
+  Db.exec new_build () >>= fun () ->
+  Db.exec insert_from_old_build user_id >>= fun () ->
+  Db.exec drop_build () >>= fun () ->
+  Db.exec rename_build () >>= fun () ->
+  Db.exec idx_build_job_start () >>= 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 insert_from_new_build () >>= fun () ->
+  Db.exec drop_build () >>= fun () ->
+  Db.exec rename_build () >>= fun () ->
+  Db.exec idx_build_job_start () >>= fun () ->
+  Db.exec remove_nologin_user () >>= 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 = 6L
+let current_version = 7L
 
 type id = Rep.id
 
@@ -212,12 +212,13 @@ module Build = struct
     console : (int * string) list;
     script : string;
     main_binary : id option;
+    user_id : id;
     job_id : id;
   }
 
   let t =
     let rep =
-      Caqti_type.(tup2
+      Caqti_type.(tup3
                     (tup4
                        uuid
                        (tup2
@@ -229,13 +230,14 @@ module Build = struct
                        (tup2
                           string
                           (option Rep.id)))
+                    id
                     id)
     in
-    let encode { uuid; start; finish; result; console; script; main_binary; job_id } =
+    let encode { uuid; start; finish; result; console; script; main_binary; user_id; job_id } =
-      Ok ((uuid, (start, finish), (result, console), (script, main_binary)), job_id)
+      Ok ((uuid, (start, finish), (result, console), (script, main_binary)), user_id, job_id)
     in
-    let decode ((uuid, (start, finish), (result, console), (script, main_binary)), job_id) =
+    let decode ((uuid, (start, finish), (result, console), (script, main_binary)), user_id, job_id) =
-      Ok { uuid; start; finish; result; console; script; main_binary; job_id }
+      Ok { uuid; start; finish; result; console; script; main_binary; user_id; job_id }
     in
     Caqti_type.custom ~encode ~decode rep
 
@@ -246,12 +248,13 @@ module Build = struct
       finish : Ptime.t;
       result : Builder.execution_result;
       main_binary : id option;
+      user_id : id;
       job_id : id;
     }
 
     let t =
       let rep =
-        Caqti_type.(tup2
+        Caqti_type.(tup3
                      (tup4
                        uuid
                        (tup2
@@ -259,13 +262,14 @@ module Build = struct
                           Rep.ptime)
                        execution_result
                        (option Rep.id))
+                     id
                      id)
       in
-      let encode { uuid; start; finish; result; main_binary; job_id } =
+      let encode { uuid; start; finish; result; main_binary; user_id; job_id } =
-        Ok ((uuid, (start, finish), result, main_binary), job_id)
+        Ok ((uuid, (start, finish), result, main_binary), user_id, job_id)
       in
-      let decode ((uuid, (start, finish), result, main_binary), job_id) =
+      let decode ((uuid, (start, finish), result, main_binary), user_id, job_id) =
-        Ok { uuid; start; finish; result; main_binary; job_id }
+        Ok { uuid; start; finish; result; main_binary; user_id; job_id }
       in
       Caqti_type.custom ~encode ~decode rep
   end
@@ -286,9 +290,11 @@ module Build = struct
            console BLOB NOT NULL,
            script TEXT NOT NULL,
            main_binary INTEGER,
+           user INTEGER NOT NULL,
            job INTEGER NOT NULL,
 
            FOREIGN KEY(main_binary) REFERENCES build_artifact(id),
+           FOREIGN KEY(user) REFERENCES user(id),
            FOREIGN KEY(job) REFERENCES job(id)
          )
       |}
@@ -304,7 +310,7 @@ module Build = struct
       t
       {| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
                 result_kind, result_code, result_msg,
-                console, script, main_binary, job
+                console, script, main_binary, user, job
            FROM build
            WHERE id = ?
         |}
@@ -315,7 +321,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, main_binary, job
+                  console, script, main_binary, user, job
            FROM build
            WHERE uuid = ?
         |}
@@ -326,7 +332,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, main_binary, job
+                  script, main_binary, user, job
            FROM build
            WHERE job = ?
            ORDER BY start_d DESC, start_ps DESC
@@ -340,7 +346,7 @@ module Build = struct
       {| 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.main_binary, build.job,
+                build.main_binary, build.user, build.job,
                 build_artifact.filepath, build_artifact.localpath, build_artifact.sha256, build_artifact.size
            FROM build, job
            LEFT JOIN build_artifact ON
@@ -359,7 +365,7 @@ module Build = struct
       {| 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.main_binary, b.job,
+           b.main_binary, b.user, b.job,
            a.filepath, a.localpath, a.sha256, a.size
          FROM build b
          LEFT JOIN build_artifact a ON
@@ -398,7 +404,7 @@ module Build = struct
       {| 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.main_binary, b.job
+           b.main_binary, 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
@@ -412,9 +418,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, job)
+           result_kind, result_code, result_msg, console, script, main_binary, user, job)
            VALUES
-           (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
+           (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
         |}
 
   let get_by_hash =
@@ -426,7 +432,7 @@ module Build = struct
       {| 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.console, b.script, b.main_binary, b.job
+           b.console, b.script, b.main_binary, b.user, b.job
          FROM build_artifact a
          INNER JOIN build b ON b.id = a.build
          INNER JOIN job ON job.id = b.job

db/builder_db.mli

@@ -113,6 +113,7 @@ sig
     console : (int * string) list;
     script : string;
     main_binary : id option;
+    user_id : id;
     job_id : id;
   }
   module Meta :
@@ -123,6 +124,7 @@ sig
       finish : Ptime.t;
       result : Builder.execution_result;
       main_binary : id option;
+      user_id : id;
       job_id : id;
     }
   end

lib/builder_web.ml

@@ -196,7 +196,9 @@ let add_routes datadir =
       |> Lwt_result.ok
     | false ->
       let datadir = Dream.global datadir_global req in
-      Dream.sql req (Model.add_build datadir exec)
+      (Lwt.return (Dream.local Authorization.user_info_local req |>
+                   Option.to_result ~none:(`Msg "no authenticated user")) >>= fun (user_id, _) ->
+       Dream.sql req (Model.add_build datadir user_id exec))
       |> if_error "Internal server error"
         ~log:(fun e -> Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e))
       >>= fun () -> Dream.respond "" |> Lwt_result.ok

lib/model.ml

@@ -191,6 +191,7 @@ let commit_files datadir staging_dir job_name uuid =
 
 let add_build
     datadir
+    user_id
     ((job, uuid, console, start, finish, result, _) as exec)
     (module Db : CONN) =
   let open Builder_db in
@@ -214,7 +215,7 @@ let add_build
     Lwt.return (Option.to_result ~none:(`Msg "No such job id") job_id) >>= fun job_id ->
     Db.exec Build.add { Build.uuid; start; finish; result;
                         console; script = job.Builder.script;
-                        main_binary = None; job_id } >>= fun () ->
+                        main_binary = None; user_id; job_id } >>= fun () ->
     Db.find last_insert_rowid () >>= fun id ->
     List.fold_left
       (fun r file ->

lib/model.mli

@@ -61,6 +61,7 @@ val authorized : Builder_db.id -> string -> Caqti_lwt.connection -> (unit, [> Ca
 
 val add_build :
   Fpath.t ->
+  Builder_db.id ->
   (Builder.job * Uuidm.t * (int * string) list * Ptime.t * Ptime.t *
    Builder.execution_result * (Fpath.t * string) list) ->
   Caqti_lwt.connection ->

lib/views.ml

@@ -168,7 +168,7 @@ let job name builds =
 
 let job_build
   name
-  { Builder_db.Build.uuid; start; finish; result; console; script; main_binary = _; job_id = _ }
+  { Builder_db.Build.uuid; start; finish; result; console; script; _ }
   artifacts
   latest_uuid
   previous_build

test/builder_db.ml

@@ -75,12 +75,13 @@ let restricted = false
 let auth = Builder_web_auth.hash ~scrypt_params ~username ~password ~restricted ()
 
 let add_test_user (module Db : CONN) =
-  Db.exec Builder_db.User.add auth
+  Db.exec Builder_db.User.add auth >>= fun () ->
+  Db.find Builder_db.last_insert_rowid ()
 
 let with_user_db f () =
   or_fail
     (setup_db () >>= fun conn ->
-     add_test_user conn >>= fun () ->
+     add_test_user conn >>= fun _id ->
      f conn)
 
 let test_user_get_all (module Db : CONN) =
@@ -150,17 +151,17 @@ let main_binary =
   let size = String.length data in
   { Builder_db.Rep.filepath; localpath; sha256; size }
 
-let fail_if_none =
+let fail_if_none a =
-  Option.to_result ~none:(`Msg "Failed to retrieve job id")
+  Option.to_result ~none:(`Msg "Failed to retrieve") a
 
-let add_test_build (module Db : CONN) =
+let add_test_build user_id (module Db : CONN) =
   let r =
     let open Builder_db in
     Db.start () >>= fun () ->
     Db.exec Job.try_add job_name >>= fun () ->
     Db.find_opt Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id ->
     Db.exec Build.add { Build.uuid; start; finish; result; console; script;
-                        main_binary = None;
+                        main_binary = None; user_id;
                         job_id } >>= fun () ->
     Db.find last_insert_rowid () >>= fun id ->
     Db.exec Build_artifact.add (main_binary, id) >>= fun () ->
@@ -175,7 +176,8 @@ let add_test_build (module Db : CONN) =
 let with_build_db f () =
   or_fail
     (setup_db () >>= fun conn ->
-     add_test_build conn >>= fun () ->
+     add_test_user conn >>= fun user_id ->
+     add_test_build user_id conn >>= fun () ->
      f conn)
 
 let test_job_get_all (module Db : CONN) =
@@ -224,10 +226,11 @@ let finish' = Option.get (Ptime.of_float_s 3601.)
 let add_second_build (module Db : CONN) =
   let uuid = uuid' and start = start' and finish = finish' in
   let open Builder_db in
+  Db.find_opt User.get_user username >>= fail_if_none >>= fun (user_id, _) ->
   Db.start () >>= fun () ->
   Db.find_opt Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id ->
   Db.exec Build.add { Build.uuid; start; finish; result; console; script;
-                      main_binary = None; job_id;
+                      main_binary = None; user_id; job_id;
                     } >>= fun () ->
   Db.find last_insert_rowid () >>= fun id ->
   Db.exec Build_artifact.add (main_binary, id) >>= fun () ->