Implement job, job run

bin/builder_web_app.ml

@@ -1,6 +1,6 @@
 open Opium
 
-let t = { Builder_web.Model.dir = Fpath.v "sample" }
+let t = { Builder_web.dir = Fpath.v "sample" }
 
 let app =
   App.empty

lib/builder_web.ml

@@ -3,20 +3,49 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 open Opium
 
-module Model = Model
+type t = Model.t = {
+  dir : Fpath.t
+}
 
 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);
+      Log.warn (fun m -> m "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 job req =
+    let job = Router.param req "job" in
+    match Model.job t (Fpath.v job) with
+    | Error (`Msg e) ->
+      Log.warn (fun m -> m "Error getting job: %s" e);
+      Response.of_plain_text ~status:`Internal_server_error
+        "Error getting job" |> Lwt.return
+    | Ok job ->
+      Views.job job |> Response.of_html |> Lwt.return
+  in
+
+  let job_run req =
+    let job = Router.param req "job"
+    and run = Router.param req "run" in
+    match Model.read_full t (Fpath.v job) (Fpath.v run) with
+    | Error (`Msg e) ->
+      Log.warn (fun m -> m "Error getting job run: %s" e);
+      Response.of_plain_text ~status:`Internal_server_error
+        "Error getting job run" |> Lwt.return
+    | Ok job_run ->
+      Views.job_run job_run |> Response.of_html |> Lwt.return
+  in
+
+  [
+    App.get "/" builder;
+    App.get "/job/:job" job;
+    App.get "/job/:job/run/:run" job_run;
+  ]
 
 let add_routes t (app : App.t) =
   List.fold_right

lib/dune

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

lib/model.ml

@@ -7,16 +7,12 @@ type t = {
   dir : Fpath.t;
 }
 
-type job_run = Fpath.t
-
 type job = {
-  name : Fpath.t;
+  path : Fpath.t;
-  runs : job_run list;
+  runs : Fpath.t list;
 }
 
-let job_name { name; _ } = Fpath.to_string name
+let job_name { path; _ } = Fpath.to_string path
-(* 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;
@@ -28,24 +24,24 @@ type job_run_info = {
   data : (Fpath.t * string) list
 }
 
-let read_full t job run =
+let read_full t path run =
-  let f = Fpath.(t.dir // job.name // run / "full") in
+  let f = Fpath.(t.dir // path // 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 =
+let job t job =
   Bos.OS.Dir.contents ~rel:true Fpath.(t.dir // job) >>= fun job_runs ->
-  Ok { name = job; runs = job_runs }
+  Ok { path = 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 ->
+  List.filter_map (fun f ->
-      match job_runs t job with
+      match job t f with
       | Ok job -> Some job
       | Error (`Msg e) ->
-        Log.warn (fun f -> f "Error reading job run dir %a: %s" Fpath.pp
+        Log.warn (fun m -> m "Error reading job run dir %a: %s" Fpath.pp
-                     Fpath.(t.dir // job) e);
+                     Fpath.(t.dir // f) e);
         None)

lib/model.mli

@@ -2,9 +2,11 @@ type t = {
   dir : Fpath.t
 }
 
-type job
+type job = {
+  path : Fpath.t;
+  runs : Fpath.t list;
+}
 
-type job_run
 
 type job_run_info = {
   job_info : Builder.job;
@@ -17,8 +19,8 @@ type job_run_info = {
 }
 
 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 read_full : t -> Fpath.t -> Fpath.t -> (job_run_info, [> `Msg of string ]) result
 
+val job : t -> Fpath.t -> (job, [> `Msg of string]) result
 val jobs : t -> (job list, [> `Msg of string ]) result

lib/views.ml

@@ -1,5 +1,7 @@
 open Tyxml.Html
 
+let txtf fmt = Fmt.kstrf txt fmt
+
 let layout ~title:title_ body_ =
   html
     (head (title (txt title_))
@@ -10,11 +12,43 @@ let builder jobs =
   layout ~title:"Builder Web"
     [ h1 [txt "Builder web"];
       p [
-        txt "We have currently ";
+        txtf "We have currently %d jobs."
-        txt (string_of_int (List.length jobs));
+          (List.length jobs);
-        txt " jobs.";
       ];
       ul (List.map (fun job ->
-          li [txt (Model.job_name job)])
+          li [
+            a ~a:[a_href ("job/" ^ Model.job_name job)]
+              [txt (Model.job_name job)];
+          ])
           jobs);
     ]
+
+let job job =
+  let name = Model.job_name job in
+  layout ~title:(Printf.sprintf "Job %s" name)
+    [ h1 [txtf "Job %s" name];
+      p [
+        txtf "Currently %d job runs."
+          (List.length job.Model.runs)
+      ];
+      ul (List.map (fun (run : Fpath.t) ->
+          li [
+            a ~a:[a_href Fpath.(to_string (job.path / "run" // run))]
+              [txtf "%a" Fpath.pp run];
+          ])
+          job.Model.runs);
+
+    ]
+
+let job_run { Model.job_info = { Builder.name; _ };
+              uuid; result; out; _ } =
+  layout ~title:(Printf.sprintf "Job run %s (%s)" name (Uuidm.to_string uuid))
+    [ h1 [txtf "Job build %s (%a)" name Uuidm.pp uuid];
+      p [txtf "Status: %a" Builder.pp_execution_result result];
+      div (List.concat_map (fun (ts, line) ->
+          [
+            code [txtf "%d ms %s" (Duration.to_ms (Int64.of_int ts)) line];
+            br ();
+          ])
+          (List.rev out));
+    ]