robur/builder-web
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge pull request 'Schema versioning and main binary' (#22) from schema-versioning into main

Browse source 
Reviewed-on: https://git.robur.io/robur/builder-web/pulls/22
This commit is contained in:
Reynir Björnsson 2021-01-29 09:52:38 +00:00
commit 1dce5eeda3
10 changed files with 399 additions and 51 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

87
bin/migrations/builder_migrations.ml Normal file
View 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
View 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
View 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) ()

110
db/builder_db.ml
View file

@ -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
(tup2
Rep.ptime
Rep.ptime
execution_result)
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.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";
]

27
db/builder_db.mli
View file

@ -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

32
db/representation.ml
View file

@ -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)

6
lib/builder_web.ml
View file

@ -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 =

34
lib/model.ml
View file

@ -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 ->

5
lib/model.mli
View file

@ -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

23
lib/views.ml
View file

@ -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 ->
[
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