Migration code, model aware of main binary
Sqlite3 application_id and user_version are now set to identify the database is a builder-web database, and the user_version represents the schema version. The 'build' table is extended with a 'main_binary' column. This represents the main binary artifact from the build. This is decided by there being exactly one file in bin/. A migration tool is written that does both migrations and rollbacks, and migration and rollback is implemented for the above mentioned change.
This commit is contained in:
parent
a936915b74
commit
56737ec71b
8 changed files with 328 additions and 25 deletions
87
bin/migrations/builder_migrations.ml
Normal file
87
bin/migrations/builder_migrations.ml
Normal file
|
@ -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
|
4
bin/migrations/dune
Normal file
4
bin/migrations/dune
Normal file
|
@ -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 ))
|
110
bin/migrations/m20210126.ml
Normal file
110
bin/migrations/m20210126.ml
Normal file
|
@ -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) ()
|
|
@ -1,6 +1,11 @@
|
||||||
module Rep = Representation
|
module Rep = Representation
|
||||||
open Rep
|
open Rep
|
||||||
|
|
||||||
|
let application_id = 1234839235l
|
||||||
|
|
||||||
|
(* Please update this when making changes! *)
|
||||||
|
let current_version = 1L
|
||||||
|
|
||||||
type id = Rep.id
|
type id = Rep.id
|
||||||
|
|
||||||
type file = {
|
type file = {
|
||||||
|
@ -22,6 +27,29 @@ let last_insert_rowid =
|
||||||
id
|
id
|
||||||
"SELECT last_insert_rowid()"
|
"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
|
module Job = struct
|
||||||
let migrate =
|
let migrate =
|
||||||
Caqti_request.exec
|
Caqti_request.exec
|
||||||
|
@ -87,11 +115,21 @@ module Build_artifact = struct
|
||||||
Caqti_type.unit
|
Caqti_type.unit
|
||||||
"DROP TABLE IF EXISTS build_artifact"
|
"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 =
|
let get_by_build_uuid =
|
||||||
Caqti_request.find_opt
|
Caqti_request.find_opt
|
||||||
(Caqti_type.tup2 uuid fpath)
|
(Caqti_type.tup2 uuid fpath)
|
||||||
(Caqti_type.tup2 fpath cstruct)
|
(Caqti_type.tup2 id file)
|
||||||
{| SELECT build_artifact.localpath, build_artifact.sha256
|
{| SELECT build_artifact.id, build_artifact.filepath,
|
||||||
|
build_artifact.localpath, build_artifact.sha256
|
||||||
FROM build_artifact
|
FROM build_artifact
|
||||||
INNER JOIN build ON build.id = build_artifact.build
|
INNER JOIN build ON build.id = build_artifact.build
|
||||||
WHERE build.uuid = ? AND build_artifact.filepath = ?
|
WHERE build.uuid = ? AND build_artifact.filepath = ?
|
||||||
|
@ -176,6 +214,7 @@ module Build = struct
|
||||||
result : Builder.execution_result;
|
result : Builder.execution_result;
|
||||||
console : (int * string) list;
|
console : (int * string) list;
|
||||||
script : string;
|
script : string;
|
||||||
|
main_binary : Fpath.t option;
|
||||||
job_id : id;
|
job_id : id;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -190,14 +229,16 @@ module Build = struct
|
||||||
(tup2
|
(tup2
|
||||||
execution_result
|
execution_result
|
||||||
console)
|
console)
|
||||||
string)
|
(tup2
|
||||||
|
string
|
||||||
|
(option Rep.fpath)))
|
||||||
id)
|
id)
|
||||||
in
|
in
|
||||||
let encode { 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), job_id)
|
Ok ((uuid, (start, finish), (result, console), (script, main_binary)), job_id)
|
||||||
in
|
in
|
||||||
let decode ((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; job_id }
|
Ok { uuid; start; finish; result; console; script; main_binary; job_id }
|
||||||
in
|
in
|
||||||
Caqti_type.custom ~encode ~decode rep
|
Caqti_type.custom ~encode ~decode rep
|
||||||
|
|
||||||
|
@ -207,6 +248,7 @@ module Build = struct
|
||||||
start : Ptime.t;
|
start : Ptime.t;
|
||||||
finish : Ptime.t;
|
finish : Ptime.t;
|
||||||
result : Builder.execution_result;
|
result : Builder.execution_result;
|
||||||
|
main_binary : Fpath.t option;
|
||||||
job_id : id;
|
job_id : id;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -215,16 +257,18 @@ module Build = struct
|
||||||
Caqti_type.(tup2
|
Caqti_type.(tup2
|
||||||
(tup4
|
(tup4
|
||||||
uuid
|
uuid
|
||||||
Rep.ptime
|
(tup2
|
||||||
Rep.ptime
|
Rep.ptime
|
||||||
execution_result)
|
Rep.ptime)
|
||||||
|
execution_result
|
||||||
|
(option Rep.fpath))
|
||||||
id)
|
id)
|
||||||
in
|
in
|
||||||
let encode { uuid; start; finish; result; job_id } =
|
let encode { uuid; start; finish; result; main_binary; job_id } =
|
||||||
Ok ((uuid, start, finish, result), job_id)
|
Ok ((uuid, (start, finish), result, main_binary), job_id)
|
||||||
in
|
in
|
||||||
let decode ((uuid, start, finish, result), job_id) =
|
let decode ((uuid, (start, finish), result, main_binary), job_id) =
|
||||||
Ok { uuid; start; finish; result; job_id }
|
Ok { uuid; start; finish; result; main_binary; job_id }
|
||||||
in
|
in
|
||||||
Caqti_type.custom ~encode ~decode rep
|
Caqti_type.custom ~encode ~decode rep
|
||||||
end
|
end
|
||||||
|
@ -244,6 +288,7 @@ module Build = struct
|
||||||
result_msg TEXT,
|
result_msg TEXT,
|
||||||
console BLOB NOT NULL,
|
console BLOB NOT NULL,
|
||||||
script TEXT NOT NULL,
|
script TEXT NOT NULL,
|
||||||
|
main_binary TEXT,
|
||||||
job INTEGER NOT NULL,
|
job INTEGER NOT NULL,
|
||||||
|
|
||||||
FOREIGN KEY(job) REFERENCES job(id)
|
FOREIGN KEY(job) REFERENCES job(id)
|
||||||
|
@ -261,7 +306,7 @@ module Build = struct
|
||||||
t
|
t
|
||||||
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
|
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
|
||||||
result_kind, result_code, result_msg,
|
result_kind, result_code, result_msg,
|
||||||
console, script, job
|
console, script, main_binary, job
|
||||||
FROM build
|
FROM build
|
||||||
WHERE id = ?
|
WHERE id = ?
|
||||||
|}
|
|}
|
||||||
|
@ -272,7 +317,7 @@ module Build = struct
|
||||||
(Caqti_type.tup2 id t)
|
(Caqti_type.tup2 id t)
|
||||||
{| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
|
{| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
|
||||||
result_kind, result_code, result_msg,
|
result_kind, result_code, result_msg,
|
||||||
console, script, job
|
console, script, main_binary, job
|
||||||
FROM build
|
FROM build
|
||||||
WHERE uuid = ?
|
WHERE uuid = ?
|
||||||
|}
|
|}
|
||||||
|
@ -283,7 +328,7 @@ module Build = struct
|
||||||
(Caqti_type.tup2 id t)
|
(Caqti_type.tup2 id t)
|
||||||
{| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
|
{| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
|
||||||
result_kind, result_code, result_msg, console,
|
result_kind, result_code, result_msg, console,
|
||||||
script, job
|
script, main_binary, job
|
||||||
FROM build
|
FROM build
|
||||||
WHERE job = ?
|
WHERE job = ?
|
||||||
ORDER BY start_d DESC, start_ps DESC
|
ORDER BY start_d DESC, start_ps DESC
|
||||||
|
@ -295,7 +340,7 @@ module Build = struct
|
||||||
(Caqti_type.tup2
|
(Caqti_type.tup2
|
||||||
id Meta.t)
|
id Meta.t)
|
||||||
{| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
|
{| 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
|
FROM build
|
||||||
WHERE job = ?
|
WHERE job = ?
|
||||||
ORDER BY start_d DESC, start_ps DESC
|
ORDER BY start_d DESC, start_ps DESC
|
||||||
|
@ -308,7 +353,8 @@ module Build = struct
|
||||||
id Meta.t)
|
id Meta.t)
|
||||||
{| SELECT build.id, build.uuid,
|
{| SELECT build.id, build.uuid,
|
||||||
build.start_d, build.start_ps, build.finish_d, build.finish_ps,
|
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
|
FROM build, job
|
||||||
WHERE job.name = ? AND build.job = job.id
|
WHERE job.name = ? AND build.job = job.id
|
||||||
ORDER BY start_d DESC, start_ps DESC
|
ORDER BY start_d DESC, start_ps DESC
|
||||||
|
@ -320,7 +366,7 @@ module Build = struct
|
||||||
t
|
t
|
||||||
{| INSERT INTO build
|
{| INSERT INTO build
|
||||||
(uuid, start_d, start_ps, finish_d, finish_ps,
|
(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
|
VALUES
|
||||||
(?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
|
(?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
|
||||||
|}
|
|}
|
||||||
|
@ -394,6 +440,8 @@ let migrate = [
|
||||||
Build_artifact.migrate;
|
Build_artifact.migrate;
|
||||||
Build_file.migrate;
|
Build_file.migrate;
|
||||||
User.migrate;
|
User.migrate;
|
||||||
|
set_current_version;
|
||||||
|
set_application_id;
|
||||||
]
|
]
|
||||||
|
|
||||||
let rollback = [
|
let rollback = [
|
||||||
|
@ -402,4 +450,8 @@ let rollback = [
|
||||||
Build_artifact.rollback;
|
Build_artifact.rollback;
|
||||||
Build.rollback;
|
Build.rollback;
|
||||||
Job.rollback;
|
Job.rollback;
|
||||||
|
Caqti_request.exec Caqti_type.unit
|
||||||
|
"PRAGMA user_version = 0";
|
||||||
|
Caqti_request.exec Caqti_type.unit
|
||||||
|
"PRAGMA application_id = 0";
|
||||||
]
|
]
|
||||||
|
|
|
@ -7,6 +7,22 @@ type file = {
|
||||||
}
|
}
|
||||||
val file : file Caqti_type.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 :
|
val last_insert_rowid :
|
||||||
(unit, id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
|
(unit, id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
|
||||||
|
|
||||||
|
@ -35,8 +51,12 @@ module Build_artifact : sig
|
||||||
val rollback :
|
val rollback :
|
||||||
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
|
(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 :
|
val get_by_build_uuid :
|
||||||
(Uuidm.t * Fpath.t, Fpath.t * Cstruct.t,
|
(Uuidm.t * Fpath.t, id * file,
|
||||||
[< `Many | `One | `Zero > `One `Zero ])
|
[< `Many | `One | `Zero > `One `Zero ])
|
||||||
Caqti_request.t
|
Caqti_request.t
|
||||||
val get_all_by_build :
|
val get_all_by_build :
|
||||||
|
@ -74,6 +94,7 @@ sig
|
||||||
result : Builder.execution_result;
|
result : Builder.execution_result;
|
||||||
console : (int * string) list;
|
console : (int * string) list;
|
||||||
script : string;
|
script : string;
|
||||||
|
main_binary : Fpath.t option;
|
||||||
job_id : id;
|
job_id : id;
|
||||||
}
|
}
|
||||||
module Meta :
|
module Meta :
|
||||||
|
@ -83,6 +104,7 @@ sig
|
||||||
start : Ptime.t;
|
start : Ptime.t;
|
||||||
finish : Ptime.t;
|
finish : Ptime.t;
|
||||||
result : Builder.execution_result;
|
result : Builder.execution_result;
|
||||||
|
main_binary : Fpath.t option;
|
||||||
job_id : id;
|
job_id : id;
|
||||||
}
|
}
|
||||||
end
|
end
|
||||||
|
|
31
lib/model.ml
31
lib/model.ml
|
@ -32,8 +32,8 @@ let read_file filepath =
|
||||||
let build_artifact build filepath (module Db : CONN) =
|
let build_artifact 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 (localpath, sha256) ->
|
| Some (_id, file) ->
|
||||||
read_file localpath >|= fun data -> data, sha256
|
read_file file.Builder_db.localpath >|= fun data -> data, file.Builder_db.sha256
|
||||||
| None ->
|
| None ->
|
||||||
Lwt.return_error `Not_found
|
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 >|=
|
Db.find_opt Builder_db.Build.get_by_uuid uuid >|=
|
||||||
Option.is_some
|
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) =
|
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
|
||||||
|
|
||||||
|
@ -115,10 +122,28 @@ let add_build
|
||||||
let open Builder_db in
|
let open Builder_db in
|
||||||
let job_name = job.Builder.name in
|
let job_name = job.Builder.name in
|
||||||
save_all basedir exec >>= fun (artifacts, input_files) ->
|
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.exec Job.try_add job_name >>= fun () ->
|
||||||
Db.find Job.get_id_by_name job_name >>= fun job_id ->
|
Db.find Job.get_id_by_name job_name >>= fun job_id ->
|
||||||
Db.exec Build.add { Build.uuid; start; finish; result;
|
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 ->
|
Db.find last_insert_rowid () >>= fun id ->
|
||||||
List.fold_left
|
List.fold_left
|
||||||
(fun r file ->
|
(fun r file ->
|
||||||
|
|
|
@ -14,6 +14,9 @@ val build : Uuidm.t -> Caqti_lwt.connection ->
|
||||||
val build_exists : Uuidm.t -> Caqti_lwt.connection ->
|
val build_exists : Uuidm.t -> Caqti_lwt.connection ->
|
||||||
(bool, [> error ]) result Lwt.t
|
(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 ->
|
val job : string -> Caqti_lwt.connection ->
|
||||||
((Builder_db.id * Builder_db.Build.Meta.t) list, [> error ]) result Lwt.t
|
((Builder_db.id * Builder_db.Build.Meta.t) list, [> error ]) result Lwt.t
|
||||||
|
|
||||||
|
|
|
@ -116,7 +116,7 @@ let job name builds =
|
||||||
|
|
||||||
let job_build
|
let job_build
|
||||||
name
|
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
|
artifacts
|
||||||
=
|
=
|
||||||
let ptime_pp = Ptime.pp_human () in
|
let ptime_pp = Ptime.pp_human () in
|
||||||
|
|
Loading…
Reference in a new issue