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

add tags to jobs: section and synopsis, inferred from the latest successful build

Browse source
This commit is contained in:
Robur 2021-06-29 14:59:08 +00:00
parent 0d1b00b13c
commit e45497e97c
10 changed files with 400 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
bin/migrations/builder_migrations.ml
View file

@ -120,5 +120,6 @@ let () =
actions (module M20210608);
actions (module M20210609);
actions (module M20210625);
actions (module M20210629);
])
|> Cmdliner.Term.exit

2
bin/migrations/dune
View file

@ -1,4 +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 ))
(libraries builder_db caqti caqti-driver-sqlite3 caqti.blocking cmdliner logs logs.cli logs.fmt opam-format bos))

159
bin/migrations/m20210629.ml Normal file
View file

@ -0,0 +1,159 @@
let new_version = 9L and old_version = 8L
let identifier = "2021-06-29"
let migrate_doc = "add tag and job_tag table"
let rollback_doc = "remove tag and job tag table"
let tag =
Caqti_request.exec
Caqti_type.unit
{| CREATE TABLE tag (
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
tag VARCHAR(255) NOT NULL UNIQUE
)
|}
let job_tag =
Caqti_request.exec
Caqti_type.unit
{| CREATE TABLE job_tag (
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
tag INTEGER NOT NULL,
value VARCHAR(255) NOT NULL,
job INTEGER NOT NULL,
FOREIGN KEY(job) REFERENCES job(id),
FOREIGN KEY(tag) REFERENCES tag(id),
UNIQUE(tag, job)
)
|}
let jobs =
Caqti_request.collect
Caqti_type.unit
Builder_db.Rep.id
"SELECT id FROM job"
let latest_successful_build =
Caqti_request.find
Builder_db.Rep.id
Builder_db.Rep.id
{| SELECT b.id
FROM build b
WHERE b.job = ? AND b.result_kind = 0 AND b.result_code = 0
ORDER BY b.start_d DESC, b.start_ps DESC
LIMIT 1
|}
let build_artifacts =
Caqti_request.collect
Builder_db.Rep.id
Caqti_type.(tup2 Builder_db.Rep.fpath Builder_db.Rep.fpath)
{| SELECT a.filepath, a.localpath
FROM build_artifact a
WHERE a.build = ?
|}
let infer_section_and_synopsis artifacts =
let opam_switch =
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 switch =
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
match OpamPackage.Name.Map.find_opt root.OpamPackage.name switch.OpamFile.SwitchExport.overlays with
| None -> None
| Some opam -> OpamFile.OPAM.synopsis opam
in
let infer_section_from_packages switch =
let influx = OpamPackage.Name.of_string "metrics-influx" in
if OpamPackage.Set.exists (fun p -> OpamPackage.Name.equal p.OpamPackage.name influx)
switch.OpamFile.SwitchExport.selections.OpamTypes.sel_installed
then
"Unikernel (monitoring)"
else
"Unikernel"
in
let infer_section_from_extension =
match List.find_opt (fun (p, _) -> Fpath.(is_prefix (v "bin/") p)) artifacts with
| None -> None
| Some (p, _) ->
match Fpath.get_ext p with
| ".deb" -> Some "Debian Package"
| ".txz" -> Some "FreeBSD Package"
| _ -> None
in
match opam_switch with
| None -> None, None
| Some opam_switch ->
let section =
match infer_section_from_extension with
| Some x -> x
| None -> infer_section_from_packages opam_switch
in
Some section, infer_synopsis opam_switch
let remove_tag =
Caqti_request.exec
Caqti_type.unit
"DROP TABLE tag"
let remove_job_tag =
Caqti_request.exec
Caqti_type.unit
"DROP TABLE job_tag"
let insert_tag =
Caqti_request.exec
Caqti_type.string
"INSERT INTO tag (tag) VALUES (?)"
let insert_job_tag =
Caqti_request.exec
Caqti_type.(tup3 Builder_db.Rep.id string Builder_db.Rep.id)
"INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"
let find_tag =
Caqti_request.find
Caqti_type.string
Builder_db.Rep.id
"SELECT id FROM tag where tag = ?"
open Rresult.R.Infix
let migrate datadir (module Db : Caqti_blocking.CONNECTION) =
Grej.check_version ~user_version:old_version (module Db) >>= fun () ->
Db.exec tag () >>= fun () ->
Db.exec job_tag () >>= fun () ->
Db.exec insert_tag "section" >>= fun () ->
Db.exec insert_tag "synopsis" >>= fun () ->
Db.find find_tag "section" >>= fun section_id ->
Db.find find_tag "synopsis" >>= fun synopsis_id ->
Db.collect_list jobs () >>= fun jobs ->
Grej.list_iter_result (fun job ->
Db.find latest_successful_build job >>= fun build ->
Db.collect_list build_artifacts build >>= fun artifacts ->
List.fold_left (fun acc (fpath, lpath) ->
acc >>= fun acc ->
Bos.OS.File.read Fpath.(append datadir lpath) >>= fun data ->
Ok ((fpath, data) :: acc))
(Ok [])
artifacts >>= fun files ->
let sec_syn = infer_section_and_synopsis files in
(match fst sec_syn with None -> Ok () | Some s -> Db.exec insert_job_tag (section_id, s, job)) >>= fun () ->
(match snd sec_syn with None -> Ok () | Some s -> Db.exec insert_job_tag (synopsis_id, s, job)))
jobs >>= 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 remove_tag () >>= fun () ->
Db.exec remove_job_tag () >>= fun () ->
Db.exec (Grej.set_version old_version) ()

