Store relative paths for build artifacts in database

This commit is contained in:
Robur 2021-06-01 15:43:55 +00:00
parent 10351c65bd
commit 49003ca21f
12 changed files with 98 additions and 45 deletions

View file

@ -6,6 +6,8 @@ let pp_error ppf = function
| `Wrong_version (application_id, user_version) -> | `Wrong_version (application_id, user_version) ->
Format.fprintf ppf "wrong version { application_id: %ld, user_version: %Ld }" Format.fprintf ppf "wrong version { application_id: %ld, user_version: %Ld }"
application_id user_version application_id user_version
| `Msg m ->
Format.fprintf ppf "%s" m
let or_die exit_code = function let or_die exit_code = function
| Ok r -> r | Ok r -> r
@ -13,18 +15,20 @@ let or_die exit_code = function
Format.eprintf "Database error: %a" pp_error e; Format.eprintf "Database error: %a" pp_error e;
exit exit_code 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..."); Logs.debug (fun m -> m "Connecting to database...");
let ((module Db : Caqti_blocking.CONNECTION) as conn) = let ((module Db : Caqti_blocking.CONNECTION) as conn) =
Caqti_blocking.connect 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 |> or_die 1
in in
Logs.debug (fun m -> m "Connected!"); Logs.debug (fun m -> m "Connected!");
let r = let r =
Db.start () >>= fun () -> Db.start () >>= fun () ->
Logs.debug (fun m -> m "Started database transaction"); Logs.debug (fun m -> m "Started database transaction");
match action conn with match action datadir conn with
| Ok () -> | Ok () ->
Logs.debug (fun m -> m "Committing database transaction"); Logs.debug (fun m -> m "Committing database transaction");
Db.commit () Db.commit ()
@ -42,11 +46,11 @@ let help man_format migrations = function
then `Help (man_format, Some migration) then `Help (man_format, Some migration)
else `Error (true, "Unknown migration: " ^ 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 & 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 =
let setup_log level = let setup_log level =
@ -57,60 +61,69 @@ let setup_log =
let m20210126 = let m20210126 =
let doc = "Adds a column 'main_binary' in 'build' (2021-01-26)" in 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" Cmdliner.Term.info ~doc "migrate-2021-01-26"
let r20210126 = let r20210126 =
let doc = "Rollback 'main_binary' in 'build' (2021-01-26)" in 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" Cmdliner.Term.info ~doc "rollback-2021-01-26"
let m20210202 = let m20210202 =
let doc = "Adds an index 'job_build_idx' on 'build' (2021-02-02)" in 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" Cmdliner.Term.info ~doc "migrate-2021-02-02"
let r20210202 = let r20210202 =
let doc = "Rollback index 'job_build_idx' on 'build' (2021-02-02)" in 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" Cmdliner.Term.info ~doc "rollback-2021-02-02"
let m20210216 = let m20210216 =
let doc = "Changes 'user' for scrypt hashed passwords (NB: Destructive!!) (2021-02-16)" in 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" Cmdliner.Term.info ~doc "migrate-2021-02-16"
let r20210216 = let r20210216 =
let doc = "Rollback scrypt hashed passwords (NB: Destructive!!) (2021-02-16)" in 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" Cmdliner.Term.info ~doc "rollback-2021-02-16"
let m20210218 = let m20210218 =
let doc = "Adds column 'size' to 'build_file' and 'build_artifact' (2021-02-18)" in 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" Cmdliner.Term.info ~doc "migrate-2021-02-18"
let r20210218 = let r20210218 =
let doc = "Roll back column 'size' in 'build_file' and 'build_artifact' (2021-02-18)" in 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" Cmdliner.Term.info ~doc "rollback-2021-02-18"
let f20210308 = let f20210308 =
let doc = "Remove broken builds as fixed in commit a57798f4c02eb4d528b90932ec26fb0b718f1a13. \ let doc = "Remove broken builds as fixed in commit a57798f4c02eb4d528b90932ec26fb0b718f1a13. \
Note that the files on disk have to be removed manually." in 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" Cmdliner.Term.info ~doc "fixup-2021-03-08"
let m20210427 = let m20210427 =
let doc = "Adds an index 'idx_build_job_start' on 'build' (2021-04-27)" in 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" Cmdliner.Term.info ~doc "migrate-2021-04-27"
let r20210427 = let r20210427 =
let doc = "Rollback index 'idx_build_job_start'' on 'build' (2021-04-27)" in 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" 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 help_cmd =
let topic = let topic =
@ -136,5 +149,6 @@ let () =
m20210218; r20210218; m20210218; r20210218;
f20210308; f20210308;
m20210427; r20210427; m20210427; r20210427;
m20210531; r20210531;
] ]
|> Cmdliner.Term.exit |> Cmdliner.Term.exit

View file

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

View file

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

View file

@ -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 let open Rresult.R.Infix in
Grej.check_version ~user_version:old_user_version (module Db) >>= fun () -> Grej.check_version ~user_version:old_user_version (module Db) >>= fun () ->
Db.exec drop_user () >>= fun () -> Db.exec drop_user () >>= fun () ->
Db.exec new_user () >>= fun () -> Db.exec new_user () >>= fun () ->
Db.exec (Grej.set_version new_user_version) () 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 let open Rresult.R.Infix in
Grej.check_version ~user_version:new_user_version (module Db) >>= fun () -> Grej.check_version ~user_version:new_user_version (module Db) >>= fun () ->
Db.exec drop_user () >>= fun () -> Db.exec drop_user () >>= fun () ->

View file

@ -79,7 +79,7 @@ let rename_build_file =
Caqti_type.unit Caqti_type.unit
"ALTER TABLE new_build_file RENAME TO build_file" "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 let open Rresult.R.Infix in
Grej.check_version ~user_version:old_user_version (module Db) >>= fun () -> Grej.check_version ~user_version:old_user_version (module Db) >>= fun () ->
Db.exec new_build_artifact () >>= fun () -> Db.exec new_build_artifact () >>= fun () ->
@ -146,7 +146,7 @@ let copy_build_file =
Caqti_type.unit Caqti_type.unit
"INSERT INTO new_build_file SELECT id, filepath, localpath, sha256, build FROM build_file" "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 let open Rresult.R.Infix in
Grej.check_version ~user_version:new_user_version (module Db) >>= fun () -> Grej.check_version ~user_version:new_user_version (module Db) >>= fun () ->
Db.exec old_build_artifact () >>= fun () -> Db.exec old_build_artifact () >>= fun () ->

View file

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

View file

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

View file

@ -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) ()

View file

@ -4,7 +4,7 @@ open Rep
let application_id = 1234839235l let application_id = 1234839235l
(* Please update this when making changes! *) (* Please update this when making changes! *)
let current_version = 3L let current_version = 4L
type id = Rep.id type id = Rep.id

View file

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

View file

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

View file

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