From 17420c389b658031acae2b6d902ed1921c8304c8 Mon Sep 17 00:00:00 2001 From: Robur Date: Tue, 31 Aug 2021 11:59:45 +0000 Subject: [PATCH] WIP --- bin/builder_db.ml | 10 +- bin/migrations/m20210712c.ml | 220 +++++++++++++++++++++++++++++++++++ db/builder_db.ml | 88 +++++--------- db/builder_db.mli | 39 +++---- lib/model.ml | 26 ++++- lib/model.mli | 12 +- lib/views.ml | 23 ++-- test/builder_db.ml | 19 ++- 8 files changed, 311 insertions(+), 126 deletions(-) create mode 100644 bin/migrations/m20210712c.ml diff --git a/bin/builder_db.ml b/bin/builder_db.ml index 453ba3b..b8470ff 100644 --- a/bin/builder_db.ml +++ b/bin/builder_db.ml @@ -139,15 +139,15 @@ let job_remove () datadir jobname = Db.start () >>= fun () -> Db.exec defer_foreign_keys () >>= fun () -> let r = - Db.collect_list Builder_db.Build.get_all_meta job_id >>= fun builds -> - List.fold_left (fun r (build, meta, _) -> + Db.collect_list Builder_db.Build.get_all job_id >>= fun builds -> + List.fold_left (fun r (build_id, build) -> r >>= fun () -> - let dir = Fpath.(v datadir / jobname / Uuidm.to_string meta.Builder_db.Build.Meta.uuid) in + let dir = Fpath.(v datadir / jobname / Uuidm.to_string build.Builder_db.Build.uuid) in (match Bos.OS.Dir.delete ~recurse:true dir with | Ok _ -> () | Error `Msg e -> Logs.warn (fun m -> m "failed to remove build directory %a: %s" Fpath.pp dir e)); - Db.exec Builder_db.Build_artifact.remove_by_build build >>= fun () -> - Db.exec Builder_db.Build.remove build) + Db.exec Builder_db.Build_artifact.remove_by_build build_id >>= fun () -> + Db.exec Builder_db.Build.remove build_id) (Ok ()) builds >>= fun () -> Db.exec Builder_db.Job.remove job_id >>= fun () -> diff --git a/bin/migrations/m20210712c.ml b/bin/migrations/m20210712c.ml new file mode 100644 index 0000000..faadaeb --- /dev/null +++ b/bin/migrations/m20210712c.ml @@ -0,0 +1,220 @@ +let new_version = 14L and old_version = 13L +and identifier = "2021-07-12c" +and migrate_doc = "store script, console on disk" +and rollback_doc = "store script, console in database" + +module Asn = struct + let decode_strict codec cs = + match Asn.decode codec cs with + | Ok (a, cs) -> + if Cstruct.len cs = 0 + then Ok a + else Error "trailing bytes" + | Error (`Parse msg) -> Error ("parse error: " ^ msg) + + let projections_of asn = + let c = Asn.codec Asn.der asn in + (decode_strict c, Asn.encode c) + + let console = + Asn.S.(sequence_of + (sequence2 + (required ~label:"delta" int) + (required ~label:"data" utf8_string))) + + let console_of_cs, console_to_cs = projections_of console +end + +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 TEXT NOT NULL, + script TEXT NOT NULL, + main_binary INTEGER, + user INTEGER NOT NULL, + job INTEGER NOT NULL, + input_id BLOB, -- sha256 (sha256 || sha256 || sha256) + + FOREIGN KEY(main_binary) REFERENCES build_artifact(id) DEFERRABLE INITIALLY DEFERRED, + FOREIGN KEY(user) REFERENCES user(id), + FOREIGN KEY(job) REFERENCES job(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_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 || sha256 || sha256) + + 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_from_old_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, result_code, result_msg, + '', '', main_binary, user, job, input_id + FROM build + |} + +let copy_from_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, result_code, result_msg, + x'', '', main_binary, user, job, input_id + FROM build + |} + +let old_build_console_script = + Caqti_request.collect + Caqti_type.unit + Caqti_type.(tup4 (Builder_db.Rep.id (`build : [ `build ])) + (tup2 string Builder_db.Rep.uuid) octets string) + "SELECT b.id, job.name, b.uuid, b.console, b.script FROM build b, job WHERE b.job = job.id" + +let update_new_build_console_script = + Caqti_request.exec + Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.fpath Builder_db.Rep.fpath) + "UPDATE new_build SET console = ?2, script = ?3 WHERE id = ?1" + +let new_build_console_script = + Caqti_request.collect + Caqti_type.unit + Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.fpath Builder_db.Rep.fpath) + "SELECT id, console, script FROM build" + +let update_old_build_console_script = + Caqti_request.exec + Caqti_type.(tup3 (Builder_db.Rep.id (`build : [ `build ])) octets string) + "UPDATE new_build SET console = ?2, script = ?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 console_to_string console = + Asn.console_of_cs console >>| fun console -> + List.map (fun (delta, data) -> + Printf.sprintf "%.3fs:%s\n" (Duration.to_f delta) data) + console + |> String.concat "" + +let console_of_string data = + let lines = String.split_on_char '\n' data in + let console = List.map (fun line -> + match String.split_on_char ':' line with + | ts :: tail -> + let delta = float_of_string (String.sub ts 0 (String.length ts - 1)) in + Duration.of_f delta, String.concat ":" tail + | _ -> assert false) + lines + in + Asn.console_to_cs console + +let save_console_and_script datadir job_name uuid console script = + let out name = Fpath.(datadir / job_name / Uuidm.to_string uuid / name + "txt") in + let script_out = out "script" in + Bos.OS.File.write script_out script >>= fun () -> + let console_out = out "console" in + let console_data = console_to_string console in + Bos.OS.File.write console_out console_data >>= fun () -> + Ok (console_out, script_out) + +let read_console_and_script datadir console_file script_file = + let console_file = Fpath.append datadir console_file + and script_file = Fpath.append datadir script_file + in + Bos.OS.File.read console_file >>= fun console -> + Bos.OS.File.read script_fle >>= fun script -> + let console = console_of_string console in + Bos.OS.File.delete console_file >>= fun () -> + Bos.OS.File.delete script_file >>= fun () -> + Ok (console, script) + +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_from_old_build () >>= fun () -> + Db.collect_list old_build_console_script () >>= fun console_scripts -> + Grej.list_iter_result (fun (id, (job_name, uuid), console, script) -> + save_console_and_script datadir job_name uuid console script >>= fun (console_file, script_file) -> + Db.exec update_new_build_console_script (id, console_file, script_file)) + console_scripts >>= 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 (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_from_new_build () >>= fun () -> + Db.collect_list new_build_console_script () >>= fun console_scripts -> + Grej.list_iter_result (fun (id, console_file, script_file) -> + read_console_and_script datadir console_file script_file >>= fun (console, script) -> + Db.exec update_old_build_console_script (id, console, script)) + console_scripts >>= 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 (Grej.set_version old_version) () diff --git a/db/builder_db.ml b/db/builder_db.ml index cf87f4f..c33a777 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 = 13L +let current_version = 14L type 'a id = 'a Rep.id @@ -239,8 +239,8 @@ module Build = struct start : Ptime.t; finish : Ptime.t; result : Builder.execution_result; - console : (int * string) list; - script : string; + console : Fpath.t; + script : Fpath.t; main_binary : [`build_artifact] id option; input_id : Cstruct.t option; user_id : [`user] id; @@ -257,9 +257,9 @@ module Build = struct Rep.ptime) (tup2 execution_result - console) + fpath) (tup3 - string + fpath (option (Rep.id `build_artifact)) (option Rep.cstruct))) (id `user) @@ -273,42 +273,6 @@ module Build = struct in Caqti_type.custom ~encode ~decode rep - module Meta = struct - type t = { - uuid : Uuidm.t; - start : Ptime.t; - finish : Ptime.t; - result : Builder.execution_result; - main_binary : [`build_artifact] id option; - input_id : Cstruct.t option; - user_id : [`user] id; - job_id : [`job] id; - } - - let t = - let rep = - Caqti_type.(tup3 - (tup4 - uuid - (tup2 - Rep.ptime - Rep.ptime) - execution_result - (tup2 - (option (Rep.id `build_artifact)) - (option Rep.cstruct))) - (id `user) - (id `job)) - in - let encode { uuid; start; finish; result; main_binary; input_id; user_id; job_id } = - Ok ((uuid, (start, finish), result, (main_binary, input_id)), user_id, job_id) - in - let decode ((uuid, (start, finish), result, (main_binary, input_id)), user_id, job_id) = - Ok { uuid; start; finish; result; main_binary; input_id; user_id; job_id } - in - Caqti_type.custom ~encode ~decode rep - end - let migrate = Caqti_request.exec Caqti_type.unit @@ -321,7 +285,7 @@ module Build = struct finish_ps INTEGER NOT NULL, result_code INTEGER NOT NULL, result_msg TEXT, - console BLOB NOT NULL, + console TEXT NOT NULL, script TEXT NOT NULL, main_binary INTEGER, user INTEGER NOT NULL, @@ -373,14 +337,14 @@ module Build = struct ORDER BY start_d DESC, start_ps DESC |} - let get_all_meta = + let get_all_with_main_binary = Caqti_request.collect (id `job) (Caqti_type.tup3 - (id `build) Meta.t file_opt) + (id `build) t file_opt) {| SELECT build.id, build.uuid, build.start_d, build.start_ps, build.finish_d, build.finish_ps, - build.result_code, build.result_msg, + build.result_code, build.result_msg, console, script, 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 @@ -403,9 +367,9 @@ module Build = struct let get_latest_failed = Caqti_request.find_opt (id `job) - Meta.t + t {| SELECT uuid, start_d, start_ps, finish_d, finish_ps, - result_code, result_msg, + result_code, result_msg, console, script, main_binary, input_id, user, job FROM build WHERE job = ? AND result_code <> 0 @@ -418,11 +382,11 @@ module Build = struct (id `job) Caqti_type.(tup3 (id `build) - Meta.t + t file_opt) {| SELECT b.id, b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, - 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, a.filepath, a.localpath, a.sha256, a.size FROM build b @@ -458,10 +422,10 @@ module Build = struct let get_previous_successful = Caqti_request.find_opt (id `build) - Caqti_type.(tup2 (id `build) Meta.t) + Caqti_type.(tup2 (id `build) t) {| SELECT b.id, b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, - b.result_code, b.result_msg, + b.result_code, b.result_msg, console, script, b.main_binary, b.input_id, b.user, b.job FROM build b, build b0 WHERE b0.id = ? AND b0.job = b.job AND @@ -474,9 +438,9 @@ module Build = struct let get_same_input_same_output_builds = Caqti_request.collect (id `build) - Meta.t + t {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, - 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 b0, build_artifact a0, build b, build_artifact a WHERE b0.id = ? AND a0.id = b0.main_binary AND a0.sha256 = a.sha256 @@ -508,9 +472,9 @@ module Build = struct let get_one_by_input_id = Caqti_request.find Rep.cstruct - Meta.t + t {| SELECT uuid, start_d, start_ps, finish_d, finish_ps, - result_code, result_msg, + result_code, result_msg, console, script, main_binary, input_id, user, job FROM build WHERE input_id = ? @@ -528,13 +492,13 @@ module Build = struct (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |} - let get_meta_by_hash = + let get_by_hash = Caqti_request.find Rep.cstruct - Meta.t + t {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, - 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 @@ -543,12 +507,12 @@ module Build = struct LIMIT 1 |} - let get_meta_and_artifact_by_hash = + let get_with_main_binary_by_hash = Caqti_request.find Rep.cstruct - (Caqti_type.tup2 Meta.t file_opt) + (Caqti_type.tup2 t file_opt) {| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, - 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, a.filepath, a.localpath, a.sha256, a.size FROM build_artifact a @@ -558,7 +522,7 @@ module Build = struct LIMIT 1 |} - let get_by_hash = + let get_with_jobname_by_hash = Caqti_request.find_opt Rep.cstruct (Caqti_type.tup2 diff --git a/db/builder_db.mli b/db/builder_db.mli index 0a87040..11d23eb 100644 --- a/db/builder_db.mli +++ b/db/builder_db.mli @@ -124,26 +124,13 @@ sig start : Ptime.t; finish : Ptime.t; result : Builder.execution_result; - console : (int * string) list; - script : string; + console : Fpath.t; + script : Fpath.t; main_binary : [`build_artifact] id option; input_id : Cstruct.t option; user_id : [`user] id; job_id : [`job] id; } - module Meta : - sig - type t = { - uuid : Uuidm.t; - start : Ptime.t; - finish : Ptime.t; - result : Builder.execution_result; - main_binary : [`build_artifact] id option; - input_id : Cstruct.t option; - user_id : [`user] id; - job_id : [`job] id; - } - end val migrate : (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t @@ -157,15 +144,15 @@ sig Caqti_request.t val get_all : ([`job] id, [`build] id * t, [ `Many | `One | `Zero ]) Caqti_request.t - val get_all_meta : - ([`job] id, [`build] id * Meta.t * file option, [ `Many | `One | `Zero ]) Caqti_request.t + val get_all_with_main_binary : + ([`job] id, [`build] id * t * file option, [ `Many | `One | `Zero ]) Caqti_request.t val get_all_artifact_sha : ([`job] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t val get_latest : - ([`job] id, [`build] id * Meta.t * file option, [< `Many | `One | `Zero > `One `Zero ]) + ([`job] id, [`build] id * t * file option, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t val get_latest_failed : - ([`job] id, Meta.t, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t + ([`job] id, t, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t val get_latest_uuid : ([`job] id, [`build] id * Uuidm.t, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t @@ -173,22 +160,22 @@ sig ([`job] id, Uuidm.t, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t val get_previous_successful : - ([`build] id, [`build] id * Meta.t, [< `Many | `One | `Zero > `One `Zero ]) + ([`build] id, [`build] id * t, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t val get_same_input_same_output_builds : - ([`build] id, Meta.t, [ `Many | `One | `Zero ]) Caqti_request.t + ([`build] id, t, [ `Many | `One | `Zero ]) Caqti_request.t val get_same_input_different_output_hashes : ([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t val get_different_input_same_output_input_ids : ([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t val get_one_by_input_id : - (Cstruct.t, Meta.t, [< `Many | `One | `Zero > `One ]) Caqti_request.t + (Cstruct.t, t, [< `Many | `One | `Zero > `One ]) Caqti_request.t val add : (t, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t - val get_meta_by_hash : - (Cstruct.t, Meta.t, [< `Many | `One | `Zero > `One]) Caqti_request.t - val get_meta_and_artifact_by_hash : - (Cstruct.t, Meta.t * file option, [< `Many | `One | `Zero > `One]) Caqti_request.t val get_by_hash : + (Cstruct.t, t, [< `Many | `One | `Zero > `One]) Caqti_request.t + val get_with_main_binary_by_hash : + (Cstruct.t, t * file option, [< `Many | `One | `Zero > `One]) Caqti_request.t + val get_with_jobname_by_hash : (Cstruct.t, string * t, [< `Many | `One | `Zero > `One `Zero]) Caqti_request.t val set_main_binary : ([`build] id * [`build_artifact] id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t val remove : ([`build] id, unit, [< `Many | `One | `Zero > `Zero]) Caqti_request.t diff --git a/lib/model.ml b/lib/model.ml index 3104d7b..91a0fc9 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -52,7 +52,7 @@ let build_meta job (module Db : CONN) = Option.map (fun (_id, meta, file) -> (meta, file)) let build_hash hash (module Db : CONN) = - Db.find_opt Builder_db.Build.get_by_hash hash + Db.find_opt Builder_db.Build.get_with_jobname_by_hash hash let build_exists uuid (module Db : CONN) = Db.find_opt Builder_db.Build.get_by_uuid uuid >|= @@ -89,11 +89,10 @@ let builds_with_same_input_and_different_main_binary id (module Db : CONN) = match acc with | Error _ as e -> Lwt.return e | Ok metas -> - Db.find Builder_db.Build.get_meta_by_hash hash >>= fun build -> + Db.find Builder_db.Build.get_by_hash hash >>= fun build -> Lwt.return (Ok (build :: metas))) (Ok []) hashes - let job_id job_name (module Db : CONN) = Db.find_opt Builder_db.Job.get_id_by_name job_name @@ -112,9 +111,9 @@ let job_and_readme job (module Db : CONN) = match acc with | Error _ as e -> Lwt.return e | Ok (fail, metas) -> - Db.find Builder_db.Build.get_meta_and_artifact_by_hash hash >|= fun (meta, file) -> + Db.find Builder_db.Build.get_with_main_binary_by_hash hash >|= fun (meta, file) -> match fail with - | Some f when Ptime.is_later ~than:meta.Builder_db.Build.Meta.start f.Builder_db.Build.Meta.start -> None, (meta, file) :: (f, None) :: metas + | Some f when Ptime.is_later ~than:meta.Builder_db.Build.start f.Builder_db.Build.start -> None, (meta, file) :: (f, None) :: metas | x -> x, (meta, file) :: metas) (Ok (failed, [])) sha >|= fun (x, builds) -> let builds = match x with None -> builds | Some f -> (f, None) :: builds in @@ -279,6 +278,19 @@ let compute_input_id artifacts = | Some a, Some b, Some c -> Some (Mirage_crypto.Hash.SHA256.digest (Cstruct.concat [a;b;c])) | _ -> None +let save_console_and_script staging_dir datadir job_name uuid console script = + let out name = Fpath.(datadir / job_name / Uuidm.to_string uuid / name + "txt") in + let out_staging name = Fpath.(staging_dir / name + "txt") in + let console_to_string console = + List.map (fun (delta, data) -> + Printf.sprintf "%.3fs:%s\n" (Duration.to_f (Int64.of_int delta)) data) + console + |> String.concat "" + in + save (out_staging "script") script >>= fun () -> + save (out_staging "console") (console_to_string console) >|= fun () -> + (out "script", out "console") + let add_build datadir user_id @@ -303,6 +315,8 @@ let add_build in List.filter (fun (p, _) -> not (not_interesting p)) raw_artifacts in + or_cleanup (save_console_and_script staging_dir datadir job_name uuid console job.Builder.script) + >>= fun (console, script) -> or_cleanup (save_all staging_dir job uuid artifacts_to_preserve) >>= fun artifacts -> let r = Db.start () >>= fun () -> @@ -323,7 +337,7 @@ let add_build Db.find Tag.get_id_by_name readme_tag >>= fun readme_id -> let input_id = compute_input_id artifacts in Db.exec Build.add { Build.uuid; start; finish; result; - console; script = job.Builder.script; + console; script; main_binary = None; input_id; user_id; job_id } >>= fun () -> Db.find last_insert_rowid () >>= fun id -> let sec_syn = infer_section_and_synopsis job_name raw_artifacts in diff --git a/lib/model.mli b/lib/model.mli index 384c16d..5c7dad7 100644 --- a/lib/model.mli +++ b/lib/model.mli @@ -22,7 +22,7 @@ val build : Uuidm.t -> Caqti_lwt.connection -> ([`build] Builder_db.id * Builder_db.Build.t, [> error ]) result Lwt.t val build_meta : [`job] Builder_db.id -> Caqti_lwt.connection -> - ((Builder_db.Build.Meta.t * Builder_db.file option) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t + ((Builder_db.Build.t * Builder_db.file option) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t val build_hash : Cstruct.t -> Caqti_lwt.connection -> ((string * Builder_db.Build.t) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t @@ -37,22 +37,22 @@ val latest_successful_build_uuid : [`job] Builder_db.id -> Caqti_lwt.connection (Uuidm.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t val previous_successful_build : [`build] Builder_db.id -> Caqti_lwt.connection -> - (Builder_db.Build.Meta.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t + (Builder_db.Build.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t val builds_with_different_input_and_same_main_binary : [`build] Builder_db.id -> Caqti_lwt.connection -> - (Builder_db.Build.Meta.t list, [> Caqti_error.call_or_retrieve ]) result Lwt.t + (Builder_db.Build.t list, [> Caqti_error.call_or_retrieve ]) result Lwt.t val builds_with_same_input_and_same_main_binary : [`build] Builder_db.id -> Caqti_lwt.connection -> - (Builder_db.Build.Meta.t list, [> Caqti_error.call_or_retrieve ]) result Lwt.t + (Builder_db.Build.t list, [> Caqti_error.call_or_retrieve ]) result Lwt.t val builds_with_same_input_and_different_main_binary : [`build] Builder_db.id -> Caqti_lwt.connection -> - (Builder_db.Build.Meta.t list, [> Caqti_error.call_or_retrieve ]) result Lwt.t + (Builder_db.Build.t list, [> Caqti_error.call_or_retrieve ]) result Lwt.t val readme : string -> Caqti_lwt.connection -> (string option, [> error ]) result Lwt.t val job_and_readme : string -> Caqti_lwt.connection -> - (string option * (Builder_db.Build.Meta.t * Builder_db.file option) list, [> error ]) result Lwt.t + (string option * (Builder_db.Build.t * Builder_db.file option) list, [> error ]) result Lwt.t val job_id : string -> Caqti_lwt.connection -> ([`job] Builder_db.id option, [> Caqti_error.call_or_retrieve ]) result Lwt.t diff --git a/lib/views.ml b/lib/views.ml index 7873fdb..e38a1d9 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -83,7 +83,7 @@ let artifact ?(basename=false) job_name build { Builder_db.filepath; localpath = [ a ~a:[a_href (Fmt.strf "/job/%s/build/%a/f/%a" job_name - Uuidm.pp build.Builder_db.Build.Meta.uuid + Uuidm.pp build.Builder_db.Build.uuid Fpath.pp filepath)] [if basename then txt (Fpath.basename filepath) @@ -132,13 +132,13 @@ let builder section_job_map = a ~a:[a_href ("job/" ^ job_name ^ "/")] [txt job_name]; txt " "; - check_icon latest_build.Builder_db.Build.Meta.result; + check_icon latest_build.Builder_db.Build.result; br (); txt (Option.value ~default:"" synopsis); br (); a ~a:[a_href (Fmt.strf "job/%s/build/%a/" job_name Uuidm.pp - latest_build.Builder_db.Build.Meta.uuid)] - [txtf "%a" (Ptime.pp_human ()) latest_build.Builder_db.Build.Meta.start]; + latest_build.Builder_db.Build.uuid)] + [txtf "%a" (Ptime.pp_human ()) latest_build.Builder_db.Build.start]; txt " "; ] @ match latest_artifact with | Some main_binary -> @@ -171,9 +171,9 @@ let job name readme builds = ]; ul (List.map (fun (build, main_binary) -> li ([ - a ~a:[a_href Fpath.(to_string (v "build" / Uuidm.to_string build.Builder_db.Build.Meta.uuid / ""))] + a ~a:[a_href Fpath.(to_string (v "build" / Uuidm.to_string build.Builder_db.Build.uuid / ""))] [ - txtf "%a" (Ptime.pp_human ()) build.Builder_db.Build.Meta.start; + txtf "%a" (Ptime.pp_human ()) build.Builder_db.Build.start; ]; txt " "; check_icon build.result; @@ -192,7 +192,7 @@ let job name readme builds = let job_build name readme - { Builder_db.Build.uuid; start; finish; result; console; script; _ } + { Builder_db.Build.uuid; start; finish; result; _ } artifacts same_input_same_output different_input_same_output same_input_different_output latest_uuid @@ -216,7 +216,7 @@ let job_build p [txtf "Execution result: %a." Builder.pp_execution_result result]; ] @ (match same_input_same_output with [] -> [] | xs -> [ h3 [ txt "Reproduced by builds"] ; - p (List.concat_map (fun { Builder_db.Build.Meta.start ; uuid ; _ } -> + p (List.concat_map (fun { Builder_db.Build.start ; uuid ; _ } -> [ a ~a:[Fmt.kstr a_href "/job/%s/build/%a" name Uuidm.pp uuid] [txtf "%a" pp_ptime start] ; txt ", " ]) @@ -229,13 +229,13 @@ let job_build Uuidm.pp uuid Uuidm.pp latest_uuid] [txt "With latest build"] ; br () ] | _ -> []) @ - List.concat_map (fun { Builder_db.Build.Meta.start = other_start ; uuid = other_uuid ; _ } -> + List.concat_map (fun { Builder_db.Build.start = other_start ; uuid = other_uuid ; _ } -> let fst, snd = if Ptime.is_later ~than:start other_start then uuid, other_uuid else other_uuid, uuid in [ a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch" Uuidm.pp fst Uuidm.pp snd] [txtf "With build %a (output is identical binary)" pp_ptime other_start] ; br () ]) different_input_same_output @ - List.concat_map (fun { Builder_db.Build.Meta.start = other_start ; uuid = other_uuid ; _ } -> + List.concat_map (fun { Builder_db.Build.start = other_start ; uuid = other_uuid ; _ } -> let fst, snd = if Ptime.is_later ~than:start other_start then uuid, other_uuid else other_uuid, uuid in [ a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch" Uuidm.pp fst Uuidm.pp snd] @@ -255,6 +255,8 @@ let job_build ]; ]) artifacts); + (* + (* FIXME *) h3 [txt "Job script"]; toggleable "job-script" "Show/hide" [ pre [txt script] ]; @@ -276,6 +278,7 @@ let job_build ]) (List.rev console)); ]; + *) ]) let key_values xs = diff --git a/test/builder_db.ml b/test/builder_db.ml index 05ca48c..9eafca0 100644 --- a/test/builder_db.ml +++ b/test/builder_db.ml @@ -134,12 +134,9 @@ let test_user_unauth (module Db : CONN) = (Builder_web_auth.verify_password "wrong" auth') false let job_name = "test-job" -let script = {|#!/bin/sh - echo '#!/bin/sh' > bin/hello.sh - echo 'echo Hello, World!' > bin/hello.sh - |} +let script = Fpath.v "/dev/null" let uuid = Uuidm.create `V4 -let console = [(0, "Hello, World!")] +let console = Fpath.v "/dev/null" let start = Option.get (Ptime.of_float_s 0.) let finish = Option.get (Ptime.of_float_s 1.) let result = Builder.Exited 0 @@ -213,9 +210,9 @@ let test_build_get_all (module Db : CONN) = Db.collect_list Builder_db.Build.get_all job_id >>| fun builds -> Alcotest.(check int) "one build" (List.length builds) 1 -let test_build_get_all_meta (module Db : CONN) = +let test_build_get_all_with_main_binary (module Db : CONN) = Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id -> - Db.collect_list Builder_db.Build.get_all_meta job_id >>| fun builds -> + Db.collect_list Builder_db.Build.get_all_with_main_binary job_id >>| fun builds -> Alcotest.(check int) "one build" (List.length builds) 1 let uuid' = Uuidm.create `V4 @@ -269,9 +266,9 @@ let test_build_get_previous_none (module Db : CONN) = | Some (_id, meta) -> Alcotest.failf "Got unexpected result %a" Uuidm.pp meta.uuid -let test_build_get_by_hash (module Db : CONN) = +let test_build_get_with_jobname_by_hash (module Db : CONN) = add_second_build (module Db) >>= fun () -> - Db.find_opt Builder_db.Build.get_by_hash main_binary.sha256 + Db.find_opt Builder_db.Build.get_with_jobname_by_hash main_binary.sha256 >>| get_opt "no build" >>| fun (job_name', build) -> Alcotest.(check string) "same job" job_name' job_name; Alcotest.(check Testable.uuid) "same uuid" build.uuid uuid' @@ -326,10 +323,10 @@ let () = "build", [ test_case "Get build" `Quick (with_build_db test_build_get_by_uuid); test_case "One build" `Quick (with_build_db test_build_get_all); - test_case "One build (meta data)" `Quick (with_build_db test_build_get_all_meta); + test_case "One build (meta data)" `Quick (with_build_db test_build_get_all_with_main_binary); test_case "Get latest build" `Quick (with_build_db test_build_get_latest); test_case "Get latest build uuid" `Quick (with_build_db test_build_get_latest_uuid); - test_case "Get build by hash" `Quick (with_build_db test_build_get_by_hash); + test_case "Get build by hash" `Quick (with_build_db test_build_get_with_jobname_by_hash); test_case "Get previous build" `Quick (with_build_db test_build_get_previous); test_case "Get previous build when first" `Quick (with_build_db test_build_get_previous_none); ];