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

Show builds by platform

Browse source
This commit is contained in:
Robur 2021-11-08 10:55:11 +00:00
parent 594c6d5917
commit 16748b8995
7 changed files with 260 additions and 184 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

69
db/builder_db.ml
View file

@ -325,6 +325,16 @@ module Build = struct
ORDER BY b.start_d DESC, b.start_ps DESC ORDER BY b.start_d DESC, b.start_ps DESC
|} |}
let get_all_artifact_sha_by_platform =
Caqti_request.collect
Caqti_type.(tup2 (id `job) string)
Rep.cstruct
{| SELECT DISTINCT a.sha256
FROM build_artifact a, build b
WHERE b.job = ? AND b.platform = ? AND b.main_binary = a.id
ORDER BY b.start_d DESC, b.start_ps DESC
|}
let get_latest_failed = let get_latest_failed =
Caqti_request.find_opt Caqti_request.find_opt
(id `job) (id `job)
@ -338,9 +348,22 @@ module Build = struct
LIMIT 1 LIMIT 1
|} |}
let get_latest_failed_by_platform =
Caqti_request.find_opt
Caqti_type.(tup2 (id `job) string)
t
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
result_code, result_msg, console, script,
platform, main_binary, input_id, user, job
FROM build
WHERE job = ? AND platform = ? AND result_code <> 0
ORDER BY start_d DESC, start_ps DESC
LIMIT 1
|}
let get_latest = let get_latest =
Caqti_request.find_opt Caqti_request.find_opt
(id `job) Caqti_type.(tup2 (id `job) string)
Caqti_type.(tup3 Caqti_type.(tup3
(id `build) (id `build)
t t
@ -353,7 +376,7 @@ module Build = struct
FROM build b FROM build b
LEFT JOIN build_artifact a ON LEFT JOIN build_artifact a ON
b.main_binary = a.id b.main_binary = a.id
WHERE b.job = ? WHERE b.job = ?1 AND b.platform = ?2
ORDER BY b.start_d DESC, b.start_ps DESC ORDER BY b.start_d DESC, b.start_ps DESC
LIMIT 1 LIMIT 1
|} |}
@ -369,22 +392,46 @@ module Build = struct
LIMIT 1 LIMIT 1
|} |}
let get_previous_successful = let get_latest_successful_uuid_by_platform =
Caqti_request.find_opt
Caqti_type.(tup2 (id `job) string)
Rep.uuid
{| SELECT b.uuid
FROM build b
WHERE b.job = ?1 AND b.result_code = 0 AND b.platform = ?2
ORDER BY b.start_d DESC, b.start_ps DESC
LIMIT 1
|}
let get_previous_successful_uuid =
Caqti_request.find_opt Caqti_request.find_opt
(id `build) (id `build)
Caqti_type.(tup2 (id `build) t) Rep.uuid
{| SELECT b.id, {| SELECT b.uuid
b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
b.result_code, b.result_msg, b.console, b.script,
b.platform, 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
b.platform = b0.platform AND
b.result_code = 0 AND b.result_code = 0 AND
(b0.start_d > b.start_d OR b0.start_d = b.start_d AND b0.start_ps > b.start_ps) (b0.start_d > b.start_d OR b0.start_d = b.start_d AND b0.start_ps > b.start_ps)
ORDER BY b.start_d DESC, b.start_ps DESC ORDER BY b.start_d DESC, b.start_ps DESC
LIMIT 1 LIMIT 1
|} |}
let get_next_successful_uuid =
Caqti_request.find_opt
(id `build)
Rep.uuid
{| SELECT b.uuid
FROM build b, build b0
WHERE b0.id = ? AND b0.job = b.job AND
b.platform = b0.platform AND
b.result_code = 0 AND
(b0.start_d < b.start_d OR b0.start_d = b.start_d AND b0.start_ps < b.start_ps)
ORDER BY b.start_d ASC, b.start_ps ASC
LIMIT 1
|}
let get_same_input_same_output_builds = let get_same_input_same_output_builds =
Caqti_request.collect Caqti_request.collect
(id `build) (id `build)
@ -432,6 +479,12 @@ module Build = struct
LIMIT 1 LIMIT 1
|} |}
let get_platforms_for_job =
Caqti_request.collect
(id `job)
Caqti_type.string
"SELECT DISTINCT platform FROM build WHERE job = ?"
let add = let add =
Caqti_request.exec Caqti_request.exec
t t

