Initial commit

bin/builder_web_app.ml

@@ -0,0 +1,11 @@
+open Opium
+
+let t = { Builder_web.Model.dir = Fpath.v "sample" }
+
+let app =
+  App.empty
+  |> App.cmd_name "Builder Web"
+  |> Builder_web.add_routes t
+
+let () =
+  App.run_command app

bin/dune

@@ -0,0 +1,4 @@
+(executable
+ (public_name builder_web)
+ (name builder_web_app)
+ (libraries builder_web))

builder-web.opam

@@ -0,0 +1,23 @@
+opam-version: "2.0"
+maintainer: "Reynir Björnsson <reynir@reynir.dk>"
+authors: ["Reynir Björnsson <reynir@reynir.dk>"]
+homepage: "https://github.com/roburio/builder-web"
+dev-repo: "git+https://github.com/roburio/builder-web.git"
+bug-reports: "https://github.com/roburio/builder-web/issues"
+license: "ISC"
+
+build: [
+  ["dune" "subst"] {pinned}
+  ["dune" "build" "-p" name "-j" jobs]
+]
+
+depends: [
+  "builder"
+  "opium"
+]
+
+synopsis: "Web interface for builder"
+
+pin-depends: [
+  ["builder.dev" "git+https://git.data.coop/reynir/builder.git"]
+]

dune-project

@@ -0,0 +1,2 @@
+(lang dune 2.7)
+(name builder-web)

lib/builder_web.ml

@@ -0,0 +1,25 @@
+let src = Logs.Src.create "builder-web" ~doc:"Builder_web"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+open Opium
+
+module Model = Model
+
+let routes (t : Model.t) =
+  let builder _req =
+    match Model.jobs t with
+    | Error (`Msg e) ->
+      Log.warn (fun f -> f "Error getting jobs: %s" e);
+      Response.of_plain_text ~status:`Internal_server_error
+        "Error getting jobs" |> Lwt.return
+    | Ok jobs ->
+      Views.builder jobs |> Response.of_html |> Lwt.return
+  in
+
+  [ App.get "/" builder ]
+
+let add_routes t (app : App.t) =
+  List.fold_right
+    (fun route app -> route app)
+    (routes t)
+    app

lib/dune

@@ -0,0 +1,3 @@
+(library
+ (name builder_web)
+ (libraries builder opium bos rresult))

lib/model.ml

@@ -0,0 +1,51 @@
+let src = Logs.Src.create "builder-web.model" ~doc:"Builder_web model"
+module Log = (val Logs.src_log  src : Logs.LOG)
+
+open Rresult.R.Infix
+
+type t = {
+  dir : Fpath.t;
+}
+
+type job_run = Fpath.t
+
+type job = {
+  name : Fpath.t;
+  runs : job_run list;
+}
+
+let job_name { name; _ } = Fpath.to_string name
+(* TODO: ensure invariant: jobs are always valid UUIDs *)
+let job_run_uuid f = Option.get (Uuidm.of_string (Fpath.to_string f))
+
+type job_run_info = {
+  job_info : Builder.job;
+  uuid : Uuidm.t;
+  out : (int * string) list;
+  start : Ptime.t;
+  finish : Ptime.t;
+  result : Builder.execution_result;
+  data : (Fpath.t * string) list
+}
+
+let read_full t job run =
+  let f = Fpath.(t.dir // job.name // run / "full") in
+  Bos.OS.File.read f >>= fun s ->
+  Builder.Asn.exec_of_cs (Cstruct.of_string s)
+  >>| fun (job_info, uuid, out, start, finish, result, data) ->
+  { job_info; uuid; out; start; finish; result; data }
+
+let job_runs t job =
+  Bos.OS.Dir.contents ~rel:true Fpath.(t.dir // job) >>= fun job_runs ->
+  Ok { name = job; runs = job_runs }
+
+let jobs t =
+  Bos.OS.Dir.contents ~rel:true t.dir >>|
+  List.filter (fun f -> not (Fpath.equal (Fpath.v "state") f)) >>|
+  List.filter_map (fun job ->
+      match job_runs t job with
+      | Ok job -> Some job
+      | Error (`Msg e) ->
+        Log.warn (fun f -> f "Error reading job run dir %a: %s" Fpath.pp
+                     Fpath.(t.dir // job) e);
+        None)

lib/model.mli

@@ -0,0 +1,24 @@
+type t = {
+  dir : Fpath.t
+}
+
+type job
+
+type job_run
+
+type job_run_info = {
+  job_info : Builder.job;
+  uuid : Uuidm.t;
+  out : (int * string) list;
+  start : Ptime.t;
+  finish : Ptime.t;
+  result : Builder.execution_result;
+  data : (Fpath.t * string) list
+}
+
+val job_name : job -> string
+val job_run_uuid : job_run -> Uuidm.t
+
+val read_full : t -> job -> job_run -> (job_run_info, [> `Msg of string ]) result
+
+val jobs : t -> (job list, [> `Msg of string ]) result

lib/views.ml

@@ -0,0 +1,20 @@
+open Tyxml.Html
+
+let layout ~title:title_ body_ =
+  html
+    (head (title (txt title_))
+       [])
+    (body body_)
+
+let builder jobs =
+  layout ~title:"Builder Web"
+    [ h1 [txt "Builder web"];
+      p [
+        txt "We have currently ";
+        txt (string_of_int (List.length jobs));
+        txt " jobs.";
+      ];
+      ul (List.map (fun job ->
+          li [txt (Model.job_name job)])
+          jobs);
+    ]