Lwt-ify model

This commit is contained in:
Reynir Björnsson 2020-12-08 11:49:26 +01:00
parent 6e2c5718c1
commit 465ede64d6
3 changed files with 51 additions and 39 deletions

View file

@ -2,7 +2,8 @@ let src = Logs.Src.create "builder-web" ~doc:"Builder_web"
module Log = (val Logs.src_log src : Logs.LOG) module Log = (val Logs.src_log src : Logs.LOG)
open Opium open Opium
open Rresult.R.Infix open Lwt.Syntax
open Lwt_result.Infix
type t = Model.t type t = Model.t
@ -15,45 +16,48 @@ let safe_seg path =
let routes (t : Model.t) = let routes (t : Model.t) =
let builder _req = let builder _req =
match Model.jobs t with let+ jobs = Model.jobs t in
match jobs with
| Error (`Msg e) -> | Error (`Msg e) ->
Log.warn (fun m -> m "Error getting jobs: %s" e); Log.warn (fun m -> m "Error getting jobs: %s" e);
Response.of_plain_text ~status:`Internal_server_error Response.of_plain_text ~status:`Internal_server_error
"Error getting jobs" |> Lwt.return "Error getting jobs"
| Ok jobs -> | Ok jobs ->
List.sort Fpath.compare jobs List.sort Fpath.compare jobs
|> Views.builder |> Response.of_html |> Lwt.return |> Views.builder |> Response.of_html
in in
let job req = let job req =
let job = Router.param req "job" in let job = Router.param req "job" in
match safe_seg job >>= fun job -> let+ job = Lwt_result.lift (safe_seg job) >>= fun job -> Model.job t job in
Model.job t job with match job with
| Ok job -> | Ok job ->
let name = Model.job_name job let name = Model.job_name job
and runs = List.sort and runs = List.sort
(fun (b1 : Model.job_run_meta) (b2 : Model.job_run_meta) -> (fun (b1 : Model.job_run_meta) (b2 : Model.job_run_meta) ->
Ptime.compare b1.start b2.start) Ptime.compare b1.start b2.start)
job.Model.runs in job.Model.runs in
Views.job name runs |> Response.of_html |> Lwt.return Views.job name runs |> Response.of_html
| 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
"Error getting job" |> Lwt.return "Error getting job"
in in
let job_run req = let job_run req =
let job = Router.param req "job" let job = Router.param req "job"
and run = Router.param req "run" in and run = Router.param req "run" in
match safe_seg job >>= fun job -> let+ job_run =
safe_seg run >>= fun run -> Lwt_result.lift (safe_seg job) >>= fun job ->
Model.read_full t job run with Lwt_result.lift (safe_seg run) >>= fun run ->
Model.read_full t job run in
match job_run with
| Error (`Msg e) -> | Error (`Msg e) ->
Log.warn (fun m -> m "Error getting job run: %s" e); Log.warn (fun m -> m "Error getting job run: %s" e);
Response.of_plain_text ~status:`Internal_server_error Response.of_plain_text ~status:`Internal_server_error
"Error getting job run" |> Lwt.return "Error getting job run"
| Ok job_run -> | Ok job_run ->
Views.job_run job_run |> Response.of_html |> Lwt.return Views.job_run job_run |> Response.of_html
in in
[ [

View file

@ -1,7 +1,8 @@
let src = Logs.Src.create "builder-web.model" ~doc:"Builder_web model" let src = Logs.Src.create "builder-web.model" ~doc:"Builder_web model"
module Log = (val Logs.src_log src : Logs.LOG) module Log = (val Logs.src_log src : Logs.LOG)
open Rresult.R.Infix open Lwt.Syntax
open Lwt_result.Infix
module RunMap = Map.Make(struct module RunMap = Map.Make(struct
type t = Fpath.t * Fpath.t type t = Fpath.t * Fpath.t
@ -42,7 +43,9 @@ 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 -> let* ic = Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string f) in
let+ s = Lwt_io.read ic in
let open Rresult.R.Infix in
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) ->
let meta = { job_info; uuid; start; finish; result } in let meta = { job_info; uuid; start; finish; result } in
@ -52,22 +55,24 @@ let read_full t path run =
let read_full_meta t path run = let read_full_meta t path run =
match RunMap.find_opt (path, run) t.cache with match RunMap.find_opt (path, run) t.cache with
| Some meta -> | Some meta ->
Bos.OS.File.exists Fpath.(t.dir // path // run / "full") >>= fun exists -> Lwt_result.lift (Bos.OS.File.exists Fpath.(t.dir // path // run / "full")) >>= fun exists ->
if exists if exists
then Ok meta then Lwt_result.return meta
else else
(t.cache <- RunMap.remove (path, run) t.cache; (t.cache <- RunMap.remove (path, run) t.cache;
Error (`Msg "no such file")) Lwt_result.fail (`Msg "no such file"))
| None -> | None ->
read_full t path run >>| fun { meta; out = _; data = _ } -> read_full t path run >|= fun { meta; out = _; data = _ } ->
meta meta
let job t job = let job t job =
let path = Fpath.(t.dir // job) in let path = Fpath.(t.dir // job) in
Bos.OS.Dir.contents ~rel:true path >>= fun runs -> let open Lwt_result.Infix in
let runs = Lwt_result.lift (Bos.OS.Dir.contents ~rel:true path) >>= fun runs ->
List.filter_map (fun run -> let+ runs =
match read_full_meta t job run with Lwt_list.filter_map_s (fun run ->
let+ meta = read_full_meta t job run in
match meta with
| Error (`Msg e) -> | Error (`Msg e) ->
Log.warn (fun m -> m "error reading job run file %a: %s" Log.warn (fun m -> m "error reading job run file %a: %s"
Fpath.pp Fpath.(path // run) e); Fpath.pp Fpath.(path // run) e);
@ -78,16 +83,19 @@ let job t job =
Ok { path = job; runs } Ok { path = job; runs }
let jobs t = let jobs t =
Bos.OS.Dir.contents ~rel:true t.dir >>| let r =
List.filter (fun f -> not (Fpath.equal (Fpath.v "state") f)) >>| let open Rresult.R.Infix in
List.filter_map (fun f -> Bos.OS.Dir.contents ~rel:true t.dir >>|
match Bos.OS.Dir.exists Fpath.(t.dir // f) with List.filter (fun f -> not (Fpath.equal (Fpath.v "state") f)) >>|
| Ok true -> Some f List.filter_map (fun f ->
| Ok false -> match Bos.OS.Dir.exists Fpath.(t.dir // f) with
Log.warn (fun m -> m "dir %a doesn't exist" Fpath.pp | Ok true -> Some f
Fpath.(t.dir // f)); | Ok false ->
None Log.warn (fun m -> m "dir %a doesn't exist" Fpath.pp
| Error (`Msg e) -> Fpath.(t.dir // f));
Log.warn (fun m -> m "error reading job dir %a: %s" Fpath.pp None
Fpath.(t.dir // f) e); | Error (`Msg e) ->
None) Log.warn (fun m -> m "error reading job dir %a: %s" Fpath.pp
Fpath.(t.dir // f) e);
None)
in Lwt.return r

View file

@ -23,7 +23,7 @@ val init : Fpath.t -> t
val job_name : job -> string val job_name : job -> string
val read_full : t -> Fpath.t -> Fpath.t -> (job_run_info, [> `Msg of string ]) result val read_full : t -> Fpath.t -> Fpath.t -> (job_run_info, [> `Msg of string ]) result Lwt.t
val job : t -> Fpath.t -> (job, [> `Msg of string]) result val job : t -> Fpath.t -> (job, [> `Msg of string]) result Lwt.t
val jobs : t -> (Fpath.t list, [> `Msg of string ]) result val jobs : t -> (Fpath.t list, [> `Msg of string ]) result Lwt.t