osh.ml 4.66 KB
Newer Older
zapashcanon's avatar
zapashcanon committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
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
zapashcanon's avatar
zapashcanon committed
16 17 18 19 20 21 22 23 24 25 26

let asset_loader _root path _request =
  match Content.read ("assets/" ^ path) with
  | None -> Dream.empty `Not_Found
  | Some asset -> Dream.respond asset

let page path =
  match Content.read (path ^ ".md") with
  | None -> None
  | Some page -> Some (Omd.of_string page |> Omd.to_html)

zapashcanon's avatar
zapashcanon committed
27 28 29 30
(** This takes a lot of parameter but overrides any of them if provided in
    request. *)
let mk_badge ~label ~color ~style ~label_color ~status ~scale request =
  let q field = Dream.query field request in
zapashcanon's avatar
zapashcanon committed
31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
  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)
zapashcanon's avatar
zapashcanon committed
82
    in
83
    let status, invalid =
zapashcanon's avatar
zapashcanon committed
84 85 86 87 88 89
      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)
zapashcanon's avatar
zapashcanon committed
90
    in
91
    let status =
zapashcanon's avatar
zapashcanon committed
92
      if not invalid then
93
        Ok status
zapashcanon's avatar
zapashcanon committed
94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
      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 ->
115
            let status = x |> Util.member "conclusion" |> Util.to_string in
116
            Hashtbl.replace tbl url (status, Unix.time ());
117
            Ok status )
zapashcanon's avatar
zapashcanon committed
118
    in
119
    match status with
zapashcanon's avatar
zapashcanon committed
120
    | Error e -> Dream.respond e
121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137
    | Ok status ->
      let open Ocb in
      let status, color =
        match status 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
      Dream.respond ~headers:[ ("Content-Type", "image/svg+xml") ] badge
zapashcanon's avatar
zapashcanon committed
138

zapashcanon's avatar
zapashcanon committed
139
let () =
zapashcanon's avatar
zapashcanon committed
140 141
  Dream.run ~interface:"0.0.0.0"
  @@ Dream.logger
zapashcanon's avatar
zapashcanon committed
142 143
  @@ Dream.router
       [ Dream.get "/assets/**" (Dream.static ~loader:asset_loader "")
zapashcanon's avatar
zapashcanon committed
144 145
       ; Dream.get "/" home_page
       ; Dream.get "/badge" badge
zapashcanon's avatar
zapashcanon committed
146
       ; Dream.get "/badge/github/workflow/status/:user/:repo/:workflow"
zapashcanon's avatar
zapashcanon committed
147
           badge_github_workflow_status
zapashcanon's avatar
zapashcanon committed
148 149
       ]
  @@ Dream.not_found