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

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

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

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) ()
+
+

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;

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

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

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

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
 

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
+

lib/views.ml

@@ -95,49 +95,57 @@ let artifact ?(basename=false) job_name build { Builder_db.filepath; localpath =
 
 
 
-let builder jobs =
+let builder section_job_map =
-  layout ~title:"Builder Web"
+  layout ~title:"Reproducible OPAM builds"
-    [ h1 [txt "Builder web"];
+    ([ h1 [txt "Introduction to reproducible OPAM builds"];
-      form ~a:[a_action "/hash"; a_method `Get]
+       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 |} ;
-          label [
+           a ~a:[a_href "https://github.com/roburio/orb/"] [txt "orb"];
-            txt "Search artifact by SHA256";
+           txt "."
-            br ();
+       ];
-            input ~a:[
+       form ~a:[a_action "/hash"; a_method `Get]
-              a_input_type `Search;
+         [
-              a_id "sha256";
+           label [
-              a_name "sha256";
+             txt "Search artifact by SHA256";
-            ] ();
+             br ();
-          ];
+             input ~a:[
-          input ~a:[
+               a_input_type `Search;
-            a_input_type `Submit;
+               a_id "sha256";
-            a_value "Search";
+               a_name "sha256";
-          ] ();
+             ] ();
-        ];
+           ];
-      p [
+           input ~a:[
-        txtf "We have currently %d jobs."
+             a_input_type `Submit;
-          (List.length jobs);
+             a_value "Search";
-      ];
+           ] ();
-      ul (List.map (fun (job_name, latest_build, latest_artifact) ->
+         ];
-          li ([
+       ] @
-              a ~a:[a_href ("job/" ^ job_name ^ "/")]
+       Utils.String_map.fold (fun section jobs acc ->
-                [txt job_name];
+         acc @ [
-              txt " ";
+           h2 [ txt section ];
-              check_icon latest_build.Builder_db.Build.Meta.result;
+           ul (List.map (fun (job_name, synopsis, latest_build, latest_artifact) ->
-              br ();
+               li ([
-              a ~a:[a_href (Fmt.strf "job/%s/build/%a/" job_name Uuidm.pp
+                   a ~a:[a_href ("job/" ^ job_name ^ "/")]
-                              latest_build.Builder_db.Build.Meta.uuid)]
+                     [txt job_name];
-                [txtf "%a" (Ptime.pp_human ()) latest_build.Builder_db.Build.Meta.start];
+                   txt " ";
-              txt " ";
+                   check_icon latest_build.Builder_db.Build.Meta.result;
-            ] @ match latest_artifact with
+                   br ();
-            | Some main_binary ->
+                   txt (Option.value ~default:"" synopsis);
-              artifact ~basename:true job_name latest_build main_binary
+                   br ();
-            | None ->
+                   a ~a:[a_href (Fmt.strf "job/%s/build/%a/" job_name Uuidm.pp
-              [
+                                   latest_build.Builder_db.Build.Meta.uuid)]
-                txtf "Build failed";
+                     [txtf "%a" (Ptime.pp_human ()) latest_build.Builder_db.Build.Meta.start];
-              ]))
+                   txt " ";
-        jobs);
+                 ] @ 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)