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)
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
[

View file

@ -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

View file

@ -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