Store relative paths for build artifacts in database

bin/migrations/builder_migrations.ml

@@ -6,6 +6,8 @@ let pp_error ppf = function
   | `Wrong_version (application_id, user_version) ->
     Format.fprintf ppf "wrong version { application_id: %ld, user_version: %Ld }"
       application_id user_version
+  | `Msg m ->
+    Format.fprintf ppf "%s" m
 
 let or_die exit_code = function
   | Ok r -> r
@@ -13,18 +15,20 @@ let or_die exit_code = function
     Format.eprintf "Database error: %a" pp_error e;
     exit exit_code
 
-let do_database_action action () dbpath =
+let do_database_action action () datadir =
+  let datadir = Fpath.v datadir in
+  let dbpath = Fpath.(datadir / "builder.sqlite3") in
   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"]] ())
+      (Uri.make ~scheme:"sqlite3" ~path:(Fpath.to_string 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
+    match action datadir conn with
     | Ok () ->
       Logs.debug (fun m -> m "Committing database transaction");
       Db.commit ()
@@ -42,11 +46,11 @@ let help man_format migrations = function
     then `Help (man_format, Some migration)
     else `Error (true, "Unknown migration: " ^ migration)
 
-let dbpath =
+let datadir =
-  let doc = "sqlite3 database path" in
+  let doc = "data directory containing builder.sqlite3 and data files" in
   Cmdliner.Arg.(value &
-                opt non_dir_file "/var/db/builder-web/builder.sqlite3" &
+                opt dir "/var/db/builder-web/" &
-                info ~doc ["dbpath"])
+                info ~doc ["datadir"])
 
 let setup_log =
   let setup_log level =
@@ -57,60 +61,69 @@ let setup_log =
 
 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.(const do_database_action $ const M20210126.migrate $ setup_log $ datadir),
   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.(const do_database_action $ const M20210126.rollback $ setup_log $ datadir),
   Cmdliner.Term.info ~doc "rollback-2021-01-26"
 
 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 $ dbpath),
+  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 $ dbpath),
+  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 $ dbpath),
+  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 $ dbpath),
+  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 $ dbpath),
+  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 $ dbpath),
+  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. \
     Note that the files on disk have to be removed manually." in
-  Cmdliner.Term.(const do_database_action $ const M20210308.fixup $ setup_log $ dbpath),
+  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 $ dbpath),
+  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 $ dbpath),
+  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 help_cmd =
   let topic =
@@ -136,5 +149,6 @@ let () =
       m20210218; r20210218;
       f20210308;
       m20210427; r20210427;
+      m20210531; r20210531;
     ]
   |> Cmdliner.Term.exit

bin/migrations/m20210126.ml

@@ -28,7 +28,7 @@ let set_main_binary =
     Caqti_type.(tup2 int64 (option string))
     "UPDATE build SET main_binary = ?2 WHERE id = ?1"
 
-let migrate (module Db : Caqti_blocking.CONNECTION) =
+let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   let open Rresult.R.Infix in
   Grej.check_version ~application_id:0l ~user_version:0L (module Db) >>= fun () ->
   Db.exec alter_build () >>= fun () ->
@@ -84,7 +84,7 @@ let rollback_data =
        FROM __tmp_build
     |}
 
-let rollback (module Db : Caqti_blocking.CONNECTION) =
+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 () ->
   Db.exec rename_build () >>= fun () ->

bin/migrations/m20210202.ml

@@ -1,6 +1,6 @@
 open Rresult.R.Infix
 
-let migrate (module Db : Caqti_blocking.CONNECTION) =
+let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   let job_build_idx =
     Caqti_request.exec ~oneshot:true
       Caqti_type.unit
@@ -9,7 +9,7 @@ let migrate (module Db : Caqti_blocking.CONNECTION) =
   Grej.check_version ~user_version:1L (module Db) >>= fun () ->
   Db.exec job_build_idx ()
 
-let rollback (module Db : Caqti_blocking.CONNECTION) =
+let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   let q =
     Caqti_request.exec ~oneshot:true
       Caqti_type.unit

bin/migrations/m20210216.ml

@@ -32,14 +32,14 @@ let old_user =
        )
     |}
 
-let migrate (module Db : Caqti_blocking.CONNECTION) =
+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 () ->
   Db.exec drop_user () >>= fun () ->
   Db.exec new_user () >>= fun () ->
   Db.exec (Grej.set_version new_user_version) ()
 
-let rollback (module Db : Caqti_blocking.CONNECTION) =
+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 () ->
   Db.exec drop_user () >>= fun () ->

bin/migrations/m20210218.ml

@@ -79,7 +79,7 @@ let rename_build_file =
     Caqti_type.unit
     "ALTER TABLE new_build_file RENAME TO build_file"
 
