diff --git a/bin/migrations/builder_migrations.ml b/bin/migrations/builder_migrations.ml index 06d35b4..24d9624 100644 --- a/bin/migrations/builder_migrations.ml +++ b/bin/migrations/builder_migrations.ml @@ -120,5 +120,6 @@ let () = actions (module M20210608); actions (module M20210609); actions (module M20210625); + actions (module M20210629); ]) |> Cmdliner.Term.exit diff --git a/bin/migrations/dune b/bin/migrations/dune index 76fc068..cf48b08 100644 --- a/bin/migrations/dune +++ b/bin/migrations/dune @@ -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)) diff --git a/bin/migrations/m20210629.ml b/bin/migrations/m20210629.ml new file mode 100644 index 0000000..f73a905 --- /dev/null +++ b/bin/migrations/m20210629.ml @@ -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) () + + diff --git a/db/builder_db.ml b/db/builder_db.ml index aad349d..733cc4c 100644 --- a/db/builder_db.ml +++ b/db/builder_db.ml @@ -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; diff --git a/db/builder_db.mli b/db/builder_db.mli index 587236a..0357343 100644 --- a/db/builder_db.mli +++ b/db/builder_db.mli @@ -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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 3b5dd3c..11548e7 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -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 -> diff --git a/lib/model.ml b/lib/model.ml index 39b391a..ca96b87 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -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 () -> diff --git a/lib/model.mli b/lib/model.mli index 6eb7697..d02fed4 100644 --- a/lib/model.mli +++ b/lib/model.mli @@ -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 diff --git a/lib/utils.ml b/lib/utils.ml new file mode 100644 index 0000000..f83cc14 --- /dev/null +++ b/lib/utils.ml @@ -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 + diff --git a/lib/views.ml b/lib/views.ml index d2faa8b..44e3076 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -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)