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

WIP

Browse source
This commit is contained in:
Robur 2021-08-31 11:59:45 +00:00
parent 0d918192ea
commit 17420c389b
8 changed files with 311 additions and 126 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
bin/builder_db.ml
View file

@ -139,15 +139,15 @@ let job_remove () datadir jobname =
Db.start () >>= fun () -> Db.start () >>= fun () ->
Db.exec defer_foreign_keys () >>= fun () -> Db.exec defer_foreign_keys () >>= fun () ->
let r = let r =
Db.collect_list Builder_db.Build.get_all_meta job_id >>= fun builds -> Db.collect_list Builder_db.Build.get_all job_id >>= fun builds ->
List.fold_left (fun r (build, meta, _) -> List.fold_left (fun r (build_id, build) ->
r >>= fun () -> 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 (match Bos.OS.Dir.delete ~recurse:true dir with
| Ok _ -> () | Ok _ -> ()
| Error `Msg e -> Logs.warn (fun m -> m "failed to remove build directory %a: %s" Fpath.pp dir e)); | 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_artifact.remove_by_build build_id >>= fun () ->
Db.exec Builder_db.Build.remove build) Db.exec Builder_db.Build.remove build_id)
(Ok ()) (Ok ())
builds >>= fun () -> builds >>= fun () ->
Db.exec Builder_db.Job.remove job_id >>= fun () -> Db.exec Builder_db.Job.remove job_id >>= fun () ->

220
bin/migrations/m20210712c.ml Normal file
View file

@ -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<opam-switch> || sha256<build-environment> || sha256<system-packages>)
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<opam-switch> || sha256<build-environment> || sha256<system-packages>)
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) ()

88
db/builder_db.ml
View file

@ -4,7 +4,7 @@ open Rep
let application_id = 1234839235l let application_id = 1234839235l
(* Please update this when making changes! *) (* Please update this when making changes! *)
let current_version = 13L let current_version = 14L
type 'a id = 'a Rep.id type 'a id = 'a Rep.id
@ -239,8 +239,8 @@ module Build = struct
start : Ptime.t; start : Ptime.t;
finish : Ptime.t; finish : Ptime.t;
result : Builder.execution_result; result : Builder.execution_result;
console : (int * string) list; console : Fpath.t;
script : string; script : Fpath.t;
main_binary : [`build_artifact] id option; main_binary : [`build_artifact] id option;
input_id : Cstruct.t option; input_id : Cstruct.t option;
user_id : [`user] id; user_id : [`user] id;
@ -257,9 +257,9 @@ module Build = struct
Rep.ptime) Rep.ptime)
(tup2 (tup2
execution_result execution_result
console) fpath)
(tup3 (tup3
string fpath
(option (Rep.id `build_artifact)) (option (Rep.id `build_artifact))
(option Rep.cstruct))) (option Rep.cstruct)))
(id `user) (id `user)
@ -273,42 +273,6 @@ module Build = struct
in in
Caqti_type.custom ~encode ~decode rep 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 = let migrate =
Caqti_request.exec Caqti_request.exec
Caqti_type.unit Caqti_type.unit
@ -321,7 +285,7 @@ module Build = struct
finish_ps INTEGER NOT NULL, finish_ps INTEGER NOT NULL,
result_code INTEGER NOT NULL, result_code INTEGER NOT NULL,
result_msg TEXT, result_msg TEXT,
console BLOB NOT NULL, console TEXT NOT NULL,
script TEXT NOT NULL, script TEXT NOT NULL,
main_binary INTEGER, main_binary INTEGER,
user INTEGER NOT NULL, user INTEGER NOT NULL,
@ -373,14 +337,14 @@ module Build = struct
ORDER BY start_d DESC, start_ps DESC ORDER BY start_d DESC, start_ps DESC
|} |}
let get_all_meta = let get_all_with_main_binary =
Caqti_request.collect Caqti_request.collect
(id `job) (id `job)
(Caqti_type.tup3 (Caqti_type.tup3
(id `build) Meta.t file_opt) (id `build) t file_opt)
{| 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_code, build.result_msg, build.result_code, build.result_msg, console, script,
build.main_binary, build.input_id, build.user, build.job, build.main_binary, build.input_id, build.user, build.job,
build_artifact.filepath, build_artifact.localpath, build_artifact.sha256, build_artifact.size build_artifact.filepath, build_artifact.localpath, build_artifact.sha256, build_artifact.size
FROM build, job FROM build, job
@ -403,9 +367,9 @@ module Build = struct
let get_latest_failed = let get_latest_failed =
Caqti_request.find_opt Caqti_request.find_opt
(id `job) (id `job)
Meta.t t
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps, {| 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 main_binary, input_id, user, job
FROM build FROM build
WHERE job = ? AND result_code <> 0 WHERE job = ? AND result_code <> 0
@ -418,11 +382,11 @@ module Build = struct
(id `job) (id `job)
Caqti_type.(tup3 Caqti_type.(tup3
(id `build) (id `build)
Meta.t t
file_opt) file_opt)
{| SELECT b.id, {| SELECT b.id,
b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, 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, b.main_binary, b.input_id, b.user, b.job,
a.filepath, a.localpath, a.sha256, a.size a.filepath, a.localpath, a.sha256, a.size
FROM build b FROM build b
@ -458,10 +422,10 @@ module Build = struct
let get_previous_successful = let get_previous_successful =
Caqti_request.find_opt Caqti_request.find_opt
(id `build) (id `build)
Caqti_type.(tup2 (id `build) Meta.t) Caqti_type.(tup2 (id `build) t)
{| SELECT b.id, {| SELECT b.id,
b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, 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 b.main_binary, b.input_id, b.user, b.job
FROM build b, build b0 FROM build b, build b0
WHERE b0.id = ? AND b0.job = b.job AND WHERE b0.id = ? AND b0.job = b.job AND
@ -474,9 +438,9 @@ module Build = struct
let get_same_input_same_output_builds = let get_same_input_same_output_builds =
Caqti_request.collect Caqti_request.collect
(id `build) (id `build)
Meta.t t
{| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, {| 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 b.main_binary, b.input_id, b.user, b.job
FROM build b0, build_artifact a0, build b, build_artifact a 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 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 = let get_one_by_input_id =
Caqti_request.find Caqti_request.find
Rep.cstruct Rep.cstruct
Meta.t t
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps, {| 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 main_binary, input_id, user, job
FROM build FROM build
WHERE input_id = ? WHERE input_id = ?
@ -528,13 +492,13 @@ module Build = struct
(?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
|} |}
let get_meta_by_hash = let get_by_hash =
Caqti_request.find Caqti_request.find
Rep.cstruct Rep.cstruct
Meta.t t
{| SELECT {| SELECT
b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps, 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 b.main_binary, b.input_id, b.user, b.job
FROM build_artifact a FROM build_artifact a
INNER JOIN build b ON b.id = a.build INNER JOIN build b ON b.id = a.build
@ -543,12 +507,12 @@ module Build = struct
LIMIT 1 LIMIT 1
|} |}
let get_meta_and_artifact_by_hash = let get_with_main_binary_by_hash =
Caqti_request.find Caqti_request.find
Rep.cstruct 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, {| 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, b.main_binary, b.input_id, b.user, b.job,
a.filepath, a.localpath, a.sha256, a.size a.filepath, a.localpath, a.sha256, a.size
FROM build_artifact a FROM build_artifact a
@ -558,7 +522,7 @@ module Build = struct
LIMIT 1 LIMIT 1
|} |}
let get_by_hash = let get_with_jobname_by_hash =
Caqti_request.find_opt Caqti_request.find_opt
Rep.cstruct Rep.cstruct
(Caqti_type.tup2 (Caqti_type.tup2

39
db/builder_db.mli
View file

@ -124,26 +124,13 @@ sig
start : Ptime.t; start : Ptime.t;
finish : Ptime.t; finish : Ptime.t;
result : Builder.execution_result; result : Builder.execution_result;
console : (int * string) list; console : Fpath.t;
script : string; script : Fpath.t;
main_binary : [`build_artifact] id option; main_binary : [`build_artifact] id option;
input_id : Cstruct.t option; input_id : Cstruct.t option;
user_id : [`user] id; user_id : [`user] id;
job_id : [`job] 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 : val migrate :
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t (unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
@ -157,15 +144,15 @@ sig
Caqti_request.t Caqti_request.t
val get_all : val get_all :
([`job] id, [`build] id * t, [ `Many | `One | `Zero ]) Caqti_request.t ([`job] id, [`build] id * t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_all_meta : val get_all_with_main_binary :
([`job] id, [`build] id * Meta.t * file option, [ `Many | `One | `Zero ]) Caqti_request.t ([`job] id, [`build] id * t * file option, [ `Many | `One | `Zero ]) Caqti_request.t
val get_all_artifact_sha : val get_all_artifact_sha :
([`job] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t ([`job] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_latest : 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 Caqti_request.t
val get_latest_failed : 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 : val get_latest_uuid :
([`job] id, [`build] id * Uuidm.t, [< `Many | `One | `Zero > `One `Zero ]) ([`job] id, [`build] id * Uuidm.t, [< `Many | `One | `Zero > `One `Zero ])
Caqti_request.t Caqti_request.t
@ -173,22 +160,22 @@ sig
([`job] id, Uuidm.t, [< `Many | `One | `Zero > `One `Zero ]) ([`job] id, Uuidm.t, [< `Many | `One | `Zero > `One `Zero ])
Caqti_request.t Caqti_request.t
val get_previous_successful : 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 Caqti_request.t
val get_same_input_same_output_builds : 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 : val get_same_input_different_output_hashes :
([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t ([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_different_input_same_output_input_ids : val get_different_input_same_output_input_ids :
([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t ([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_one_by_input_id : 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 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 : 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 (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 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 val remove : ([`build] id, unit, [< `Many | `One | `Zero > `Zero]) Caqti_request.t

26
lib/model.ml
View file

@ -52,7 +52,7 @@ let build_meta job (module Db : CONN) =
Option.map (fun (_id, meta, file) -> (meta, file)) Option.map (fun (_id, meta, file) -> (meta, file))
let build_hash hash (module Db : CONN) = 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) = 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 >|=
@ -89,11 +89,10 @@ let builds_with_same_input_and_different_main_binary id (module Db : CONN) =
match acc with match acc with
| Error _ as e -> Lwt.return e | Error _ as e -> Lwt.return e
| Ok metas -> | 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))) Lwt.return (Ok (build :: metas)))
(Ok []) hashes (Ok []) hashes
let job_id job_name (module Db : CONN) = let job_id job_name (module Db : CONN) =
Db.find_opt Builder_db.Job.get_id_by_name job_name 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 match acc with
| Error _ as e -> Lwt.return e | Error _ as e -> Lwt.return e
| Ok (fail, metas) -> | 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 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) | x -> x, (meta, file) :: metas)
(Ok (failed, [])) sha >|= fun (x, builds) -> (Ok (failed, [])) sha >|= fun (x, builds) ->
let builds = match x with None -> builds | Some f -> (f, None) :: builds in 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])) | Some a, Some b, Some c -> Some (Mirage_crypto.Hash.SHA256.digest (Cstruct.concat [a;b;c]))
| _ -> None | _ -> 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 let add_build
datadir datadir
user_id user_id
@ -303,6 +315,8 @@ let add_build
in in
List.filter (fun (p, _) -> not (not_interesting p)) raw_artifacts List.filter (fun (p, _) -> not (not_interesting p)) raw_artifacts
in 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 -> or_cleanup (save_all staging_dir job uuid artifacts_to_preserve) >>= fun artifacts ->
let r = let r =
Db.start () >>= fun () -> Db.start () >>= fun () ->
@ -323,7 +337,7 @@ let add_build
Db.find Tag.get_id_by_name readme_tag >>= fun readme_id -> Db.find Tag.get_id_by_name readme_tag >>= fun readme_id ->
let input_id = compute_input_id artifacts in let input_id = compute_input_id artifacts in
Db.exec Build.add { Build.uuid; start; finish; result; 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 () -> main_binary = None; input_id; user_id; job_id } >>= fun () ->
Db.find last_insert_rowid () >>= fun id -> Db.find last_insert_rowid () >>= fun id ->
let sec_syn = infer_section_and_synopsis job_name raw_artifacts in let sec_syn = infer_section_and_synopsis job_name raw_artifacts in

