Lwt-ify model

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
 
   [

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

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