diff --git a/bin/migrations/builder_migrations.ml b/bin/migrations/builder_migrations.ml new file mode 100644 index 0000000..b152d44 --- /dev/null +++ b/bin/migrations/builder_migrations.ml @@ -0,0 +1,87 @@ +open Rresult.R.Infix + +let pp_error ppf = function + | #Caqti_error.load_or_connect | #Caqti_error.call_or_retrieve as e -> + Caqti_error.pp ppf e + | `Wrong_version (application_id, user_version) -> + Format.fprintf ppf "wrong version { application_id: %ld, user_version: %Ld }" + application_id user_version + +let or_die exit_code = function + | Ok r -> r + | Error e -> + Format.eprintf "Database error: %a" pp_error e; + exit exit_code + +let do_database_action action () dbpath = + 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"]] ()) + |> 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 + | Ok () -> + Logs.debug (fun m -> m "Committing database transaction"); + Db.commit () + | Error _ as e -> + Logs.debug (fun m -> m "Rolling back database transaction"); + Db.rollback () >>= fun () -> + e + in + or_die 2 r + +let help man_format migrations = function + | None -> `Help (man_format, None) + | Some migration -> + if List.mem migration migrations + then `Help (man_format, Some migration) + else `Error (true, "Unknown migration: " ^ migration) + +let dbpath = + let doc = "sqlite3 database path" in + Cmdliner.Arg.(value & + opt non_dir_file "/var/db/builder-web/builder.sqlite3" & + info ~doc ["dbpath"]) + +let setup_log = + let setup_log level = + Logs.set_level level; + Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()); + in + Cmdliner.Term.(const setup_log $ Logs_cli.level ()) + +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.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.info ~doc "rollback-2021-01-26" + +let help_cmd = + let topic = + let doc = "Migration to get help on" in + Cmdliner.Arg.(value & pos 0 (some string) None & info ~doc ~docv:"MIGRATION" []) + in + let doc = "Builder migration help" in + Cmdliner.Term.(ret (const help $ man_format $ choice_names $ topic)), + Cmdliner.Term.info ~doc "help" + +let default_cmd = + let doc = "Builder migration command" in + Cmdliner.Term.(ret (const help $ man_format $ choice_names $ const None)), + Cmdliner.Term.info ~doc "builder-migrations" + +let () = + Cmdliner.Term.eval_choice + default_cmd + [help_cmd; + m20210126; r20210126] + |> Cmdliner.Term.exit diff --git a/bin/migrations/dune b/bin/migrations/dune new file mode 100644 index 0000000..76fc068 --- /dev/null +++ b/bin/migrations/dune @@ -0,0 +1,4 @@ +(executable + (public_name builder-migrations) + (name builder_migrations) + (libraries builder_db caqti caqti-driver-sqlite3 caqti.blocking cmdliner logs logs.cli logs.fmt )) diff --git a/bin/migrations/m20210126.ml b/bin/migrations/m20210126.ml new file mode 100644 index 0000000..52d5e09 --- /dev/null +++ b/bin/migrations/m20210126.ml @@ -0,0 +1,110 @@ +let new_user_version = + 1L + +let set_application_id = + Caqti_request.exec + Caqti_type.unit + (Printf.sprintf "PRAGMA application_id = %ld" Builder_db.application_id) + +let set_version version = + Caqti_request.exec ~oneshot:true + Caqti_type.unit + (Printf.sprintf "PRAGMA user_version = %Ld" version) + +let alter_build = + Caqti_request.exec ~oneshot:true + Caqti_type.unit + "ALTER TABLE build ADD COLUMN main_binary TEXT" + +let all_builds = + Caqti_request.collect ~oneshot:true + Caqti_type.unit + Caqti_type.int64 + "SELECT id FROM build" + +let bin_artifact = + Caqti_request.collect ~oneshot:true + Caqti_type.int64 + Caqti_type.(tup2 int64 string) + "SELECT id, filepath FROM build_artifact WHERE build = ? AND filepath LIKE 'bin/%'" + +let set_main_binary = + Caqti_request.exec ~oneshot:true + Caqti_type.(tup2 int64 (option string)) + "UPDATE build SET main_binary = ?2 WHERE id = ?1" + +let migrate (module Db : Caqti_blocking.CONNECTION) = + let open Rresult.R.Infix in + Db.find Builder_db.get_application_id () >>= fun application_id -> + Db.find Builder_db.get_version () >>= fun user_version -> + if application_id <> 0l || user_version <> 0L + then + Error (`Wrong_version (application_id, user_version)) + else + Db.exec alter_build () >>= fun () -> + Db.collect_list all_builds () >>= fun builds -> + List.fold_left (fun r build -> + r >>= fun () -> + Db.collect_list bin_artifact build >>= function + | [_id, main_binary] -> + Db.exec set_main_binary (build, Some main_binary) + | [] -> + Logs.debug (fun m -> m "No binaries for build id %Ld" build); + Ok () + | binaries -> + Logs.warn (fun m -> m "More than one binary for build id %Ld" build); + Logs.debug (fun m -> m "binaries: [%a]" Fmt.(list ~sep:(any ";") string) + (List.map snd binaries)); + Ok ()) + (Ok ()) + builds >>= fun () -> + Db.exec Builder_db.set_application_id () >>= fun () -> + Db.exec (set_version new_user_version) () + +let rename_build = + Caqti_request.exec + Caqti_type.unit + "ALTER TABLE build RENAME TO __tmp_build" + +let create_build = + Caqti_request.exec + Caqti_type.unit + {| CREATE TABLE 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, + job INTEGER NOT NULL, + + FOREIGN KEY(job) REFERENCES job(id) + ) + |} + +let rollback_data = + Caqti_request.exec + Caqti_type.unit + {| INSERT INTO build + SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, + result_kind, result_code, result_msg, console, script, job + FROM __tmp_build + |} + +let rollback (module Db : Caqti_blocking.CONNECTION) = + let open Rresult.R.Infix in + Db.find Builder_db.get_application_id () >>= fun application_id -> + Db.find Builder_db.get_version () >>= fun user_version -> + if application_id <> Builder_db.application_id || user_version <> new_user_version + then + Error (`Wrong_version (application_id, user_version)) + else + Db.exec rename_build () >>= fun () -> + Db.exec create_build () >>= fun () -> + Db.exec rollback_data () >>= fun () -> + Db.exec (set_version 0L) () diff --git a/db/builder_db.ml b/db/builder_db.ml index 47ce051..5187e45 100644 --- a/db/builder_db.ml +++ b/db/builder_db.ml @@ -1,27 +1,48 @@ module Rep = Representation open Rep +let application_id = 1234839235l + +(* Please update this when making changes! *) +let current_version = 1L + type id = Rep.id -type file = { +type file = Rep.file = { filepath : Fpath.t; localpath : Fpath.t; sha256 : Cstruct.t; } -let file = - let encode { filepath; localpath; sha256 } = - Ok (filepath, localpath, sha256) in - let decode (filepath, localpath, sha256) = - Ok { filepath; localpath; sha256 } in - Caqti_type.custom ~encode ~decode Caqti_type.(tup3 fpath fpath cstruct) - let last_insert_rowid = Caqti_request.find Caqti_type.unit id "SELECT last_insert_rowid()" + +let get_application_id = + Caqti_request.find + Caqti_type.unit + Caqti_type.int32 + "PRAGMA application_id" + +let get_version = + Caqti_request.find + Caqti_type.unit + Caqti_type.int64 + "PRAGMA user_version" + +let set_application_id = + Caqti_request.exec + Caqti_type.unit + (Printf.sprintf "PRAGMA application_id = %ld" application_id) + +let set_current_version = + Caqti_request.exec + Caqti_type.unit + (Printf.sprintf "PRAGMA user_version = %Ld" current_version) + module Job = struct let migrate = Caqti_request.exec @@ -87,11 +108,21 @@ module Build_artifact = struct Caqti_type.unit "DROP TABLE IF EXISTS build_artifact" + let get_by_build = + Caqti_request.find + (Caqti_type.tup2 id fpath) + (Caqti_type.tup2 id file) + {| SELECT id, filepath, localpath, sha256 + FROM build_artifact + WHERE build = ? AND filepath = ? + |} + let get_by_build_uuid = Caqti_request.find_opt (Caqti_type.tup2 uuid fpath) - (Caqti_type.tup2 fpath cstruct) - {| SELECT build_artifact.localpath, build_artifact.sha256 + (Caqti_type.tup2 id file) + {| SELECT build_artifact.id, build_artifact.filepath, + build_artifact.localpath, build_artifact.sha256 FROM build_artifact INNER JOIN build ON build.id = build_artifact.build WHERE build.uuid = ? AND build_artifact.filepath = ? @@ -176,6 +207,7 @@ module Build = struct result : Builder.execution_result; console : (int * string) list; script : string; + main_binary : Fpath.t option; job_id : id; } @@ -190,14 +222,16 @@ module Build = struct (tup2 execution_result console) - string) + (tup2 + string + (option Rep.fpath))) id) in - let encode { uuid; start; finish; result; console; script; job_id } = - Ok ((uuid, (start, finish), (result, console), script), job_id) + let encode { uuid; start; finish; result; console; script; main_binary; job_id } = + Ok ((uuid, (start, finish), (result, console), (script, main_binary)), job_id) in - let decode ((uuid, (start, finish), (result, console), script), job_id) = - Ok { uuid; start; finish; result; console; script; job_id } + let decode ((uuid, (start, finish), (result, console), (script, main_binary)), job_id) = + Ok { uuid; start; finish; result; console; script; main_binary; job_id } in Caqti_type.custom ~encode ~decode rep @@ -207,6 +241,7 @@ module Build = struct start : Ptime.t; finish : Ptime.t; result : Builder.execution_result; + main_binary : Fpath.t option; job_id : id; } @@ -215,16 +250,18 @@ module Build = struct Caqti_type.(tup2 (tup4 uuid - Rep.ptime - Rep.ptime - execution_result) + (tup2 + Rep.ptime + Rep.ptime) + execution_result + (option Rep.fpath)) id) in - let encode { uuid; start; finish; result; job_id } = - Ok ((uuid, start, finish, result), job_id) + let encode { uuid; start; finish; result; main_binary; job_id } = + Ok ((uuid, (start, finish), result, main_binary), job_id) in - let decode ((uuid, start, finish, result), job_id) = - Ok { uuid; start; finish; result; job_id } + let decode ((uuid, (start, finish), result, main_binary), job_id) = + Ok { uuid; start; finish; result; main_binary; job_id } in Caqti_type.custom ~encode ~decode rep end @@ -244,6 +281,7 @@ module Build = struct result_msg TEXT, console BLOB NOT NULL, script TEXT NOT NULL, + main_binary TEXT, job INTEGER NOT NULL, FOREIGN KEY(job) REFERENCES job(id) @@ -261,7 +299,7 @@ module Build = struct t {| SELECT uuid, start_d, start_ps, finish_d, finish_ps, result_kind, result_code, result_msg, - console, script, job + console, script, main_binary, job FROM build WHERE id = ? |} @@ -272,7 +310,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, job + console, script, main_binary, job FROM build WHERE uuid = ? |} @@ -283,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, job + script, main_binary, job FROM build WHERE job = ? ORDER BY start_d DESC, start_ps DESC @@ -295,7 +333,7 @@ module Build = struct (Caqti_type.tup2 id Meta.t) {| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps, - result_kind, result_code, result_msg, job + result_kind, result_code, result_msg, main_binary, job FROM build WHERE job = ? ORDER BY start_d DESC, start_ps DESC @@ -304,12 +342,18 @@ module Build = struct let get_all_meta_by_name = Caqti_request.collect Caqti_type.string - (Caqti_type.tup2 - id Meta.t) + (Caqti_type.tup3 + id + Meta.t + file_opt) {| 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.job + 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_artifact.filepath, build_artifact.localpath, build_artifact.sha256 FROM build, job + LEFT JOIN build_artifact ON + build_artifact.build = build.id AND build.main_binary = build_artifact.filepath WHERE job.name = ? AND build.job = job.id ORDER BY start_d DESC, start_ps DESC |} @@ -320,9 +364,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, job) + result_kind, result_code, result_msg, console, script, main_binary, job) VALUES - (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) + (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |} end @@ -394,6 +438,8 @@ let migrate = [ Build_artifact.migrate; Build_file.migrate; User.migrate; + set_current_version; + set_application_id; ] let rollback = [ @@ -402,4 +448,8 @@ let rollback = [ Build_artifact.rollback; Build.rollback; Job.rollback; + Caqti_request.exec Caqti_type.unit + "PRAGMA user_version = 0"; + Caqti_request.exec Caqti_type.unit + "PRAGMA application_id = 0"; ] diff --git a/db/builder_db.mli b/db/builder_db.mli index 5c38737..6745394 100644 --- a/db/builder_db.mli +++ b/db/builder_db.mli @@ -5,7 +5,22 @@ type file = { localpath : Fpath.t; sha256 : Cstruct.t; } -val file : file Caqti_type.t + +val application_id : int32 + +val current_version : int64 + +val get_application_id : + (unit, int32, [< `Many | `One | `Zero > `One ]) Caqti_request.t + +val set_application_id : + (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t + +val get_version : + (unit, int64, [< `Many | `One | `Zero > `One ]) Caqti_request.t + +val set_current_version : + (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t val last_insert_rowid : (unit, id, [< `Many | `One | `Zero > `One ]) Caqti_request.t @@ -35,8 +50,12 @@ module Build_artifact : sig val rollback : (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t + val get_by_build : + (id * Fpath.t, id * file, + [< `Many | `One | `Zero > `One ]) Caqti_request.t + val get_by_build_uuid : - (Uuidm.t * Fpath.t, Fpath.t * Cstruct.t, + (Uuidm.t * Fpath.t, id * file, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t val get_all_by_build : @@ -74,6 +93,7 @@ sig result : Builder.execution_result; console : (int * string) list; script : string; + main_binary : Fpath.t option; job_id : id; } module Meta : @@ -83,6 +103,7 @@ sig start : Ptime.t; finish : Ptime.t; result : Builder.execution_result; + main_binary : Fpath.t option; job_id : id; } end @@ -102,7 +123,7 @@ sig val get_all_meta : (id, id * Meta.t, [ `Many | `One | `Zero ]) Caqti_request.t val get_all_meta_by_name : - (string, id * Meta.t, [ `Many | `One | `Zero ]) Caqti_request.t + (string, id * Meta.t * file option, [ `Many | `One | `Zero ]) Caqti_request.t val add : (t, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t end diff --git a/db/representation.ml b/db/representation.ml index d1809ff..482339f 100644 --- a/db/representation.ml +++ b/db/representation.ml @@ -23,6 +23,12 @@ end type id = int64 let id = Caqti_type.int64 +type file = { + filepath : Fpath.t; + localpath : Fpath.t; + sha256 : Cstruct.t; +} + let uuid = let encode uuid = Ok (Uuidm.to_bytes uuid) in let decode s = @@ -50,6 +56,32 @@ let cstruct = let decode s = Ok (Cstruct.of_string s) in Caqti_type.custom ~encode ~decode Caqti_type.octets +let file = + let encode { filepath; localpath; sha256 } = + Ok (filepath, localpath, sha256) in + let decode (filepath, localpath, sha256) = + Ok { filepath; localpath; sha256 } in + Caqti_type.custom ~encode ~decode Caqti_type.(tup3 fpath fpath cstruct) + +let file_opt = + let rep = Caqti_type.(tup3 (option fpath) (option fpath) (option cstruct)) in + let encode = function + | Some { filepath; localpath; sha256 } -> + Ok (Some filepath, Some localpath, Some sha256) + | None -> + Ok (None, None, None) + in + let decode = function + | (Some filepath, Some localpath, Some sha256) -> + Ok (Some { filepath; localpath; sha256 }) + | (None, None, None) -> + Ok None + | _ -> + (* This should not happen if the database is well-formed *) + Error "Some but not all fields NULL" + in + Caqti_type.custom ~encode ~decode rep + let execution_result = let encode = function | Builder.Exited v -> Ok (0, Some v, None) diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 1037c1f..ed74ad2 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -86,14 +86,16 @@ let routes t = let job req = let job_name = Router.param req "job" in - let+ job = Caqti_lwt.Pool.use (Model.job job_name) t.pool in + let+ job = + Caqti_lwt.Pool.use (Model.job job_name) t.pool + in match job with | Error e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e); Response.of_plain_text ~status:`Internal_server_error "Error getting job" | Ok builds -> - Views.job job_name (List.map snd builds) |> Response.of_html + Views.job job_name builds |> Response.of_html in let job_build req = diff --git a/lib/model.ml b/lib/model.ml index d92316d..80db6d0 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -32,8 +32,8 @@ let read_file filepath = let build_artifact build filepath (module Db : CONN) = Db.find_opt Builder_db.Build_artifact.get_by_build_uuid (build, filepath) >>= function - | Some (localpath, sha256) -> - read_file localpath >|= fun data -> data, sha256 + | Some (_id, file) -> + read_file file.Builder_db.localpath >|= fun data -> data, file.Builder_db.sha256 | None -> Lwt.return_error `Not_found @@ -49,8 +49,16 @@ let build_exists uuid (module Db : CONN) = Db.find_opt Builder_db.Build.get_by_uuid uuid >|= Option.is_some +let main_binary id main_binary (module Db : CONN) = + match main_binary with + | None -> Lwt_result.return None + | Some main_binary -> + Db.find Builder_db.Build_artifact.get_by_build (id, main_binary) >|= fun (_id, file) -> + Some file + let job job (module Db : CONN) = - Db.collect_list Builder_db.Build.get_all_meta_by_name job + Db.collect_list Builder_db.Build.get_all_meta_by_name job >|= + List.map (fun (_id, meta, main_binary) -> (meta, main_binary)) let jobs (module Db : CONN) = Db.collect_list Builder_db.Job.get_all () >|= @@ -115,10 +123,28 @@ let add_build let open Builder_db in let job_name = job.Builder.name in save_all basedir exec >>= fun (artifacts, input_files) -> + let main_binary = + match List.find_all + (fun file -> + Fpath.is_prefix + (Fpath.v "bin/") + file.Builder_db.filepath) + artifacts with + | [ main_binary ] -> Some main_binary.filepath + | [] -> + Log.debug (fun m -> m "Zero binaries for build %a" Uuidm.pp uuid); + None + | binaries -> + Log.debug (fun m -> m "Multiple binaries for build %a: %a" Uuidm.pp uuid + Fmt.(list ~sep:(any ",") Fpath.pp) + (List.map (fun f -> f.filepath) binaries)); + None + in Db.exec Job.try_add job_name >>= fun () -> Db.find Job.get_id_by_name job_name >>= fun job_id -> Db.exec Build.add { Build.uuid; start; finish; result; - console; script = job.Builder.script; job_id } >>= fun () -> + console; script = job.Builder.script; + main_binary; job_id } >>= fun () -> Db.find last_insert_rowid () >>= fun id -> List.fold_left (fun r file -> diff --git a/lib/model.mli b/lib/model.mli index 7081f74..f8b01a4 100644 --- a/lib/model.mli +++ b/lib/model.mli @@ -14,8 +14,11 @@ val build : Uuidm.t -> Caqti_lwt.connection -> val build_exists : Uuidm.t -> Caqti_lwt.connection -> (bool, [> error ]) result Lwt.t +val main_binary : Builder_db.id -> Fpath.t option -> Caqti_lwt.connection -> + (Builder_db.file option, [> error ]) result Lwt.t + val job : string -> Caqti_lwt.connection -> - ((Builder_db.id * Builder_db.Build.Meta.t) list, [> error ]) result Lwt.t + ((Builder_db.Build.Meta.t * Builder_db.file option) list, [> error ]) result Lwt.t val jobs : Caqti_lwt.connection -> (string list, [> error ]) result Lwt.t diff --git a/lib/views.ml b/lib/views.ml index baeddb9..00340b1 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -101,22 +101,35 @@ let job name builds = txtf "Currently %d builds." (List.length builds) ]; - ul (List.map (fun build -> - li [ - a ~a:[a_href Fpath.(to_string (v "build" / Uuidm.to_string build.Builder_db.Build.Meta.uuid) ^ "/")] + 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 / ""))] + [ + txtf "%a" (Ptime.pp_human ()) build.Builder_db.Build.Meta.start; + ]; + txt " "; + check_icon build.result; + br (); + ] @ match main_binary with + | Some main_binary -> [ - txtf "%a" (Ptime.pp_human ()) build.Builder_db.Build.Meta.start; - ]; - txt " "; - check_icon build.result; - ]) + a ~a:[a_href Fpath.(to_string (v "build" / Uuidm.to_string build.Builder_db.Build.Meta.uuid + / "f" // main_binary.Builder_db.filepath))] + [txtf "%s" (Fpath.basename main_binary.Builder_db.filepath)]; + txt " "; + code [txtf "SHA256:%a" Hex.pp (Hex.of_cstruct main_binary.Builder_db.sha256)]; + ] + | None -> + [ + txtf "Build failed"; + ])) builds); ] let job_build name - { Builder_db.Build.uuid = _; start; finish; result; console; script; job_id = _ } + { Builder_db.Build.uuid = _; start; finish; result; console; script; main_binary = _; job_id = _ } artifacts = let ptime_pp = Ptime.pp_human () in