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..7ebdcda 100644 --- a/db/builder_db.ml +++ b/db/builder_db.ml @@ -1,6 +1,11 @@ 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 = { @@ -22,6 +27,29 @@ let last_insert_rowid = 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 +115,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 +214,7 @@ module Build = struct result : Builder.execution_result; console : (int * string) list; script : string; + main_binary : Fpath.t option; job_id : id; } @@ -190,14 +229,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 +248,7 @@ module Build = struct start : Ptime.t; finish : Ptime.t; result : Builder.execution_result; + main_binary : Fpath.t option; job_id : id; } @@ -215,16 +257,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 +288,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 +306,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 +317,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 +328,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 +340,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 @@ -308,7 +353,8 @@ module Build = struct id Meta.t) {| 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.result_kind, build.result_code, build.result_msg, + build.main_binary, build.job FROM build, job WHERE job.name = ? AND build.job = job.id ORDER BY start_d DESC, start_ps DESC @@ -320,7 +366,7 @@ 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 (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |} @@ -394,6 +440,8 @@ let migrate = [ Build_artifact.migrate; Build_file.migrate; User.migrate; + set_current_version; + set_application_id; ] let rollback = [ @@ -402,4 +450,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..f07d714 100644 --- a/db/builder_db.mli +++ b/db/builder_db.mli @@ -7,6 +7,22 @@ type file = { } 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 +51,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 +94,7 @@ sig result : Builder.execution_result; console : (int * string) list; script : string; + main_binary : Fpath.t option; job_id : id; } module Meta : @@ -83,6 +104,7 @@ sig start : Ptime.t; finish : Ptime.t; result : Builder.execution_result; + main_binary : Fpath.t option; job_id : id; } end diff --git a/lib/model.ml b/lib/model.ml index d92316d..c19545b 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,6 +49,13 @@ let build_exists uuid (module Db : CONN) = Db.find_opt Builder_db.Build.get_by_uuid uuid >|= Option.is_some +let main_binary id { Builder_db.Build.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 @@ -115,10 +122,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.localpath + | [] -> + 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..f9e0aa1 100644 --- a/lib/model.mli +++ b/lib/model.mli @@ -14,6 +14,9 @@ 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 -> Builder_db.Build.t -> 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 diff --git a/lib/views.ml b/lib/views.ml index baeddb9..95d816a 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -116,7 +116,7 @@ let job name 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