18
db/builder_db.mli
View file

@ -115,16 +115,26 @@ sig
([`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_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_all_artifact_sha_by_platform :
([`job] id * string, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_latest : val get_latest :
([`job] id, [`build] id * t * file option, [< `Many | `One | `Zero > `One `Zero ]) ([`job] id * string, [`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, t, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t ([`job] id, t, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t
val get_latest_failed_by_platform :
([`job] id * string, t, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t
val get_latest_successful_uuid : val get_latest_successful_uuid :
([`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_latest_successful_uuid_by_platform :
([`build] id, [`build] id * t, [< `Many | `One | `Zero > `One `Zero ]) ([`job] id * string, Uuidm.t, [< `Many | `One | `Zero > `One `Zero ])
Caqti_request.t
val get_previous_successful_uuid :
([`build] id, Uuidm.t, [< `Many | `One | `Zero > `One `Zero ])
Caqti_request.t
val get_next_successful_uuid :
([`build] id, Uuidm.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, t, [ `Many | `One | `Zero ]) Caqti_request.t ([`build] id, t, [ `Many | `One | `Zero ]) Caqti_request.t
@ -134,6 +144,8 @@ sig
([`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, t, [< `Many | `One | `Zero > `One ]) Caqti_request.t (Cstruct.t, t, [< `Many | `One | `Zero > `One ]) Caqti_request.t
val get_platforms_for_job :
([`job] id, string, [ `Many | `One | `Zero ]) 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_by_hash : val get_by_hash :
(Cstruct.t, t, [< `Many | `One | `Zero > `One]) Caqti_request.t (Cstruct.t, t, [< `Many | `One | `Zero > `One]) Caqti_request.t

39
lib/builder_web.ml
View file

@ -96,14 +96,19 @@ let add_routes datadir =
List.fold_right List.fold_right
(fun (job_id, job_name, section, synopsis) r -> (fun (job_id, job_name, section, synopsis) r ->
r >>= fun acc -> r >>= fun acc ->
Dream.sql req (Model.build_with_main_binary job_id) >>= function Dream.sql req (Model.platforms_of_job job_id) >>= fun ps ->
| Some (latest_build, latest_artifact) -> List.fold_right (fun platform r ->
let v = (job_name, synopsis, latest_build, latest_artifact) in r >>= fun acc ->
let section = Option.value ~default:"Failed" section in Dream.sql req (Model.build_with_main_binary job_id platform) >>= function
Lwt_result.return (Utils.String_map.add_or_create section v acc) | Some (build, artifact) ->
Lwt_result.return ((platform, build, artifact) :: acc)
| None -> | None ->
Log.warn (fun m -> m "Job without builds: %s" job_name); Log.warn (fun m -> m "Job without builds: %s" job_name);
Lwt_result.return acc) Lwt_result.return acc)
ps (Lwt_result.return []) >>= fun platform_builds ->
let v = (job_name, synopsis, platform_builds) in
let section = Option.value ~default:"Uncategorized" section in
Lwt_result.return (Utils.String_map.add_or_create section v acc))
jobs jobs
(Lwt_result.return Utils.String_map.empty) (Lwt_result.return Utils.String_map.empty)
|> if_error "Error getting jobs" |> if_error "Error getting jobs"
@ -114,7 +119,10 @@ let add_routes datadir =
let job req = let job req =
let job_name = Dream.param "job" req in let job_name = Dream.param "job" req in
Dream.sql req (Model.job_and_readme job_name) let platform = Dream.query "platform" req in
(Dream.sql req (Model.job_and_readme job_name) >>= fun (job_id, readme) ->
Dream.sql req (Model.builds_grouped_by_output job_id platform) >|= fun builds ->
(readme, builds))
|> if_error "Error getting job" |> if_error "Error getting job"
~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e)) ~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
>>= fun (readme, builds) -> >>= fun (readme, builds) ->
@ -123,9 +131,10 @@ let add_routes datadir =
let redirect_latest req = let redirect_latest req =
let job_name = Dream.param "job" req in let job_name = Dream.param "job" req in
let platform = Dream.query "platform" req in
let path = Dream.path req |> String.concat "/" in let path = Dream.path req |> String.concat "/" in
(Dream.sql req (Model.job_id job_name) >>= Model.not_found >>= fun job_id -> (Dream.sql req (Model.job_id job_name) >>= Model.not_found >>= fun job_id ->
Dream.sql req (Model.latest_successful_build_uuid job_id)) Dream.sql req (Model.latest_successful_build_uuid job_id platform))
>>= Model.not_found >>= Model.not_found
|> if_error "Error getting job" >>= fun build -> |> if_error "Error getting job" >>= fun build ->
Dream.redirect req Dream.redirect req
@ -162,12 +171,14 @@ let add_routes datadir =
Dream.sql req (Model.builds_with_same_input_and_same_main_binary build_id) >>= fun same_input_same_output -> Dream.sql req (Model.builds_with_same_input_and_same_main_binary build_id) >>= fun same_input_same_output ->
Dream.sql req (Model.builds_with_different_input_and_same_main_binary build_id) >>= fun different_input_same_output -> Dream.sql req (Model.builds_with_different_input_and_same_main_binary build_id) >>= fun different_input_same_output ->
Dream.sql req (Model.builds_with_same_input_and_different_main_binary build_id) >>= fun same_input_different_output -> Dream.sql req (Model.builds_with_same_input_and_different_main_binary build_id) >>= fun same_input_different_output ->
Dream.sql req (Model.latest_successful_build_uuid build.job_id) >|= fun latest_uuid -> Dream.sql req (Model.latest_successful_build_uuid build.job_id (Some build.Builder_db.Build.platform)) >>= fun latest_uuid ->
(readme, build, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest_uuid)) Dream.sql req (Model.next_successful_build_uuid build_id) >>= fun next_uuid ->
Dream.sql req (Model.previous_successful_build_uuid build_id) >|= fun previous_uuid ->
(readme, build, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest_uuid, next_uuid, previous_uuid))
|> if_error "Error getting job build" |> if_error "Error getting job build"
~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e)) ~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
>>= fun (readme, build, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest_uuid) -> >>= fun (readme, build, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest_uuid, next_uuid, previous_uuid) ->
Views.job_build job_name readme build artifacts same_input_same_output different_input_same_output same_input_different_output latest_uuid Views.job_build job_name readme build artifacts same_input_same_output different_input_same_output same_input_different_output latest_uuid next_uuid previous_uuid
|> string_of_html |> Dream.html |> Lwt_result.ok |> string_of_html |> Dream.html |> Lwt_result.ok
in in
@ -343,6 +354,12 @@ let add_routes datadir =
let w f req = or_error_response (f req) in let w f req = or_error_response (f req) in
(*
/developer <- front page with failed builds (indication)
/job/:job/developer(?platform=XX) <- job list with failed builds
/failed-builds(?platform=XX) <- all failed builds across all jobs (limit by the most recent 10)
*)
Dream.router [ Dream.router [
Dream.get "/" (w builder); Dream.get "/" (w builder);
Dream.get "/job/:job/" (w job); Dream.get "/job/:job/" (w job);

99
lib/model.ml
View file

@ -50,12 +50,15 @@ let build_artifacts build (module Db : CONN) =
Db.collect_list Builder_db.Build_artifact.get_all_by_build build >|= Db.collect_list Builder_db.Build_artifact.get_all_by_build build >|=
List.map snd List.map snd
let platforms_of_job id (module Db : CONN) =
Db.collect_list Builder_db.Build.get_platforms_for_job id
let build uuid (module Db : CONN) = let build uuid (module Db : CONN) =
Db.find_opt Builder_db.Build.get_by_uuid uuid >>= Db.find_opt Builder_db.Build.get_by_uuid uuid >>=
not_found not_found
let build_with_main_binary job (module Db : CONN) = let build_with_main_binary job platform (module Db : CONN) =
Db.find_opt Builder_db.Build.get_latest job >|= Db.find_opt Builder_db.Build.get_latest (job, platform) >|=
Option.map (fun (_id, build, file) -> (build, file)) Option.map (fun (_id, build, file) -> (build, file))
let build_hash hash (module Db : CONN) = let build_hash hash (module Db : CONN) =
@ -65,12 +68,18 @@ 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 latest_successful_build_uuid job_id (module Db : CONN) = let latest_successful_build_uuid job_id platform (module Db : CONN) =
match platform with
| None ->
Db.find_opt Builder_db.Build.get_latest_successful_uuid job_id Db.find_opt Builder_db.Build.get_latest_successful_uuid job_id
| Some platform ->
Db.find_opt Builder_db.Build.get_latest_successful_uuid_by_platform (job_id, platform)
let previous_successful_build id (module Db : CONN) = let previous_successful_build_uuid id (module Db : CONN) =
Db.find_opt Builder_db.Build.get_previous_successful id >|= Db.find_opt Builder_db.Build.get_previous_successful_uuid id
Option.map (fun (_id, meta) -> meta)
let next_successful_build_uuid id (module Db : CONN) =
Db.find_opt Builder_db.Build.get_next_successful_uuid id
let builds_with_different_input_and_same_main_binary id (module Db : CONN) = let builds_with_different_input_and_same_main_binary id (module Db : CONN) =
Db.collect_list Builder_db.Build.get_different_input_same_output_input_ids id >>= fun ids -> Db.collect_list Builder_db.Build.get_different_input_same_output_input_ids id >>= fun ids ->
@ -114,9 +123,19 @@ let readme job (module Db : CONN) =
let job_and_readme job (module Db : CONN) = let job_and_readme job (module Db : CONN) =
job_id job (module Db) >>= not_found >>= fun job_id -> job_id job (module Db) >>= not_found >>= fun job_id ->
Db.find Builder_db.Tag.get_id_by_name "readme.md" >>= fun readme_id -> Db.find Builder_db.Tag.get_id_by_name "readme.md" >>= fun readme_id ->
Db.find_opt Builder_db.Job_tag.get_value (readme_id, job_id) >>= fun readme -> Db.find_opt Builder_db.Job_tag.get_value (readme_id, job_id) >|= fun readme ->
job_id, readme
let builds_grouped_by_output job_id platform (module Db : CONN) =
(match platform with
| None ->
Db.find_opt Builder_db.Build.get_latest_failed job_id >>= fun failed -> Db.find_opt Builder_db.Build.get_latest_failed job_id >>= fun failed ->
Db.collect_list Builder_db.Build.get_all_artifact_sha job_id >>= fun sha -> Db.collect_list Builder_db.Build.get_all_artifact_sha job_id >|= fun sha ->
(failed, sha)
| Some p ->
Db.find_opt Builder_db.Build.get_latest_failed_by_platform (job_id, p) >>= fun failed ->
Db.collect_list Builder_db.Build.get_all_artifact_sha_by_platform (job_id, p) >|= fun sha ->
(failed, sha)) >>= fun (failed, sha) ->
Lwt_list.fold_left_s (fun acc hash -> Lwt_list.fold_left_s (fun acc hash ->
match acc with match acc with
| Error _ as e -> Lwt.return e | Error _ as e -> Lwt.return e
@ -126,8 +145,7 @@ let job_and_readme job (module Db : CONN) =
| Some f when Ptime.is_later ~than:build.Builder_db.Build.start f.Builder_db.Build.start -> None, (build, file) :: (f, None) :: builds | Some f when Ptime.is_later ~than:build.Builder_db.Build.start f.Builder_db.Build.start -> None, (build, file) :: (f, None) :: builds
| x -> x, (build, file) :: builds) | x -> x, (build, file) :: builds)
(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 (match x with None -> builds | Some f -> (f, None) :: builds) |> List.rev
readme, List.rev builds
let jobs_with_section_synopsis (module Db : CONN) = let jobs_with_section_synopsis (module Db : CONN) =
Db.collect_list Builder_db.Job.get_all_with_section_synopsis () Db.collect_list Builder_db.Job.get_all_with_section_synopsis ()
@ -220,64 +238,35 @@ let commit_files datadir staging_dir job_name uuid =
Lwt.return (Bos.OS.Dir.create job_dir) >>= fun _ -> Lwt.return (Bos.OS.Dir.create job_dir) >>= fun _ ->
Lwt.return (Bos.OS.Path.move staging_dir dest) Lwt.return (Bos.OS.Path.move staging_dir dest)
let infer_section_and_synopsis platform name artifacts = let infer_section_and_synopsis artifacts =
let opam_switch = let infer_synopsis_and_descr switch root =
match List.find_opt (fun (p, _) -> String.equal (Fpath.basename p) "opam-switch") artifacts with
| None -> None
| Some (_, data) -> Some (OpamFile.SwitchExport.read_from_string data)
in
let infer_synopsis_and_descr switch =
let root = switch.OpamFile.SwitchExport.selections.OpamTypes.sel_roots in
if OpamPackage.Set.cardinal root <> 1 then
None, None
else
let root = OpamPackage.Set.choose root in
match OpamPackage.Name.Map.find_opt root.OpamPackage.name switch.OpamFile.SwitchExport.overlays with match OpamPackage.Name.Map.find_opt root.OpamPackage.name switch.OpamFile.SwitchExport.overlays with
| None -> None, None | None -> None, None
| Some opam -> OpamFile.OPAM.synopsis opam, OpamFile.OPAM.descr_body opam | Some opam -> OpamFile.OPAM.synopsis opam, OpamFile.OPAM.descr_body opam
in in
let infer_section_from_packages switch = let infer_section switch root =
let root = switch.OpamFile.SwitchExport.selections.OpamTypes.sel_roots in
if OpamPackage.Set.cardinal root <> 1 then
None
else
let root = OpamPackage.Set.choose root in
let root_pkg_name = OpamPackage.Name.to_string root.OpamPackage.name in let root_pkg_name = OpamPackage.Name.to_string root.OpamPackage.name in
if Astring.String.is_prefix ~affix:"mirage-unikernel-" root_pkg_name then if Astring.String.is_prefix ~affix:"mirage-unikernel-" root_pkg_name then
let influx = OpamPackage.Name.of_string "metrics-influx" in let influx = OpamPackage.Name.of_string "metrics-influx" in
if OpamPackage.Set.exists (fun p -> OpamPackage.Name.equal p.OpamPackage.name influx) if OpamPackage.Set.exists (fun p -> OpamPackage.Name.equal p.OpamPackage.name influx)
switch.OpamFile.SwitchExport.selections.OpamTypes.sel_installed switch.OpamFile.SwitchExport.selections.OpamTypes.sel_installed
then then
Some "Unikernels (with metrics reported to Influx)" "Unikernels (with metrics reported to Influx)"
else else
Some "Unikernels" "Unikernels"
else else
None "Packages"
in in
let infer_section_from_platform_or_name = match List.find_opt (fun (p, _) -> String.equal (Fpath.basename p) "opam-switch") artifacts with
if String.equal platform "no-platform" then
let map = [
"-freebsd", "FreeBSD" ;
"-debian", "Debian" ;
"-ubuntu", "Ubuntu" ;
] in
match
List.find_opt (fun (affix, _) -> Astring.String.is_infix ~affix name) map
with
| None -> None
| Some (_, os) -> Some (os ^ " Packages")
else
Some (platform ^ " Packages")
in
match opam_switch with
| None -> None, (None, None) | None -> None, (None, None)
| Some opam_switch -> | Some (_, data) ->
let section = try
match infer_section_from_packages opam_switch with let switch = OpamFile.SwitchExport.read_from_string data in
| None -> infer_section_from_platform_or_name let root = switch.OpamFile.SwitchExport.selections.OpamTypes.sel_roots in
| Some x -> Some x assert (OpamPackage.Set.cardinal root = 1);
in let root = OpamPackage.Set.choose root in
section, infer_synopsis_and_descr opam_switch Some (infer_section switch root), infer_synopsis_and_descr switch root
with _ -> None, (None, None)
let compute_input_id artifacts = let compute_input_id artifacts =
let get_hash filename = let get_hash filename =
@ -363,7 +352,7 @@ let add_build
console; script; platform; console; script; platform;
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 platform job_name raw_artifacts in let sec_syn = infer_section_and_synopsis raw_artifacts in
let add_or_update tag_id tag_value = let add_or_update tag_id tag_value =
Db.find_opt Job_tag.get_value (tag_id, job_id) >>= function Db.find_opt Job_tag.get_value (tag_id, job_id) >>= function
| None -> Db.exec Job_tag.add (tag_id, tag_value, job_id) | None -> Db.exec Job_tag.add (tag_id, tag_value, job_id)

19
lib/model.mli
View file

@ -21,10 +21,13 @@ val build_artifact_data : Fpath.t -> Builder_db.file ->
val build_artifacts : [`build] Builder_db.id -> Caqti_lwt.connection -> val build_artifacts : [`build] Builder_db.id -> Caqti_lwt.connection ->
(Builder_db.file list, [> Caqti_error.call_or_retrieve ]) result Lwt.t (Builder_db.file list, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val platforms_of_job : [`job] Builder_db.id -> Caqti_lwt.connection ->
(string list, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val build : Uuidm.t -> Caqti_lwt.connection -> 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_with_main_binary : [`job] Builder_db.id -> Caqti_lwt.connection -> val build_with_main_binary : [`job] Builder_db.id -> string -> Caqti_lwt.connection ->
((Builder_db.Build.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 ->
@ -33,11 +36,14 @@ val build_hash : Cstruct.t -> Caqti_lwt.connection ->
val build_exists : Uuidm.t -> Caqti_lwt.connection -> val build_exists : Uuidm.t -> Caqti_lwt.connection ->
(bool, [> Caqti_error.call_or_retrieve ]) result Lwt.t (bool, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val latest_successful_build_uuid : [`job] Builder_db.id -> Caqti_lwt.connection -> val latest_successful_build_uuid : [`job] Builder_db.id -> string option -> 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_uuid : [`build] Builder_db.id -> Caqti_lwt.connection ->
(Builder_db.Build.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t (Uuidm.t option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val next_successful_build_uuid : [`build] Builder_db.id -> Caqti_lwt.connection ->
(Uuidm.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.t list, [> Caqti_error.call_or_retrieve ]) result Lwt.t (Builder_db.Build.t list, [> Caqti_error.call_or_retrieve ]) result Lwt.t
@ -58,7 +64,10 @@ 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.t * Builder_db.file option) list, [> error ]) result Lwt.t ([`job] Builder_db.id * string option, [> error ]) result Lwt.t
val builds_grouped_by_output : [`job] Builder_db.id -> string option -> Caqti_lwt.connection ->
((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

140
lib/views.ml
View file

@ -127,26 +127,34 @@ let builder section_job_map =
Utils.String_map.fold (fun section jobs acc -> Utils.String_map.fold (fun section jobs acc ->
acc @ [ acc @ [
h2 [ txt section ]; h2 [ txt section ];
ul (List.map (fun (job_name, synopsis, latest_build, latest_artifact) -> ul (List.map (fun (job_name, synopsis, platform_builds) ->
li ([ li ([
a ~a:[a_href ("job/" ^ job_name ^ "/")] a ~a:[a_href ("job/" ^ job_name ^ "/")] [txt job_name];
[txt job_name];
txt " ";
check_icon latest_build.Builder_db.Build.result;
br (); br ();
txt (Option.value ~default:"" synopsis); txt (Option.value ~default:"" synopsis);
br (); br ()
] @
List.flatten
(List.map (fun (platform, latest_build, latest_artifact) ->
[
check_icon latest_build.Builder_db.Build.result;
txt " ";
a ~a:[a_href (Fmt.str "job/%s/?platform=%s" job_name platform)][txt platform];
txt " ";
a ~a:[a_href (Fmt.str "job/%s/build/%a/" job_name Uuidm.pp a ~a:[a_href (Fmt.str "job/%s/build/%a/" job_name Uuidm.pp
latest_build.Builder_db.Build.uuid)] latest_build.Builder_db.Build.uuid)]
[txtf "%a" (Ptime.pp_human ()) latest_build.Builder_db.Build.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 ->
artifact ~basename:true job_name latest_build main_binary artifact ~basename:true job_name latest_build main_binary
| None -> | None ->
[ [ txtf "Build failure: %a" Builder.pp_execution_result
txtf "Build failed"; latest_build.Builder_db.Build.result ]
])) jobs) ) @ [ br () ])
platform_builds)
))
jobs)
]) ])
section_job_map section_job_map
[]) [])
@ -165,26 +173,21 @@ let job name readme builds =
[ [
h2 ~a:[a_id "builds"] [txt "Builds"]; h2 ~a:[a_id "builds"] [txt "Builds"];
a ~a:[a_href "#readme"] [txt "Back to readme"]; a ~a:[a_href "#readme"] [txt "Back to readme"];
p [
txtf "Currently %d builds."
(List.length builds)
];
ul (List.map (fun (build, main_binary) -> ul (List.map (fun (build, main_binary) ->
li ([ li ([
check_icon build.Builder_db.Build.result;
txtf " %s " build.platform;
a ~a:[a_href Fpath.(to_string (v "build" / Uuidm.to_string build.Builder_db.Build.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.start; txtf "%a" (Ptime.pp_human ()) build.Builder_db.Build.start;
]; ];
txt " "; txt " ";
check_icon build.result;
br ();
] @ match main_binary with ] @ match main_binary with
| Some main_binary -> | Some main_binary ->
artifact ~basename:true name build main_binary artifact ~basename:true name build main_binary
| None -> | None ->
[ [ txtf "Build failure: %a" Builder.pp_execution_result
txtf "Build failed"; build.Builder_db.Build.result ]))
]))
builds); builds);
]) ])
@ -195,10 +198,9 @@ let job_build
{ Builder_db.Build.uuid; start; finish; result; platform; _ } { Builder_db.Build.uuid; start; finish; result; platform; _ }
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 next_uuid previous_uuid
= =
let delta = Ptime.diff finish start in let delta = Ptime.diff finish start in
let successful_build = match result with Builder.Exited 0 -> true | _ -> false in
layout ~title:(Fmt.str "Job %s %a" name pp_ptime start) layout ~title:(Fmt.str "Job %s %a" name pp_ptime start)
((h1 [txtf "Job %s" name] :: ((h1 [txtf "Job %s" name] ::
(match readme with (match readme with
@ -214,14 +216,7 @@ let job_build
a ~a:[a_href "#readme"] [txt "Back to readme"]; a ~a:[a_href "#readme"] [txt "Back to readme"];
p [txtf "Built on platform %s" platform ]; p [txtf "Built on platform %s" platform ];
p [txtf "Build took %a." Ptime.Span.pp delta ]; p [txtf "Build took %a." Ptime.Span.pp delta ];
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 -> [
h3 [ txt "Reproduced by builds"] ;
p (List.concat_map (fun { Builder_db.Build.start ; uuid ; _ } ->
[ a ~a:[Fmt.kstr a_href "/job/%s/build/%a" name Uuidm.pp uuid]
[txtf "%a" pp_ptime start] ;
txt ", " ])
xs) ] ) @ [
h3 [txt "Build info"]; h3 [txt "Build info"];
ul [ ul [
li [ a ~a:[Fmt.kstr a_href "/job/%s/build/%a/console" name Uuidm.pp uuid] li [ a ~a:[Fmt.kstr a_href "/job/%s/build/%a/console" name Uuidm.pp uuid]
@ -231,26 +226,6 @@ let job_build
[txt "Build script"]; [txt "Build script"];
] ]
]; ];
h3 [txt "Comparisons with other builds"];
p
((match latest_uuid with
| Some latest_uuid when successful_build && not (Uuidm.equal latest_uuid uuid) ->
[ a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch"
Uuidm.pp uuid Uuidm.pp latest_uuid]
[txt "With latest build"] ; br () ]
| _ -> []) @
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
[ a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch"
Uuidm.pp fst Uuidm.pp snd]
[txtf "With build %a (output is identical binary)" pp_ptime other_start] ; br () ])
different_input_same_output @
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
[ a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch"
Uuidm.pp fst Uuidm.pp snd]
[txtf "With build %a (same input, different output)" pp_ptime other_start] ; br () ])
same_input_different_output);
h3 [txt "Build artifacts"]; h3 [txt "Build artifacts"];
dl (List.concat_map dl (List.concat_map
(fun { Builder_db.filepath; localpath=_; sha256; size } -> (fun { Builder_db.filepath; localpath=_; sha256; size } ->
@ -265,30 +240,51 @@ let job_build
]; ];
]) ])
artifacts); artifacts);
(* h3 [ txtf "Reproduced by %d builds" (List.length (same_input_same_output @ different_input_same_output))] ;
(* FIXME *) ul
h3 [txt "Job script"]; ((List.map (fun { Builder_db.Build.start ; uuid ; platform ; _ } ->
toggleable "job-script" "Show/hide" li [
[ pre [txt script] ]; txtf "on %s, same input, " platform;
h3 [txt "Build log"]; a ~a:[Fmt.kstr a_href "/job/%s/build/%a/" name Uuidm.pp uuid]
toggleable ~hidden:false "build-log" "Show/hide build log" [txtf "%a" pp_ptime start]
[
table
(List.mapi (fun idx (ts, line) ->
let ts_id = "L" ^ string_of_int idx in
tr [
td ~a:[
a_class ["output-ts"];
a_id ts_id;
]
[a ~a:[a_href ("#"^ts_id); a_class ["output-ts-anchor"]]
[code [txtf "%#d ms" (Duration.to_ms (Int64.of_int ts))]]];
td ~a:[a_class ["output-code"]]
[code [txt line]];
]) ])
(List.rev console)); same_input_same_output) @
]; List.map (fun { Builder_db.Build.start = other_start ; uuid = other_uuid ; platform ; _ } ->
*) let fst, snd = if Ptime.is_later ~than:start other_start then uuid, other_uuid else other_uuid, uuid in
li [
txtf "on %s, different input, " platform;
a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch"
Uuidm.pp fst Uuidm.pp snd]
[txtf "%a" pp_ptime other_start]
])
different_input_same_output)
] @
(if same_input_different_output = [] then
[]
else
[ h3 [txt "Same input, different output (not reproducible!)"];
ul (
List.map (fun { Builder_db.Build.start = other_start ; uuid = other_uuid ; platform ; _ } ->
let fst, snd = if Ptime.is_later ~than:start other_start then uuid, other_uuid else other_uuid, uuid in
li [
txtf "on %s, " platform ;
a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch" Uuidm.pp fst Uuidm.pp snd]
[txtf "%a" pp_ptime other_start]
])
same_input_different_output)
]) @
[ h3 [txt "Comparisons with other builds on the same platform"];
let opt_build (ctx, uu) =
match uu with
| Some uu when not (Uuidm.equal uuid uu) ->
[ li [ a ~a:[Fmt.kstr a_href "/compare/%a/%a/opam-switch"
Uuidm.pp uuid Uuidm.pp uu]
[txtf "With %s build" ctx]]
]
| _ -> []
in
ul
(List.concat_map opt_build [ ("latest", latest_uuid) ; ("next", next_uuid) ; ("previous", previous_uuid) ])
]) ])
let key_values xs = let key_values xs =

14
test/builder_db.ml
View file

@ -220,7 +220,7 @@ let test_build_get_latest (module Db : CONN) =
add_second_build (module Db) >>= fun () -> add_second_build (module Db) >>= fun () ->
(* Test *) (* Test *)
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.find_opt Builder_db.Build.get_latest job_id Db.find_opt Builder_db.Build.get_latest (job_id, platform)
>>| get_opt "no latest build" >>| fun (_id, meta, main_binary') -> >>| get_opt "no latest build" >>| fun (_id, meta, main_binary') ->
Alcotest.(check (option Testable.file)) "same main binary" main_binary' (Some main_binary); Alcotest.(check (option Testable.file)) "same main binary" main_binary' (Some main_binary);
Alcotest.(check Testable.uuid) "same uuid" meta.uuid uuid' Alcotest.(check Testable.uuid) "same uuid" meta.uuid uuid'
@ -229,17 +229,17 @@ let test_build_get_previous (module Db : CONN) =
add_second_build (module Db) >>= fun () -> add_second_build (module Db) >>= fun () ->
Db.find_opt Builder_db.Build.get_by_uuid uuid' Db.find_opt Builder_db.Build.get_by_uuid uuid'
>>| get_opt "no build" >>= fun (id, _build) -> >>| get_opt "no build" >>= fun (id, _build) ->
Db.find_opt Builder_db.Build.get_previous_successful id Db.find_opt Builder_db.Build.get_previous_successful_uuid id
>>| get_opt "no previous build" >>| fun (_id, meta) -> >>| get_opt "no previous build" >>| fun uuid' ->
Alcotest.(check Testable.uuid) "same uuid" meta.uuid uuid Alcotest.(check Testable.uuid) "same uuid" uuid' uuid
let test_build_get_previous_none (module Db : CONN) = let test_build_get_previous_none (module Db : CONN) =
Db.find_opt Builder_db.Build.get_by_uuid uuid Db.find_opt Builder_db.Build.get_by_uuid uuid
>>| get_opt "no build" >>= fun (id, _build) -> >>| get_opt "no build" >>= fun (id, _build) ->
Db.find_opt Builder_db.Build.get_previous_successful id >>| function Db.find_opt Builder_db.Build.get_previous_successful_uuid id >>| function
| None -> () | None -> ()
| Some (_id, meta) -> | Some uuid ->
Alcotest.failf "Got unexpected result %a" Uuidm.pp meta.uuid Alcotest.failf "Got unexpected result %a" Uuidm.pp uuid
let test_build_get_with_jobname_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 () ->