84
db/builder_db.ml
View file

@ -4,7 +4,7 @@ open Rep
let application_id = 1234839235l
(* Please update this when making changes! *)
let current_version = 8L
let current_version = 9L
type id = Rep.id
@ -77,6 +77,18 @@ module Job = struct
Caqti_type.(tup2 id string)
"SELECT id, name FROM job ORDER BY name ASC"
let get_all_with_section_synopsis =
Caqti_request.collect
Caqti_type.unit
Caqti_type.(tup4 id string (option string) (option string))
{| SELECT j.id, j.name, section.value, synopsis.value
FROM job j, tag section_tag, tag synopsis_tag
LEFT JOIN job_tag section ON section.job = j.id AND section.tag = section_tag.id
LEFT JOIN job_tag synopsis ON synopsis.job = j.id AND synopsis.tag = synopsis_tag.id
WHERE section_tag.tag = 'section' AND synopsis_tag.tag = 'synopsis'
ORDER BY section.value, j.name ASC
|}
let try_add =
Caqti_request.exec
Caqti_type.string
@ -88,6 +100,72 @@ module Job = struct
"DELETE FROM job WHERE id = ?"
end
module Tag = struct
let migrate =
Caqti_request.exec
Caqti_type.unit
{| CREATE TABLE tag (
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
tag VARCHAR(255) NOT NULL UNIQUE
)
|}
let rollback =
Caqti_request.exec
Caqti_type.unit
"DROP TABLE IF EXISTS tag"
let get =
Caqti_request.find
id
Caqti_type.string
"SELECT tag FROM tag WHERE id = ?"
let get_id_by_name =
Caqti_request.find
Caqti_type.string
id
"SELECT id FROM tag WHERE tag = ?"
let try_add =
Caqti_request.exec
Caqti_type.string
"INSERT OR IGNORE INTO tag (tag) VALUES (?)"
end
module Job_tag = struct
let migrate =
Caqti_request.exec
Caqti_type.unit
{| CREATE TABLE job_tag (
id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
tag INTEGER NOT NULL,
value VARCHAR(255) NOT NULL,
job INTEGER NOT NULL,
FOREIGN KEY(job) REFERENCES job(id),
FOREIGN KEY(tag) REFERENCES tag(id),
UNIQUE(tag, job)
)
|}
let rollback =
Caqti_request.exec
Caqti_type.unit
"DROP TABLE IF EXISTS job_tag"
let add =
Caqti_request.exec
Caqti_type.(tup3 id string id)
"INSERT INTO job_tag (tag, value, job) VALUES (?, ?, ?)"
let get_value =
Caqti_request.find
Caqti_type.(tup2 id id)
Caqti_type.string
"SELECT value FROM job_tag WHERE tag = ? AND job = ?"
end
module Build_artifact = struct
let migrate =
Caqti_request.exec
@ -522,6 +600,8 @@ let migrate = [
Build_artifact.migrate;
User.migrate;
Access_list.migrate;
Tag.migrate;
Job_tag.migrate;
Caqti_request.exec Caqti_type.unit
"CREATE INDEX idx_build_job_start ON build(job, start_d DESC, start_ps DESC)";
set_current_version;
@ -529,6 +609,8 @@ let migrate = [
]
let rollback = [
Job_tag.rollback;
Tag.rollback;
Access_list.rollback;
User.rollback;
Build_artifact.rollback;

26
db/builder_db.mli
View file

@ -57,12 +57,38 @@ module Job : sig
(string, id, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t
val get_all :
(unit, id * string, [ `Many | `One | `Zero ]) Caqti_request.t
val get_all_with_section_synopsis :
(unit, id * string * string option * string option, [ `Many | `One | `Zero ]) Caqti_request.t
val try_add :
(string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val remove :
(id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
end
module Tag : sig
val migrate :
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val rollback :
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val get :
(id, string, [< `Many | `One | `Zero > `One ]) Caqti_request.t
val get_id_by_name :
(string, id, [< `Many | `One | `Zero > `One ]) Caqti_request.t
val try_add :
(string, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
end
module Job_tag : sig
val migrate :
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val rollback :
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val add :
(id * string * id, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t
val get_value :
(id * id, string, [< `Many | `One | `Zero > `One ]) Caqti_request.t
end
module Build_artifact : sig
val migrate :
(unit, unit, [< `Many | `One | `Zero > `Zero ]) Caqti_request.t

11
lib/builder_web.ml
View file

@ -85,21 +85,24 @@ let add_routes datadir =
let datadir_global = Dream.new_global ~name:"datadir" (fun () -> datadir) in
let builder req =
Dream.sql req Model.jobs
(* TODO filter unsuccessful builds, ?failed=true *)
Dream.sql req Model.jobs_with_section_synopsis
|> if_error "Error getting jobs"
~log:(fun e -> Log.warn (fun m -> m "Error getting jobs: %a" pp_error e))
>>= fun jobs ->
List.fold_right
(fun (job_id, job_name) r ->
(fun (job_id, job_name, section, synopsis) r ->
r >>= fun acc ->
Dream.sql req (Model.build_meta job_id) >>= function
| Some (latest_build, latest_artifact) ->
Lwt_result.return ((job_name, latest_build, latest_artifact) :: acc)
let v = (job_name, synopsis, latest_build, latest_artifact) in
let section = Option.value ~default:"Failed" section in
Lwt_result.return (Utils.String_map.add_or_create section v acc)
| None ->
Log.warn (fun m -> m "Job without builds: %s" job_name);
Lwt_result.return acc)
jobs
(Lwt_result.return [])
(Lwt_result.return Utils.String_map.empty)
|> if_error "Error getting jobs"
~log:(fun e -> Log.warn (fun m -> m "Error getting jobs: %a" pp_error e))
>>= fun jobs ->

62
lib/model.ml
View file

@ -88,6 +88,9 @@ let job job (module Db : CONN) =
let jobs (module Db : CONN) =
Db.collect_list Builder_db.Job.get_all ()
let jobs_with_section_synopsis (module Db : CONN) =
Db.collect_list Builder_db.Job.get_all_with_section_synopsis ()
let job_name id (module Db : CONN) =
Db.find Builder_db.Job.get id
@ -185,10 +188,54 @@ let commit_files datadir staging_dir job_name uuid =
Lwt.return (Bos.OS.Dir.create job_dir) >>= fun _ ->
Lwt.return (Bos.OS.Path.move staging_dir dest)
let infer_section_and_synopsis artifacts =
let opam_switch =
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 switch =
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
match OpamPackage.Name.Map.find_opt root.OpamPackage.name switch.OpamFile.SwitchExport.overlays with
| None -> None
| Some opam -> OpamFile.OPAM.synopsis opam
in
let infer_section_from_packages switch =
let influx = OpamPackage.Name.of_string "metrics-influx" in
if OpamPackage.Set.exists (fun p -> OpamPackage.Name.equal p.OpamPackage.name influx)
switch.OpamFile.SwitchExport.selections.OpamTypes.sel_installed
then
"Unikernel (monitoring)"
else
"Unikernel"
in
let infer_section_from_extension =
match List.find_opt (fun (p, _) -> Fpath.(is_prefix (v "bin/") p)) artifacts with
| None -> None
| Some (p, _) ->
match Fpath.get_ext p with
| ".deb" -> Some "Debian Package"
| ".txz" -> Some "FreeBSD Package"
| _ -> None
in
match opam_switch with
| None -> None, None
| Some opam_switch ->
let section =
match infer_section_from_extension with
| Some x -> x
| None -> infer_section_from_packages opam_switch
in
Some section, infer_synopsis opam_switch
let add_build
datadir
user_id
(((job : Builder.script_job), uuid, console, start, finish, result, _) as exec)
(((job : Builder.script_job), uuid, console, start, finish, result, raw_artifacts) as exec)
(module Db : CONN) =
let open Builder_db in
let job_name = job.Builder.name in
@ -209,10 +256,23 @@ let add_build
Db.exec Job.try_add job_name >>= fun () ->
Db.find_opt Job.get_id_by_name job_name >>= fun job_id ->
Lwt.return (Option.to_result ~none:(`Msg "No such job id") job_id) >>= fun job_id ->
let section_tag = "section" in
Db.exec Tag.try_add section_tag >>= fun () ->
Db.find Tag.get_id_by_name section_tag >>= fun section_id ->
let synopsis_tag = "synopsis" in
Db.exec Tag.try_add synopsis_tag >>= fun () ->
Db.find Tag.get_id_by_name synopsis_tag >>= fun synopsis_id ->
Db.exec Build.add { Build.uuid; start; finish; result;
console; script = job.Builder.script;
main_binary = None; user_id; job_id } >>= fun () ->
Db.find last_insert_rowid () >>= fun id ->
let sec_syn = infer_section_and_synopsis raw_artifacts in
(match fst sec_syn with
| None -> Lwt_result.return ()
| Some section_v -> Db.exec Job_tag.add (section_id, section_v, id)) >>= fun () ->
(match snd sec_syn with
| None -> Lwt_result.return ()
| Some synopsis_v -> Db.exec Job_tag.add (synopsis_id, synopsis_v, id)) >>= fun () ->
List.fold_left
(fun r file ->
r >>= fun () ->

3
lib/model.mli
View file

@ -51,6 +51,9 @@ val job_id : string -> Caqti_lwt.connection ->
val jobs : Caqti_lwt.connection ->
((Builder_db.id * string) list, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val jobs_with_section_synopsis : Caqti_lwt.connection ->
((Builder_db.id * string * string option * string option) list, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val job_name : Builder_db.id -> Caqti_lwt.connection ->
(string, [> Caqti_error.call_or_retrieve ]) result Lwt.t

8
lib/utils.ml Normal file
View file

@ -0,0 +1,8 @@
module String_map = struct
include Map.Make(String)
let add_or_create key v t=
update key (function None -> Some [ v ] | Some xs -> Some (v :: xs)) t
end

94
lib/views.ml
View file

@ -95,49 +95,57 @@ let artifact ?(basename=false) job_name build { Builder_db.filepath; localpath =
let builder jobs =
layout ~title:"Builder Web"
[ h1 [txt "Builder web"];
form ~a:[a_action "/hash"; a_method `Get]
[
label [
txt "Search artifact by SHA256";
br ();
input ~a:[
a_input_type `Search;
a_id "sha256";
a_name "sha256";
] ();
];
input ~a:[
a_input_type `Submit;
a_value "Search";
] ();
];
p [
txtf "We have currently %d jobs."
(List.length jobs);
];
ul (List.map (fun (job_name, latest_build, latest_artifact) ->
li ([
a ~a:[a_href ("job/" ^ job_name ^ "/")]
[txt job_name];
txt " ";
check_icon latest_build.Builder_db.Build.Meta.result;
br ();
a ~a:[a_href (Fmt.strf "job/%s/build/%a/" job_name Uuidm.pp
latest_build.Builder_db.Build.Meta.uuid)]
[txtf "%a" (Ptime.pp_human ()) latest_build.Builder_db.Build.Meta.start];
txt " ";
] @ match latest_artifact with
| Some main_binary ->
artifact ~basename:true job_name latest_build main_binary
| None ->
[
txtf "Build failed";
]))
jobs);
]
let builder section_job_map =
layout ~title:"Reproducible OPAM builds"
([ h1 [txt "Introduction to reproducible OPAM builds"];
p [ txt "This website offers binary MirageOS unikernels and supplementary OS packages." ];
p [ txt {|Following is a list of jobs that are built daily. A persistent link to the latest successful build is available as /job/*jobname*/build/latest/. You can also look up a binary by the resulting SHA 256. All builds can be reproduced with |} ;
a ~a:[a_href "https://github.com/roburio/orb/"] [txt "orb"];
txt "."
];
form ~a:[a_action "/hash"; a_method `Get]
[
label [
txt "Search artifact by SHA256";
br ();
input ~a:[
a_input_type `Search;
a_id "sha256";
a_name "sha256";
] ();
];
input ~a:[
a_input_type `Submit;
a_value "Search";
] ();
];
] @
Utils.String_map.fold (fun section jobs acc ->
acc @ [
h2 [ txt section ];
ul (List.map (fun (job_name, synopsis, latest_build, latest_artifact) ->
li ([
a ~a:[a_href ("job/" ^ job_name ^ "/")]
[txt job_name];
txt " ";
check_icon latest_build.Builder_db.Build.Meta.result;
br ();
txt (Option.value ~default:"" synopsis);
br ();
a ~a:[a_href (Fmt.strf "job/%s/build/%a/" job_name Uuidm.pp
latest_build.Builder_db.Build.Meta.uuid)]
[txtf "%a" (Ptime.pp_human ()) latest_build.Builder_db.Build.Meta.start];
txt " ";
] @ match latest_artifact with
| Some main_binary ->
artifact ~basename:true job_name latest_build main_binary
| None ->
[
txtf "Build failed";
])) jobs)
])
section_job_map
[])
let job name builds =
layout ~title:(Printf.sprintf "Job %s" name)