12
lib/model.mli
View file

@ -22,7 +22,7 @@ val build : Uuidm.t -> Caqti_lwt.connection ->
([`build] Builder_db.id * Builder_db.Build.t, [> error ]) result Lwt.t ([`build] Builder_db.id * Builder_db.Build.t, [> error ]) result Lwt.t
val build_meta : [`job] Builder_db.id -> Caqti_lwt.connection -> 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 -> val build_hash : Cstruct.t -> Caqti_lwt.connection ->
((string * Builder_db.Build.t) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t ((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 (Uuidm.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val previous_successful_build : [`build] Builder_db.id -> Caqti_lwt.connection -> 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 -> 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 -> 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 -> 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 -> val readme : string -> Caqti_lwt.connection ->
(string option, [> error ]) result Lwt.t (string option, [> error ]) result Lwt.t
val job_and_readme : string -> Caqti_lwt.connection -> 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 -> val job_id : string -> Caqti_lwt.connection ->
([`job] Builder_db.id option, [> Caqti_error.call_or_retrieve ]) result Lwt.t ([`job] Builder_db.id option, [> Caqti_error.call_or_retrieve ]) result Lwt.t

23
lib/views.ml
View file

@ -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" a ~a:[a_href (Fmt.strf "/job/%s/build/%a/f/%a"
job_name job_name
Uuidm.pp build.Builder_db.Build.Meta.uuid Uuidm.pp build.Builder_db.Build.uuid
Fpath.pp filepath)] Fpath.pp filepath)]
[if basename [if basename
then txt (Fpath.basename filepath) then txt (Fpath.basename filepath)
@ -132,13 +132,13 @@ let builder section_job_map =
a ~a:[a_href ("job/" ^ job_name ^ "/")] a ~a:[a_href ("job/" ^ job_name ^ "/")]
[txt job_name]; [txt job_name];
txt " "; txt " ";
check_icon latest_build.Builder_db.Build.Meta.result; check_icon latest_build.Builder_db.Build.result;
br (); br ();
txt (Option.value ~default:"" synopsis); txt (Option.value ~default:"" synopsis);
br (); br ();
a ~a:[a_href (Fmt.strf "job/%s/build/%a/" job_name Uuidm.pp a ~a:[a_href (Fmt.strf "job/%s/build/%a/" job_name Uuidm.pp
latest_build.Builder_db.Build.Meta.uuid)] latest_build.Builder_db.Build.uuid)]
[txtf "%a" (Ptime.pp_human ()) latest_build.Builder_db.Build.Meta.start]; [txtf "%a" (Ptime.pp_human ()) latest_build.Builder_db.Build.start];
txt " "; txt " ";
] @ match latest_artifact with ] @ match latest_artifact with
| Some main_binary -> | Some main_binary ->
@ -171,9 +171,9 @@ let job name readme builds =
]; ];
ul (List.map (fun (build, main_binary) -> ul (List.map (fun (build, main_binary) ->
li ([ 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 " "; txt " ";
check_icon build.result; check_icon build.result;
@ -192,7 +192,7 @@ let job name readme builds =
let job_build let job_build
name name
readme readme
{ Builder_db.Build.uuid; start; finish; result; console; script; _ } { Builder_db.Build.uuid; start; finish; result; _ }
artifacts artifacts
same_input_same_output different_input_same_output same_input_different_output same_input_same_output different_input_same_output same_input_different_output
latest_uuid latest_uuid
@ -216,7 +216,7 @@ let job_build
p [txtf "Execution result: %a." Builder.pp_execution_result result]; ] @ p [txtf "Execution result: %a." Builder.pp_execution_result result]; ] @
(match same_input_same_output with [] -> [] | xs -> [ (match same_input_same_output with [] -> [] | xs -> [
h3 [ txt "Reproduced by builds"] ; 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] [ a ~a:[Fmt.kstr a_href "/job/%s/build/%a" name Uuidm.pp uuid]
[txtf "%a" pp_ptime start] ; [txtf "%a" pp_ptime start] ;
txt ", " ]) txt ", " ])
@ -229,13 +229,13 @@ let job_build
Uuidm.pp uuid Uuidm.pp latest_uuid] Uuidm.pp uuid Uuidm.pp latest_uuid]
[txt "With latest build"] ; br () ] [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 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" [ a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch"
Uuidm.pp fst Uuidm.pp snd] Uuidm.pp fst Uuidm.pp snd]
[txtf "With build %a (output is identical binary)" pp_ptime other_start] ; br () ]) [txtf "With build %a (output is identical binary)" pp_ptime other_start] ; br () ])
different_input_same_output @ 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 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" [ a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch"
Uuidm.pp fst Uuidm.pp snd] Uuidm.pp fst Uuidm.pp snd]
@ -255,6 +255,8 @@ let job_build
]; ];
]) ])
artifacts); artifacts);
(*
(* FIXME *)
h3 [txt "Job script"]; h3 [txt "Job script"];
toggleable "job-script" "Show/hide" toggleable "job-script" "Show/hide"
[ pre [txt script] ]; [ pre [txt script] ];
@ -276,6 +278,7 @@ let job_build
]) ])
(List.rev console)); (List.rev console));
]; ];
*)
]) ])
let key_values xs = let key_values xs =

