From 0a92bdae6573666b664dcff19a46569ebd6633c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Wed, 2 Dec 2020 14:33:15 +0100 Subject: [PATCH] Initial commit --- bin/builder_web_app.ml | 11 +++++++++ bin/dune | 4 ++++ builder-web.opam | 23 +++++++++++++++++++ dune-project | 2 ++ lib/builder_web.ml | 25 +++++++++++++++++++++ lib/dune | 3 +++ lib/model.ml | 51 ++++++++++++++++++++++++++++++++++++++++++ lib/model.mli | 24 ++++++++++++++++++++ lib/views.ml | 20 +++++++++++++++++ 9 files changed, 163 insertions(+) create mode 100644 bin/builder_web_app.ml create mode 100644 bin/dune create mode 100644 builder-web.opam create mode 100644 dune-project create mode 100644 lib/builder_web.ml create mode 100644 lib/dune create mode 100644 lib/model.ml create mode 100644 lib/model.mli create mode 100644 lib/views.ml diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml new file mode 100644 index 0000000..29de085 --- /dev/null +++ b/bin/builder_web_app.ml @@ -0,0 +1,11 @@ +open Opium + +let t = { Builder_web.Model.dir = Fpath.v "sample" } + +let app = + App.empty + |> App.cmd_name "Builder Web" + |> Builder_web.add_routes t + +let () = + App.run_command app diff --git a/bin/dune b/bin/dune new file mode 100644 index 0000000..33fe830 --- /dev/null +++ b/bin/dune @@ -0,0 +1,4 @@ +(executable + (public_name builder_web) + (name builder_web_app) + (libraries builder_web)) diff --git a/builder-web.opam b/builder-web.opam new file mode 100644 index 0000000..ba789f8 --- /dev/null +++ b/builder-web.opam @@ -0,0 +1,23 @@ +opam-version: "2.0" +maintainer: "Reynir Björnsson " +authors: ["Reynir Björnsson "] +homepage: "https://github.com/roburio/builder-web" +dev-repo: "git+https://github.com/roburio/builder-web.git" +bug-reports: "https://github.com/roburio/builder-web/issues" +license: "ISC" + +build: [ + ["dune" "subst"] {pinned} + ["dune" "build" "-p" name "-j" jobs] +] + +depends: [ + "builder" + "opium" +] + +synopsis: "Web interface for builder" + +pin-depends: [ + ["builder.dev" "git+https://git.data.coop/reynir/builder.git"] +] diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..ad8a384 --- /dev/null +++ b/dune-project @@ -0,0 +1,2 @@ +(lang dune 2.7) +(name builder-web) diff --git a/lib/builder_web.ml b/lib/builder_web.ml new file mode 100644 index 0000000..2fb96a4 --- /dev/null +++ b/lib/builder_web.ml @@ -0,0 +1,25 @@ +let src = Logs.Src.create "builder-web" ~doc:"Builder_web" +module Log = (val Logs.src_log src : Logs.LOG) + +open Opium + +module Model = Model + +let routes (t : Model.t) = + let builder _req = + match Model.jobs t with + | Error (`Msg e) -> + Log.warn (fun f -> f "Error getting jobs: %s" e); + Response.of_plain_text ~status:`Internal_server_error + "Error getting jobs" |> Lwt.return + | Ok jobs -> + Views.builder jobs |> Response.of_html |> Lwt.return + in + + [ App.get "/" builder ] + +let add_routes t (app : App.t) = + List.fold_right + (fun route app -> route app) + (routes t) + app diff --git a/lib/dune b/lib/dune new file mode 100644 index 0000000..d47a193 --- /dev/null +++ b/lib/dune @@ -0,0 +1,3 @@ +(library + (name builder_web) + (libraries builder opium bos rresult)) diff --git a/lib/model.ml b/lib/model.ml new file mode 100644 index 0000000..f691319 --- /dev/null +++ b/lib/model.ml @@ -0,0 +1,51 @@ +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 + +type t = { + dir : Fpath.t; +} + +type job_run = Fpath.t + +type job = { + name : Fpath.t; + runs : job_run list; +} + +let job_name { name; _ } = Fpath.to_string name +(* TODO: ensure invariant: jobs are always valid UUIDs *) +let job_run_uuid f = Option.get (Uuidm.of_string (Fpath.to_string f)) + +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 +} + +let read_full t job run = + let f = Fpath.(t.dir // job.name // run / "full") in + Bos.OS.File.read f >>= fun s -> + Builder.Asn.exec_of_cs (Cstruct.of_string s) + >>| fun (job_info, uuid, out, start, finish, result, data) -> + { job_info; uuid; out; start; finish; result; data } + +let job_runs t job = + Bos.OS.Dir.contents ~rel:true Fpath.(t.dir // job) >>= fun job_runs -> + Ok { name = job; runs = 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 job -> + match job_runs t job with + | Ok job -> Some job + | Error (`Msg e) -> + Log.warn (fun f -> f "Error reading job run dir %a: %s" Fpath.pp + Fpath.(t.dir // job) e); + None) diff --git a/lib/model.mli b/lib/model.mli new file mode 100644 index 0000000..3fda5ac --- /dev/null +++ b/lib/model.mli @@ -0,0 +1,24 @@ +type t = { + dir : Fpath.t +} + +type job + +type job_run + +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_run_uuid : job_run -> Uuidm.t + +val read_full : t -> job -> job_run -> (job_run_info, [> `Msg of string ]) result + +val jobs : t -> (job list, [> `Msg of string ]) result diff --git a/lib/views.ml b/lib/views.ml new file mode 100644 index 0000000..5a02bb9 --- /dev/null +++ b/lib/views.ml @@ -0,0 +1,20 @@ +open Tyxml.Html + +let layout ~title:title_ body_ = + html + (head (title (txt title_)) + []) + (body body_) + +let builder jobs = + layout ~title:"Builder Web" + [ h1 [txt "Builder web"]; + p [ + txt "We have currently "; + txt (string_of_int (List.length jobs)); + txt " jobs."; + ]; + ul (List.map (fun job -> + li [txt (Model.job_name job)]) + jobs); + ]