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
(public_name osh)
(modules content osh template)
(libraries dream ezcurl ocb omd yojson))
(libraries dream ezcurl ocb omd lambdasoup yojson))
(rule
(targets template.ml)
......
src/osh.ml
View file @ a040b716
let render ~title ~content =
Template.render_unsafe ~title ~content:(Dream.html_escape content)
let get_title 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 =
match Content.read ("assets/" ^ path) with
......@@ -15,95 +28,122 @@ let page path =
request. *)
let mk_badge ~label ~color ~style ~label_color ~status ~scale request =
let q field = Dream.query field request in
Dream.respond
~headers:[ ("Content-Type", "image/svg+xml") ]
(let open Ocb in
let module Option = Stdlib.Option in
let label = Option.value (q "label") ~default:label in
let color =
Option.value (Option.map Color.of_string (q "color")) ~default:color
in
let style =
Option.value (Option.map Style.of_string (q "style")) ~default:style
let open Ocb in
let module Option = Stdlib.Option in
let label = Option.value (q "label") ~default:label in
let color =
Option.value (Option.map Color.of_string (q "color")) ~default:color
in
let style =
Option.value (Option.map Style.of_string (q "style")) ~default:style
in
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
let label_color =
match Dream.query "label_color" request with
| None -> label_color
| Some label_color -> Color.of_string label_color
let badge, invalid =
match Hashtbl.find_opt tbl url with
| Some (badge, timestamp) ->
let curr_timestamp = Unix.time () in
let invalid = curr_timestamp -. timestamp > 60. *. 10. in
(badge, invalid)
| None -> ("", true)
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
let badge =
if not invalid then
Ok badge
else
match Ezcurl.get ~url () with
| Error (_code, msg) ->
Error (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 -> 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
Format.asprintf "%a"
(Gen.mk ~label ~color ~style ~label_color ~status ~icon:None
~icon_width:0. ~scale )
())
match badge with
| Ok badge ->
Dream.respond ~headers:[ ("Content-Type", "image/svg+xml") ] badge
| Error e -> Dream.respond e
let () =
Dream.run ~interface:"0.0.0.0"
@@ Dream.logger
@@ Dream.router
[ Dream.get "/assets/**" (Dream.static ~loader:asset_loader "")
; Dream.get "/" (fun _request ->
match page "index" with
| 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 "/" home_page
; Dream.get "/badge" badge
; Dream.get "/badge/github/workflow/status/:user/:repo/:workflow"
(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
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 ) )
badge_github_workflow_status
]
@@ 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