19
test/builder_db.ml
View file

@ -134,12 +134,9 @@ let test_user_unauth (module Db : CONN) =
(Builder_web_auth.verify_password "wrong" auth') false (Builder_web_auth.verify_password "wrong" auth') false
let job_name = "test-job" let job_name = "test-job"
let script = {|#!/bin/sh let script = Fpath.v "/dev/null"
echo '#!/bin/sh' > bin/hello.sh
echo 'echo Hello, World!' > bin/hello.sh
|}
let uuid = Uuidm.create `V4 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 start = Option.get (Ptime.of_float_s 0.)
let finish = Option.get (Ptime.of_float_s 1.) let finish = Option.get (Ptime.of_float_s 1.)
let result = Builder.Exited 0 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 -> Db.collect_list Builder_db.Build.get_all job_id >>| fun builds ->
Alcotest.(check int) "one build" (List.length builds) 1 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.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 Alcotest.(check int) "one build" (List.length builds) 1
let uuid' = Uuidm.create `V4 let uuid' = Uuidm.create `V4
@ -269,9 +266,9 @@ let test_build_get_previous_none (module Db : CONN) =
| Some (_id, meta) -> | Some (_id, meta) ->
Alcotest.failf "Got unexpected result %a" Uuidm.pp meta.uuid 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 () -> 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) -> >>| get_opt "no build" >>| fun (job_name', build) ->
Alcotest.(check string) "same job" job_name' job_name; Alcotest.(check string) "same job" job_name' job_name;
Alcotest.(check Testable.uuid) "same uuid" build.uuid uuid' Alcotest.(check Testable.uuid) "same uuid" build.uuid uuid'
@ -326,10 +323,10 @@ let () =
"build", [ "build", [
test_case "Get build" `Quick (with_build_db test_build_get_by_uuid); 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" `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" `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 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" `Quick (with_build_db test_build_get_previous);
test_case "Get previous build when first" `Quick (with_build_db test_build_get_previous_none); test_case "Get previous build when first" `Quick (with_build_db test_build_get_previous_none);
]; ];