Skip to content

GitLab

Unverified Commit a040b716 authored by zapashcanon's avatar zapashcanon
Browse files

refactor and add a cache

parent c0bf14b8
Pipeline #15908 failed with stages
in 5 minutes and 10 seconds
Hide whitespace changes
Inline Side-by-side
Showing with 123 additions and 83 deletions
src/dune
View file @ a040b716
(executable (executable
(public_name osh) (public_name osh)
(modules content osh template) (modules content osh template)
(libraries dream ezcurl ocb omd yojson)) (libraries dream ezcurl ocb omd lambdasoup yojson))
(rule (rule
(targets template.ml) (targets template.ml)
......
src/osh.ml
View file @ a040b716
let render ~title ~content = let get_title content =
Template.render_unsafe ~title ~content:(Dream.html_escape content) let open Soup in
try
let soup = content |> parse in
soup $ "h1" |> R.leaf_text
with
| Failure _e -> "Osh by OCamlPro"
let render_unsafe ?title content =
let title =
match title with
| None -> get_title content
| Some title -> title
in
Dream.html @@ Template.render_unsafe ~content ~title
let asset_loader _root path _request = let asset_loader _root path _request =
match Content.read ("assets/" ^ path) with match Content.read ("assets/" ^ path) with
...@@ -15,95 +28,122 @@ let page path = ...@@ -15,95 +28,122 @@ let page path =
request. *) request. *)
let mk_badge ~label ~color ~style ~label_color ~status ~scale request = let mk_badge ~label ~color ~style ~label_color ~status ~scale request =
let q field = Dream.query field request in let q field = Dream.query field request in
Dream.respond let open Ocb in
~headers:[ ("Content-Type", "image/svg+xml") ] let module Option = Stdlib.Option in
(let open Ocb in let label = Option.value (q "label") ~default:label in
let module Option = Stdlib.Option in let color =
let label = Option.value (q "label") ~default:label in Option.value (Option.map Color.of_string (q "color")) ~default:color
let color = in
Option.value (Option.map Color.of_string (q "color")) ~default:color let style =
in Option.value (Option.map Style.of_string (q "style")) ~default:style
let style = in
Option.value (Option.map Style.of_string (q "style")) ~default:style let label_color =
match Dream.query "label_color" request with
| None -> label_color
| Some label_color -> Color.of_string label_color
in
let status = Option.value (q "status") ~default:status in
let scale =
match Dream.query "scale" request with
| None -> scale
| Some scale' -> begin
match float_of_string_opt scale' with
| None -> scale
| Some scale -> scale
end
in
Format.asprintf "%a"
(Gen.mk ~label ~color ~style ~label_color ~status ~icon:None ~icon_width:0.
~scale )
()
let home_page _request =
match page "index" with
| None -> Dream.empty `Not_Found
| Some content -> render_unsafe content
let badge request =
let open Ocb in
let badge =
mk_badge ~label:"Label" ~color:Color.Blue ~style:Style.Flat
~label_color:Color.Black ~status:"Status" ~scale:1. request
in
Dream.respond ~headers:[ ("Content-Type", "image/svg+xml") ] badge
let badge_github_workflow_status =
let tbl = Hashtbl.create 512 in
fun request ->
let url =
Format.sprintf
"https://api.github.com/repos/%s/%s/actions/workflows/%s/runs"
(Dream.param "user" request)
(Dream.param "repo" request)
(Dream.param "workflow" request)
in in
let label_color = let badge, invalid =
match Dream.query "label_color" request with match Hashtbl.find_opt tbl url with
| None -> label_color | Some (badge, timestamp) ->
| Some label_color -> Color.of_string label_color let curr_timestamp = Unix.time () in
let invalid = curr_timestamp -. timestamp > 60. *. 10. in
(badge, invalid)
| None -> ("", true)
in in
let status = Option.value (q "status") ~default:status in let badge =
let scale = if not invalid then
match Dream.query "scale" request with Ok badge
| None -> scale else
| Some scale' -> begin match Ezcurl.get ~url () with
match float_of_string_opt scale' with | Error (_code, msg) ->
| None -> scale Error (Format.sprintf "Failed to query the API: curl error: %s" msg)
| Some scale -> scale | Ok response -> (
end let open Yojson.Basic in
let response = from_string response.Ezcurl.body in
let response =
response |> Util.member "workflow_runs" |> Util.to_list
in
let latest_run =
List.find_opt
(fun x ->
let event = x |> Util.member "event" |> Util.to_string in
let status = x |> Util.member "status" |> Util.to_string in
status = "completed" && event = "push" )
response
in
match latest_run with
| None -> Error "Invalid JSON answer"
| Some x ->
let s = x |> Util.member "conclusion" |> Util.to_string in
let open Ocb in
let status, color =
match s with
| "success" -> ("Success", Color.Green)
| "failure" -> ("Failure", Color.Red)
| "neutral" -> ("Neutral", Color.Grey)
| "cancelled" -> ("Cancelled", Color.Red)
| "skipped" -> ("Skipped", Color.Red)
| "timed_out" -> ("Timed out", Color.Red)
| unknown -> (unknown, Color.Grey)
in
let badge =
mk_badge ~label:"Build" ~color ~style:Style.Flat
~label_color:Color.Black ~status ~scale:1. request
in
Hashtbl.add tbl url (badge, Unix.time ());
Ok badge )
in in
Format.asprintf "%a" match badge with
(Gen.mk ~label ~color ~style ~label_color ~status ~icon:None | Ok badge ->
~icon_width:0. ~scale ) Dream.respond ~headers:[ ("Content-Type", "image/svg+xml") ] badge
()) | Error e -> Dream.respond e
let () = let () =
Dream.run ~interface:"0.0.0.0" Dream.run ~interface:"0.0.0.0"
@@ Dream.logger @@ Dream.logger
@@ Dream.router @@ Dream.router
[ Dream.get "/assets/**" (Dream.static ~loader:asset_loader "") [ Dream.get "/assets/**" (Dream.static ~loader:asset_loader "")
; Dream.get "/" (fun _request -> ; Dream.get "/" home_page
match page "index" with ; Dream.get "/badge" badge
| None -> Dream.empty `Not_Found
| Some content ->
Dream.html
(Template.render_unsafe ~title:"Osh by OCamlPro" ~content) )
; Dream.get "/badge" (fun request ->
let open Ocb in
mk_badge ~label:"Label" ~color:Color.Blue ~style:Style.Flat
~label_color:Color.Black ~status:"Status" ~scale:1. request )
; Dream.get "/badge/github/workflow/status/:user/:repo/:workflow" ; Dream.get "/badge/github/workflow/status/:user/:repo/:workflow"
(fun request -> badge_github_workflow_status
let url =
Format.sprintf
"https://api.github.com/repos/%s/%s/actions/workflows/%s/runs"
(Dream.param "user" request)
(Dream.param "repo" request)
(Dream.param "workflow" request)
in
match Ezcurl.get ~url () with
| Error (_code, msg) ->
Dream.respond
(Format.sprintf "Failed to query the API: curl error: %s" msg)
| Ok response -> (
let open Yojson.Basic in
let response = from_string response.Ezcurl.body in
let response =
response |> Util.member "workflow_runs" |> Util.to_list
in
let latest_run =
List.find_opt
(fun x ->
let event = x |> Util.member "event" |> Util.to_string in
let status = x |> Util.member "status" |> Util.to_string in
status = "completed" && event = "push" )
response
in
match latest_run with
| None -> Dream.respond "Invalid JSON answer"
| Some x ->
let s = x |> Util.member "conclusion" |> Util.to_string in
let open Ocb in
let status, color =
match s with
| "success" -> ("Success", Color.Green)
| "failure" -> ("Failure", Color.Red)
| "neutral" -> ("Neutral", Color.Grey)
| "cancelled" -> ("Cancelled", Color.Red)
| "skipped" -> ("Skipped", Color.Red)
| "timed_out" -> ("Timed out", Color.Red)
| unknown -> (unknown, Color.Grey)
in
mk_badge ~label:"Build" ~color ~style:Style.Flat
~label_color:Color.Black ~status ~scale:1. request ) )
] ]
@@ Dream.not_found @@ Dream.not_found
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment