From 41b0b6c0317873e7ad8436290278df608bf40296 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Mon, 7 Dec 2020 10:17:49 +0100 Subject: [PATCH] Implement job, job run --- bin/builder_web_app.ml | 2 +- lib/builder_web.ml | 35 ++++++++++++++++++++++++++++++++--- lib/dune | 2 +- lib/model.ml | 26 +++++++++++--------------- lib/model.mli | 10 ++++++---- lib/views.ml | 42 ++++++++++++++++++++++++++++++++++++++---- 6 files changed, 89 insertions(+), 28 deletions(-) diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 29de085..65e61e3 100644 --- a/bin/builder_web_app.ml +++ b/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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 2fb96a4..166f383 100644 --- a/lib/builder_web.ml +++ b/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 diff --git a/lib/dune b/lib/dune index d47a193..09c03b4 100644 --- a/lib/dune +++ b/lib/dune @@ -1,3 +1,3 @@ (library (name builder_web) - (libraries builder opium bos rresult)) + (libraries builder opium bos rresult duration)) diff --git a/lib/model.ml b/lib/model.ml index f691319..3c33aad 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -7,16 +7,12 @@ type t = { dir : Fpath.t; } -type job_run = Fpath.t - type job = { - name : Fpath.t; - runs : job_run list; + path : Fpath.t; + runs : Fpath.t 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)) +let job_name { path; _ } = Fpath.to_string path 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 f = Fpath.(t.dir // job.name // run / "full") in +let read_full t path run = + 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 -> - match job_runs t job with + List.filter_map (fun f -> + 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 - Fpath.(t.dir // job) e); + Log.warn (fun m -> m "Error reading job run dir %a: %s" Fpath.pp + Fpath.(t.dir // f) e); None) diff --git a/lib/model.mli b/lib/model.mli index 3fda5ac..168e78d 100644 --- a/lib/model.mli +++ b/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 diff --git a/lib/views.ml b/lib/views.ml index 5a02bb9..32405c5 100644 --- a/lib/views.ml +++ b/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 "; - txt (string_of_int (List.length jobs)); - txt " jobs."; + txtf "We have currently %d jobs." + (List.length 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)); + ]