diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 65e61e3..28e2b0d 100644 --- a/bin/builder_web_app.ml +++ b/bin/builder_web_app.ml @@ -1,6 +1,6 @@ open Opium -let t = { Builder_web.dir = Fpath.v "sample" } +let t = Builder_web.init (Fpath.v "sample") let app = App.empty diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 7ac54cb..8d7d4ea 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -4,9 +4,9 @@ module Log = (val Logs.src_log src : Logs.LOG) open Opium open Rresult.R.Infix -type t = Model.t = { - dir : Fpath.t -} +type t = Model.t + +let init = Model.init let safe_seg path = if Fpath.is_seg path && not (Fpath.is_rel_seg path) @@ -21,7 +21,8 @@ let routes (t : Model.t) = Response.of_plain_text ~status:`Internal_server_error "Error getting jobs" |> Lwt.return | Ok jobs -> - Views.builder jobs |> Response.of_html |> Lwt.return + List.sort (fun j1 j2 -> Fpath.compare j1.Model.path j2.Model.path) jobs + |> Views.builder |> Response.of_html |> Lwt.return in let job req = @@ -29,7 +30,9 @@ let routes (t : Model.t) = match safe_seg job >>= fun job -> Model.job t job with | Ok job -> - Views.job job |> Response.of_html |> Lwt.return + let name = Model.job_name job + and runs = job.Model.runs in + Views.job name runs |> Response.of_html |> Lwt.return | Error (`Msg e) -> Log.warn (fun m -> m "Error getting job: %s" e); Response.of_plain_text ~status:`Internal_server_error diff --git a/lib/model.ml b/lib/model.ml index 3c33aad..7df2925 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -3,37 +3,73 @@ module Log = (val Logs.src_log src : Logs.LOG) open Rresult.R.Infix -type t = { - dir : Fpath.t; -} +module RunMap = Map.Make(struct + type t = Fpath.t * Fpath.t + let compare (j1,r1) (j2,r2) = + let jcmp = Fpath.compare j1 j2 in + if jcmp <> 0 + then jcmp + else Fpath.compare r1 r2 + end) -type job = { - path : Fpath.t; - runs : Fpath.t list; -} - -let job_name { path; _ } = Fpath.to_string path - -type job_run_info = { +type job_run_meta = { job_info : Builder.job; uuid : Uuidm.t; - out : (int * string) list; start : Ptime.t; finish : Ptime.t; result : Builder.execution_result; +} + +type job_run_info = { + meta : job_run_meta; + out : (int * string) list; data : (Fpath.t * string) list } +type t = { + dir : Fpath.t; + mutable cache : job_run_meta RunMap.t +} + +let init dir = { dir; cache = RunMap.empty; } + +type job = { + path : Fpath.t; + runs : job_run_meta list; +} + +let job_name { path; _ } = Fpath.to_string path + 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 } + { meta = { job_info; uuid; start; finish; result }; + out; data } + +let read_full_meta t path run = + match RunMap.find_opt (path, run) t.cache with + | Some meta -> Ok meta + | None -> + read_full t path run >>| fun { meta; out = _; data = _ } -> + t.cache <- RunMap.add (path, run) meta t.cache; + meta let job t job = - Bos.OS.Dir.contents ~rel:true Fpath.(t.dir // job) >>= fun job_runs -> - Ok { path = job; runs = job_runs } + let path = Fpath.(t.dir // job) in + Bos.OS.Dir.contents ~rel:true path >>= fun runs -> + let runs = + List.filter_map (fun run -> + match read_full_meta t job run with + | Error (`Msg e) -> + Log.warn (fun m -> m "error reading job run file %a: %s" + Fpath.pp Fpath.(path // run) e); + None + | Ok meta -> Some meta) + runs + in + Ok { path = job; runs } let jobs t = Bos.OS.Dir.contents ~rel:true t.dir >>| @@ -42,6 +78,6 @@ let jobs t = match job t f with | Ok job -> Some job | Error (`Msg e) -> - Log.warn (fun m -> m "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 // f) e); None) diff --git a/lib/model.mli b/lib/model.mli index 168e78d..75cf186 100644 --- a/lib/model.mli +++ b/lib/model.mli @@ -1,22 +1,25 @@ -type t = { - dir : Fpath.t +type t + +type job_run_meta = { + job_info : Builder.job; + uuid : Uuidm.t; + start : Ptime.t; + finish : Ptime.t; + result : Builder.execution_result; +} + +type job_run_info = { + meta : job_run_meta; + out : (int * string) list; + data : (Fpath.t * string) list } type job = { path : Fpath.t; - runs : Fpath.t list; + runs : job_run_meta list; } - -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 init : Fpath.t -> t val job_name : job -> string diff --git a/lib/views.ml b/lib/views.ml index f73683b..65deb57 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -23,25 +23,28 @@ let builder jobs = jobs); ] -let job job = - let name = Model.job_name job in +let job name runs = layout ~title:(Printf.sprintf "Job %s" name) [ h1 [txtf "Job %s" name]; p [ txtf "Currently %d job runs." - (List.length job.Model.runs) + (List.length runs) ]; - ul (List.map (fun (run : Fpath.t) -> + ul (List.map (fun run -> li [ - a ~a:[a_href Fpath.(to_string (v "run" // run) ^ "/")] - [txtf "%a" Fpath.pp run]; + a ~a:[a_href Fpath.(to_string (v "run" / Uuidm.to_string run.Model.uuid) ^ "/")] + [txtf "%a" (Ptime.pp_human ()) run.Model.start]; ]) - job.Model.runs); + runs); ] -let job_run { Model.job_info = { Builder.name; _ }; - uuid; result; out; _ } = +let job_run + { Model.meta = { + 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];