-let migrate (module Db : Caqti_blocking.CONNECTION) =
+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 () ->
   Db.exec new_build_artifact () >>= fun () ->
@@ -146,7 +146,7 @@ let copy_build_file =
     Caqti_type.unit
     "INSERT INTO new_build_file SELECT id, filepath, localpath, sha256, build FROM build_file"
 
-let rollback (module Db : Caqti_blocking.CONNECTION) =
+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 () ->
   Db.exec old_build_artifact () >>= fun () ->

bin/migrations/m20210308.ml

@@ -10,7 +10,7 @@ let broken_builds =
           WHERE a.build = b.id and a.filepath = b.main_binary) = 0
     |}
 
-let fixup (module Db : Caqti_blocking.CONNECTION) =
+let fixup _datadir (module Db : Caqti_blocking.CONNECTION) =
   let open Rresult.R.Infix in
   Grej.check_version ~user_version:3L (module Db) >>= fun () ->
   Db.rev_collect_list broken_builds () >>= fun broken_builds ->

bin/migrations/m20210427.ml

@@ -1,6 +1,6 @@
 open Rresult.R.Infix
 
-let migrate (module Db : Caqti_blocking.CONNECTION) =
+let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
   let idx_build_job_start =
     Caqti_request.exec ~oneshot:true
       Caqti_type.unit
@@ -15,7 +15,7 @@ let migrate (module Db : Caqti_blocking.CONNECTION) =
   Db.exec rm_job_build_idx () >>= fun () ->
   Db.exec idx_build_job_start ()
 
-let rollback (module Db : Caqti_blocking.CONNECTION) =
+let rollback _datadir (module Db : Caqti_blocking.CONNECTION) =
   let job_build_idx =
     Caqti_request.exec ~oneshot:true
       Caqti_type.unit

bin/migrations/m20210531.ml

@@ -0,0 +1,36 @@
+let old_version = 3L
+let new_version = 4L
+
+let build_artifacts =
+  Caqti_request.collect ~oneshot:true
+    Caqti_type.unit
+    Caqti_type.(tup2 Builder_db.Rep.id Builder_db.Rep.fpath)
+    "SELECT id, localpath FROM build_artifact"
+
+let build_artifact_update_localpath =
+  Caqti_request.exec ~oneshot:true
+    Caqti_type.(tup2 Builder_db.Rep.id Builder_db.Rep.fpath)
+    "UPDATE build_artifact SET localpath = ?2 WHERE id = ?1"
+
+(* We are not migrating build_file because it is unused *)
+
+let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
+  let open Rresult.R.Infix in
+  Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
+  Db.collect_list build_artifacts () >>= fun artifacts ->
+  Grej.list_iter_result (fun (id, localpath) ->
+    match Fpath.rem_prefix datadir localpath with
+    | Some p -> Db.exec build_artifact_update_localpath (id, p)
+    | None -> Error (`Msg ("couldn't remove datadir prefix from " ^ Fpath.to_string localpath)))
+   artifacts >>= fun () ->
+  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_version (module Db) >>= fun () ->
+   Db.collect_list build_artifacts () >>= fun artifacts ->
+  Grej.list_iter_result (fun (id, localpath) ->
+    let p = Fpath.(datadir // localpath) in
+    Db.exec build_artifact_update_localpath (id, p))
+   artifacts >>= 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 = 3L
+let current_version = 4L
 
 type id = Rep.id
 

lib/builder_web.ml

@@ -162,6 +162,7 @@ let add_routes datadir =
   in
 
   let job_build_file req =
+    let datadir = Dream.global datadir_global req in
     let _job_name = Dream.param "job" req
     and build = Dream.param "build" req
     and filepath = Dream.path req |> String.concat "/" in
@@ -176,7 +177,7 @@ let add_routes datadir =
       Log.debug (fun m -> m "bad path: %s" e);
       Dream.respond ~status:`Not_Found "File not found"
     | Some build, Ok filepath ->
-      let* artifact = Dream.sql req (Model.build_artifact build filepath) in
+      let* artifact = Dream.sql req (Model.build_artifact datadir build filepath) in
       match artifact with
       | Error e ->
         Log.warn (fun m -> m "Error getting build artifact: %a" pp_error e);
@@ -242,6 +243,7 @@ let add_routes datadir =
   in
 
   let compare_opam req =
+    let datadir = Dream.global datadir_global req in
     let build_left = Dream.param "build_left" req in
     let build_right = Dream.param "build_right" req in
     match Uuidm.of_string build_left, Uuidm.of_string build_right with
@@ -249,9 +251,9 @@ let add_routes datadir =
       Dream.respond ~status:`Bad_Request "Bad request"
     | Some build_left, Some build_right ->
       let* r =
-        Dream.sql req (Model.build_artifact build_left (Fpath.v "opam-switch"))
+        Dream.sql req (Model.build_artifact datadir build_left (Fpath.v "opam-switch"))
           >>= fun switch_left ->
-        Dream.sql req (Model.build_artifact build_right (Fpath.v "opam-switch"))
+        Dream.sql req (Model.build_artifact datadir build_right (Fpath.v "opam-switch"))
           >>= fun switch_right ->
         Dream.sql req (Model.build build_left) >>= fun (_id, build_left) ->
         Dream.sql req (Model.build build_right) >>= fun (_id, build_right) ->

lib/model.ml

@@ -20,7 +20,8 @@ let not_found = function
 
 let staging datadir = Fpath.(datadir / "_staging")
 
-let read_file filepath =
+let read_file datadir filepath =
+  let filepath = Fpath.(datadir // filepath) in
   Lwt.try_bind
     (fun () -> Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string filepath))
     (fun ic -> Lwt_result.ok (Lwt_io.read ic))
@@ -31,11 +32,11 @@ let read_file filepath =
         Lwt.return_error (`File_error filepath)
       | e -> Lwt.fail e)
 
