diff --git a/bin/migrations/builder_migrations.ml b/bin/migrations/builder_migrations.ml index 3758ae1..78aee3c 100644 --- a/bin/migrations/builder_migrations.ml +++ b/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 doc = "sqlite3 database path" in +let datadir = + let doc = "data directory containing builder.sqlite3 and data files" in Cmdliner.Arg.(value & - opt non_dir_file "/var/db/builder-web/builder.sqlite3" & - info ~doc ["dbpath"]) + opt dir "/var/db/builder-web/" & + 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 diff --git a/bin/migrations/m20210126.ml b/bin/migrations/m20210126.ml index 211da1c..fc16622 100644 --- a/bin/migrations/m20210126.ml +++ b/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 () -> diff --git a/bin/migrations/m20210202.ml b/bin/migrations/m20210202.ml index c7021bf..6923809 100644 --- a/bin/migrations/m20210202.ml +++ b/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 diff --git a/bin/migrations/m20210216.ml b/bin/migrations/m20210216.ml index 17f2752..e7bdaf8 100644 --- a/bin/migrations/m20210216.ml +++ b/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 () -> diff --git a/bin/migrations/m20210218.ml b/bin/migrations/m20210218.ml index 4c05bc2..d5843e5 100644 --- a/bin/migrations/m20210218.ml +++ b/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 () -> diff --git a/bin/migrations/m20210308.ml b/bin/migrations/m20210308.ml index d8f037c..b712b0d 100644 --- a/bin/migrations/m20210308.ml +++ b/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 -> diff --git a/bin/migrations/m20210427.ml b/bin/migrations/m20210427.ml index 6247545..143fdda 100644 --- a/bin/migrations/m20210427.ml +++ b/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 diff --git a/bin/migrations/m20210531.ml b/bin/migrations/m20210531.ml new file mode 100644 index 0000000..c59c250 --- /dev/null +++ b/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) () diff --git a/db/builder_db.ml b/db/builder_db.ml index ddbe697..7311ddc 100644 --- a/db/builder_db.ml +++ b/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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 0c97941..86cac23 100644 --- a/lib/builder_web.ml +++ b/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) -> diff --git a/lib/model.ml b/lib/model.ml index 29492d7..b278638 100644 --- a/lib/model.ml +++ b/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 build_dir = Fpath.(basedir / job.Builder.name / Uuidm.to_string uuid) in +let save_all staging_dir ((job, uuid, _, _, _, _, artifacts) as exec) = + 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 job_dir = Fpath.(basedir / job_name) in +let commit_files datadir staging_dir job_name uuid = + 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 -> diff --git a/lib/model.mli b/lib/model.mli index 6349fea..32307c9 100644 --- a/lib/model.mli +++ b/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 ->