From 465ede64d68e621e7072c4a20ab5ffc82ec6209e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Tue, 8 Dec 2020 11:49:26 +0100 Subject: [PATCH] Lwt-ify model --- lib/builder_web.ml | 30 +++++++++++++++----------- lib/model.ml | 54 ++++++++++++++++++++++++++-------------------- lib/model.mli | 6 +++--- 3 files changed, 51 insertions(+), 39 deletions(-) diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 7c0760a..4b02450 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -2,7 +2,8 @@ let src = Logs.Src.create "builder-web" ~doc:"Builder_web" module Log = (val Logs.src_log src : Logs.LOG) open Opium -open Rresult.R.Infix +open Lwt.Syntax +open Lwt_result.Infix type t = Model.t @@ -15,45 +16,48 @@ let safe_seg path = let routes (t : Model.t) = let builder _req = - match Model.jobs t with + let+ jobs = Model.jobs t in + match jobs with | Error (`Msg e) -> Log.warn (fun m -> m "Error getting jobs: %s" e); Response.of_plain_text ~status:`Internal_server_error - "Error getting jobs" |> Lwt.return + "Error getting jobs" | Ok jobs -> List.sort Fpath.compare jobs - |> Views.builder |> Response.of_html |> Lwt.return + |> Views.builder |> Response.of_html in let job req = let job = Router.param req "job" in - match safe_seg job >>= fun job -> - Model.job t job with + let+ job = Lwt_result.lift (safe_seg job) >>= fun job -> Model.job t job in + match job with | Ok job -> let name = Model.job_name job and runs = List.sort (fun (b1 : Model.job_run_meta) (b2 : Model.job_run_meta) -> Ptime.compare b1.start b2.start) job.Model.runs in - Views.job name runs |> Response.of_html |> Lwt.return + Views.job name runs |> Response.of_html | 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 + "Error getting job" in let job_run req = let job = Router.param req "job" and run = Router.param req "run" in - match safe_seg job >>= fun job -> - safe_seg run >>= fun run -> - Model.read_full t job run with + let+ job_run = + Lwt_result.lift (safe_seg job) >>= fun job -> + Lwt_result.lift (safe_seg run) >>= fun run -> + Model.read_full t job run in + match job_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 + "Error getting job run" | Ok job_run -> - Views.job_run job_run |> Response.of_html |> Lwt.return + Views.job_run job_run |> Response.of_html in [ diff --git a/lib/model.ml b/lib/model.ml index 3860788..516f705 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -1,7 +1,8 @@ let src = Logs.Src.create "builder-web.model" ~doc:"Builder_web model" 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 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 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) >>| fun (job_info, uuid, out, start, finish, result, data) -> 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 = match RunMap.find_opt (path, run) t.cache with | 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 - then Ok meta + then Lwt_result.return meta else (t.cache <- RunMap.remove (path, run) t.cache; - Error (`Msg "no such file")) + Lwt_result.fail (`Msg "no such file")) | None -> - read_full t path run >>| fun { meta; out = _; data = _ } -> + read_full t path run >|= fun { meta; out = _; data = _ } -> meta let job t job = 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 + let open Lwt_result.Infix in + Lwt_result.lift (Bos.OS.Dir.contents ~rel:true path) >>= fun runs -> + let+ runs = + Lwt_list.filter_map_s (fun run -> + let+ meta = read_full_meta t job run in + match meta with | Error (`Msg e) -> Log.warn (fun m -> m "error reading job run file %a: %s" Fpath.pp Fpath.(path // run) e); @@ -78,16 +83,19 @@ let job t job = Ok { path = 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 f -> - match Bos.OS.Dir.exists Fpath.(t.dir // f) with - | Ok true -> Some f - | Ok false -> - Log.warn (fun m -> m "dir %a doesn't exist" Fpath.pp - Fpath.(t.dir // f)); - None - | Error (`Msg e) -> - Log.warn (fun m -> m "error reading job dir %a: %s" Fpath.pp - Fpath.(t.dir // f) e); - None) + let r = + let open Rresult.R.Infix in + Bos.OS.Dir.contents ~rel:true t.dir >>| + List.filter (fun f -> not (Fpath.equal (Fpath.v "state") f)) >>| + List.filter_map (fun f -> + match Bos.OS.Dir.exists Fpath.(t.dir // f) with + | Ok true -> Some f + | Ok false -> + Log.warn (fun m -> m "dir %a doesn't exist" Fpath.pp + Fpath.(t.dir // f)); + None + | Error (`Msg e) -> + Log.warn (fun m -> m "error reading job dir %a: %s" Fpath.pp + Fpath.(t.dir // f) e); + None) + in Lwt.return r diff --git a/lib/model.mli b/lib/model.mli index 11f5cef..638e005 100644 --- a/lib/model.mli +++ b/lib/model.mli @@ -23,7 +23,7 @@ val init : Fpath.t -> t 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 jobs : t -> (Fpath.t list, [> `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 Lwt.t