-let build_artifact build filepath (module Db : CONN) =
+let build_artifact datadir build filepath (module Db : CONN) =
   Db.find_opt Builder_db.Build_artifact.get_by_build_uuid (build, filepath)
   >>= function
   | Some (_id, file) ->
-    read_file file.Builder_db.localpath >|= fun data -> data, file.Builder_db.sha256
+    read_file datadir file.Builder_db.localpath >|= fun data -> data, file.Builder_db.sha256
   | None ->
     Lwt.return_error `Not_found
 
@@ -154,8 +155,8 @@ let save_files dir staging files =
     (Lwt_result.return [])
     files
 
-let save_all basedir staging_dir ((job, uuid, _, _, _, _, artifacts) as exec) =
+let save_all staging_dir ((job, uuid, _, _, _, _, artifacts) as exec) =
-  let build_dir = Fpath.(basedir / job.Builder.name / Uuidm.to_string uuid) in
+  let build_dir = Fpath.(v job.Builder.name / Uuidm.to_string uuid) in
   let input_dir = Fpath.(build_dir / "input")
   and staging_input_dir = Fpath.(staging_dir / "input") in
   let output_dir = Fpath.(build_dir / "output")
@@ -171,19 +172,19 @@ let save_all basedir staging_dir ((job, uuid, _, _, _, _, artifacts) as exec) =
   save_files input_dir staging_input_dir job.Builder.files >>= fun input_files ->
   Lwt_result.return (artifacts, input_files)
 
-let commit_files basedir staging_dir job_name uuid =
+let commit_files datadir staging_dir job_name uuid =
-  let job_dir = Fpath.(basedir / job_name) in
+  let job_dir = Fpath.(datadir / job_name) in
   let dest = Fpath.(job_dir / Uuidm.to_string uuid) in
   Lwt.return (Bos.OS.Dir.create job_dir) >>= fun _ ->
   Lwt.return (Bos.OS.Path.move staging_dir dest)
 
 let add_build
-    basedir
+    datadir
     ((job, uuid, console, start, finish, result, _) as exec)
     (module Db : CONN) =
   let open Builder_db in
   let job_name = job.Builder.name in
-  let staging_dir = Fpath.(staging basedir / Uuidm.to_string uuid) in
+  let staging_dir = Fpath.(staging datadir / Uuidm.to_string uuid) in
   let or_cleanup x =
     Lwt_result.map_err (fun e ->
         Bos.OS.Dir.delete ~recurse:true staging_dir
@@ -194,7 +195,7 @@ let add_build
         e)
       x
   in
-  or_cleanup (save_all basedir staging_dir exec) >>= fun (artifacts, input_files) ->
+  or_cleanup (save_all staging_dir exec) >>= fun (artifacts, input_files) ->
   let main_binary =
     match List.find_all
             (fun file ->
@@ -233,7 +234,7 @@ let add_build
       (Lwt_result.return ())
       input_files >>= fun () ->
     Db.commit () >>= fun () ->
-    commit_files basedir staging_dir job_name uuid
+    commit_files datadir staging_dir job_name uuid
   in
   Lwt_result.bind_lwt_err (or_cleanup r)
     (fun e ->

lib/model.mli

@@ -7,7 +7,7 @@ val staging : Fpath.t -> Fpath.t
 val cleanup_staging : Fpath.t -> Caqti_lwt.connection ->
   (unit, [> `Msg of string ]) result Lwt.t
 
-val build_artifact : Uuidm.t -> Fpath.t -> Caqti_lwt.connection ->
+val build_artifact : Fpath.t -> Uuidm.t -> Fpath.t -> Caqti_lwt.connection ->
   (string * Cstruct.t, [> error ]) result Lwt.t
 
 val build_artifacts : Builder_db.id -> Caqti_lwt.connection ->