Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Page
Library
Module
Module type
Parameter
Class
Class type
Source
app.ml
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 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 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215
open Current.Syntax open Lwt.Infix let ( >>!= ) = Lwt_result.bind module Metrics = struct open Prometheus let namespace = "ocurrent" let subsystem = "github" let installations_total = let help = "Total number of active app installations" in Gauge.v ~help ~namespace ~subsystem "installations_total" end let installations_changed_cond = Lwt_condition.create () (* Fires when the list should be updated *) let input_installation_webhook () = Lwt_condition.broadcast installations_changed_cond () let list_installations_endpoint = Uri.of_string "https://api.github.com/app/installations" let access_tokens_endpoint id = Uri.of_string (Fmt.str "https://api.github.com/app/installations/%d/access_tokens" id) module Int_map = Map.Make(Int) module Installs = Current.Var(struct type t = Installation.t Int_map.t let equal = Int_map.equal (fun _ _ -> true) let pp = Fmt.using (fun t -> Int_map.bindings t |> List.map fst) Fmt.(Dump.list int) end) module Allowlist : sig type t val of_list : string list -> t val mem : string -> t -> bool end = struct type t = string list let of_list = List.map String.lowercase_ascii let mem name l = List.exists ((=) (String.lowercase_ascii name)) l end type t = { app_id : string; key : Mirage_crypto_pk.Rsa.priv; allowlist : Allowlist.t; (* Accounts which can use this app. *) installations : Installs.t; } let http { app_id; key; _ } op uri = let iat = truncate @@ Unix.gettimeofday () in let jwt = Token.encode ~key ~iat ~app_id in let headers = Cohttp.Header.init_with "Authorization" ("bearer " ^ jwt) in let headers = Cohttp.Header.add headers "accept" "application/vnd.github.machine-man-preview+json" in Log.debug (fun f -> f "API call on %a" Uri.pp uri); op ~headers uri >>= fun (resp, body) -> Cohttp_lwt.Body.to_string body >|= fun body -> match Cohttp.Response.status resp with | `OK | `Created -> let json = Yojson.Safe.from_string body in Log.debug (fun f -> f "@[<v2>Got response:@,%a@]" Yojson.Safe.pp json); resp, json | err -> Fmt.failwith "@[<v2>Error accessing GitHub App API at %a: %s@,%s@]" Uri.pp uri (Cohttp.Code.string_of_status err) body let get ~headers uri = Cohttp_lwt_unix.Client.get ~headers uri let post ~headers uri = Cohttp_lwt_unix.Client.post ~headers uri let minute = 60.0 let get_token app iid = let uri = access_tokens_endpoint iid in let now = Unix.gettimeofday () in http app post uri >|= fun (_resp, json) -> let open Yojson.Safe.Util in let token = Ok (json |> member "token" |> to_string) in (* The token is valid for 60 minutes, so request a new one after 50 minutes. *) let expiry = Some (now +. 50.0 *. minute) in Api.{ token; expiry } let next headers = headers |> Cohttp.Header.get_links |> List.find_opt (fun (link : Cohttp.Link.t) -> List.exists (fun r -> r = Cohttp.Link.Rel.next) link.arc.relation ) |> Option.map (fun link -> link.Cohttp.Link.target) let get_installations app = Lwt.catch (fun () -> let rec aux uri = http app get uri >>= fun (resp, json) -> let open Yojson.Safe.Util in let installs = json |> to_list |> List.filter_map (fun json -> let id = json |> member "id" |> to_int in let account = json |> member "account" |> member "login" |> to_string in if Allowlist.mem account app.allowlist then ( Log.info (fun f -> f "Found installation %d for %S" id account); let repository_selection = json |> member "repository_selection" |> to_string in match repository_selection with | "selected" -> Some (id, account) | "all" -> Log.warn (fun f -> f "Installation %S has selected all repositories - skipping as probably a mistake" account); None | x -> Log.warn (fun f -> f "Installation %S has unknown repository_selection %S - skipping" account x); None ) else ( Log.warn (fun f -> f "Installation %d for %S : account not on allowlist!" id account); None ) ) in match next (Cohttp.Response.headers resp) with | None -> Lwt_result.return installs | Some target -> aux target >>!= fun next_installs -> Lwt_result.return (installs @ next_installs) in aux list_installations_endpoint ) (fun ex -> Lwt_result.fail (`Msg (Fmt.str "Failed to get GitHub installations: %a" Fmt.exn ex)) ) let installation t ~account iid = let api = Api.v ~get_token:(fun () -> get_token t iid) ("i-" ^ account) in Installation.v ~api ~account ~iid module Int_set = Set.Make(Int) let remove_stale_installations new_ids = let new_ids = new_ids |> List.map fst |> Int_set.of_list in Int_map.filter (fun key _ -> Int_set.mem key new_ids) let monitor_installations t () = let rec aux () = let update = Lwt_condition.wait installations_changed_cond in get_installations t >>= fun ids -> begin match ids with | Ok ids -> Prometheus.Gauge.set Metrics.installations_total (float_of_int (List.length ids)); Installs.update t.installations (fun old_map -> let old_map = match old_map with Ok x -> x | Error _ -> Int_map.empty in (* Merge in new installations. Reuse existing Apis so we don't keep refreshing tokens, etc. *) ids |> ListLabels.fold_left ~init:old_map ~f:(fun acc (iid, account) -> if Int_map.mem iid acc then acc else Int_map.add iid (installation t iid ~account) acc ) |> remove_stale_installations ids |> Stdlib.Result.ok ); | Error (`Msg m) -> Log.warn (fun f -> f "Failed to update list of installations: %s" m) end; Lwt_unix.sleep 60.0 >>= fun () -> (* Wait at least 1m between updates *) update >>= aux in aux () let installations t = let+ apis = Installs.get t.installations in apis |> Int_map.bindings |> List.map snd (* Command-line options *) let make_config app_id private_key_file allowlist = let data = Api.read_file private_key_file in match X509.Private_key.decode_pem (Cstruct.of_string data) with | Error (`Msg msg) -> Fmt.failwith "Failed to parse secret key!@ %s" msg | Ok (`RSA key) -> let installations = Installs.create ~name:"installations" (Error (`Active `Running)) in let t = { app_id; key; allowlist; installations } in Lwt.async (monitor_installations t); t | Ok _ -> Fmt.failwith "Unsupported private key type" [@@warning "-11"] open Cmdliner let private_key_file = Arg.required @@ Arg.opt Arg.(some file) None @@ Arg.info ~doc:"A file containing the GitHub app's RSA private key." ~docv:"PATH" ["github-private-key-file"] let app_id = Arg.required @@ Arg.opt Arg.(some string) None @@ Arg.info ~doc:"The GitHub app's (integer) ID" ~docv:"ID" ["github-app-id"] let allowlist = Term.app (Term.const Allowlist.of_list) @@ Arg.required @@ Arg.opt Arg.(some (list string)) None @@ Arg.info ~doc:"A comma-separated list of allowed GitHub accounts" ~docv:"ACCOUNTS" ["github-account-allowlist"] let cmdliner = Term.(const make_config $ app_id $ private_key_file $ allowlist)