Implement meta data caching

Also print builds by their start time instead of UUID
This commit is contained in:
Reynir Björnsson 2020-12-07 15:43:54 +01:00
parent d2a3b29e43
commit cd1cdcc9bb
5 changed files with 89 additions and 44 deletions

View file

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

View file

@ -4,9 +4,9 @@ module Log = (val Logs.src_log src : Logs.LOG)
open Opium open Opium
open Rresult.R.Infix open Rresult.R.Infix
type t = Model.t = { type t = Model.t
dir : Fpath.t
} let init = Model.init
let safe_seg path = let safe_seg path =
if Fpath.is_seg path && not (Fpath.is_rel_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 Response.of_plain_text ~status:`Internal_server_error
"Error getting jobs" |> Lwt.return "Error getting jobs" |> Lwt.return
| Ok jobs -> | 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 in
let job req = let job req =
@ -29,7 +30,9 @@ let routes (t : Model.t) =
match safe_seg job >>= fun job -> match safe_seg job >>= fun job ->
Model.job t job with Model.job t job with
| Ok job -> | 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) -> | Error (`Msg e) ->
Log.warn (fun m -> m "Error getting job: %s" e); Log.warn (fun m -> m "Error getting job: %s" e);
Response.of_plain_text ~status:`Internal_server_error Response.of_plain_text ~status:`Internal_server_error

View file

@ -3,37 +3,73 @@ module Log = (val Logs.src_log src : Logs.LOG)
open Rresult.R.Infix open Rresult.R.Infix
type t = { module RunMap = Map.Make(struct
dir : Fpath.t; 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 = { type job_run_meta = {
path : Fpath.t;
runs : Fpath.t list;
}
let job_name { path; _ } = Fpath.to_string path
type job_run_info = {
job_info : Builder.job; job_info : Builder.job;
uuid : Uuidm.t; uuid : Uuidm.t;
out : (int * string) list;
start : Ptime.t; start : Ptime.t;
finish : Ptime.t; finish : Ptime.t;
result : Builder.execution_result; result : Builder.execution_result;
}
type job_run_info = {
meta : job_run_meta;
out : (int * string) list;
data : (Fpath.t * 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 read_full t path run =
let f = Fpath.(t.dir // path // run / "full") in let f = Fpath.(t.dir // path // run / "full") in
Bos.OS.File.read f >>= fun s -> Bos.OS.File.read f >>= fun s ->
Builder.Asn.exec_of_cs (Cstruct.of_string s) Builder.Asn.exec_of_cs (Cstruct.of_string s)
>>| fun (job_info, uuid, out, start, finish, result, data) -> >>| 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 = let job t job =
Bos.OS.Dir.contents ~rel:true Fpath.(t.dir // job) >>= fun job_runs -> let path = Fpath.(t.dir // job) in
Ok { path = job; runs = job_runs } 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 = let jobs t =
Bos.OS.Dir.contents ~rel:true t.dir >>| Bos.OS.Dir.contents ~rel:true t.dir >>|
@ -42,6 +78,6 @@ let jobs t =
match job t f with match job t f with
| Ok job -> Some job | Ok job -> Some job
| Error (`Msg e) -> | 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); Fpath.(t.dir // f) e);
None) None)

View file

@ -1,22 +1,25 @@
type t = { type t
dir : Fpath.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 = { type job = {
path : Fpath.t; path : Fpath.t;
runs : Fpath.t list; runs : job_run_meta list;
} }
val init : Fpath.t -> t
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_name : job -> string

View file

@ -23,25 +23,28 @@ let builder jobs =
jobs); jobs);
] ]
let job job = let job name runs =
let name = Model.job_name job in
layout ~title:(Printf.sprintf "Job %s" name) layout ~title:(Printf.sprintf "Job %s" name)
[ h1 [txtf "Job %s" name]; [ h1 [txtf "Job %s" name];
p [ p [
txtf "Currently %d job runs." 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 [ li [
a ~a:[a_href Fpath.(to_string (v "run" // run) ^ "/")] a ~a:[a_href Fpath.(to_string (v "run" / Uuidm.to_string run.Model.uuid) ^ "/")]
[txtf "%a" Fpath.pp run]; [txtf "%a" (Ptime.pp_human ()) run.Model.start];
]) ])
job.Model.runs); runs);
] ]
let job_run { Model.job_info = { Builder.name; _ }; let job_run
uuid; result; out; _ } = { Model.meta = {
Model.job_info = { Builder.name; _ };
uuid; result; _ };
out; _ }
=
layout ~title:(Printf.sprintf "Job run %s (%s)" name (Uuidm.to_string uuid)) layout ~title:(Printf.sprintf "Job run %s (%s)" name (Uuidm.to_string uuid))
[ h1 [txtf "Job build %s (%a)" name Uuidm.pp uuid]; [ h1 [txtf "Job build %s (%a)" name Uuidm.pp uuid];
p [txtf "Status: %a" Builder.pp_execution_result result]; p [txtf "Status: %a" Builder.pp_execution_result result];