Add support for auth with GH Apps

Author: thatportugueseguy

lib/api_remote.ml

@@ -3,6 +3,41 @@ open Devkit
 open Common
 open Util
 
+module Github_app = struct
+  let jwt_token ({ client_id; pem; _ } : Config_t.app_installation_cfg) =
+    let b64enc s = Base64.encode_string ~alphabet:Base64.uri_safe_alphabet ~pad:false s in
+    let now = Unix.gettimeofday () in
+    (* Issues 60 seconds in the past *)
+    let iat = int_of_float (now -. 60.0) in
+    (* Expires 1 minute from now *)
+    let exp = int_of_float (now +. 60.0) in
+    let header_json = {|{"typ":"JWT","alg":"RS256"}|} in
+    let payload_json = sprintf {|{"iat":%d,"exp":%d,"iss":"%s"}|} iat exp client_id in
+    let header_payload = sprintf "%s.%s" (b64enc header_json) (b64enc payload_json) in
+    let key =
+      match X509.Private_key.decode_pem pem with
+      | Ok (`RSA k) -> k
+      | Ok _ -> failwith "Expected RSA key for app installation auth"
+      | Error (`Message e) -> failwith @@ "Failed to parse app installation private key: " ^ e
+      | _ -> failwith "Failed to parse app installation private key"
+    in
+    let signature = Mirage_crypto_pk.Rsa.PKCS1.sign ~hash:`SHA256 ~key (`Message header_payload) |> b64enc in
+    sprintf "%s.%s" header_payload signature
+
+  let get_installation_token (app : Config_t.app_installation_cfg) =
+    let headers = [ "Accept: application/vnd.github.v3+json"; sprintf "Authorization: Bearer %s" (jwt_token app) ] in
+    let url = sprintf "https://api.github.com/app/installations/%s/access_tokens" app.installation_id in
+    let%lwt res =
+      http_request ~headers `POST url ~body:(`Raw ("application/json", ""))
+      |> Lwt_result.map_error (fun e -> sprintf "Error while authenticating with GitHub app: %s" e)
+    in
+    match res with
+    | Ok res ->
+      let { Github_t.token; _ } = Github_j.installation_token_response_of_string res in
+      Lwt.return token
+    | Error e -> failwith e
+end
+
 module Github : Api.Github = struct
   let commits_url ~(repo : Github_t.repository) ~sha =
     let _, url = ExtLib.String.replace ~sub:"{/sha}" ~by:("/" ^ sha) ~str:repo.commits_url in
@@ -29,7 +64,14 @@ module Github : Api.Github = struct
     Option.map_default (fun v -> sprintf "Authorization: token %s" v :: headers) headers token
 
   let prepare_request ~secrets ~repo_url url =
-    let token = Context.gh_token_of_secrets secrets repo_url in
+    let%lwt token =
+      match Context.gh_auth_of_secrets secrets repo_url with
+      | None -> Lwt.return_none
+      | Some (GH_token token) -> Lwt.return_some token
+      | Some (AppInstallation gh_app) ->
+        let%lwt token = Github_app.get_installation_token gh_app in
+        Lwt.return_some token
+    in
     let headers = build_headers ?token () in
     let url =
       match Context.gh_repo_of_secrets secrets repo_url with
@@ -40,15 +82,15 @@ module Github : Api.Github = struct
         let repo_config_url_scheme = repo_config.url |> Uri.of_string |> Uri.scheme in
         url |> Uri.of_string |> flip Uri.with_scheme repo_config_url_scheme |> Uri.to_string
     in
-    headers, url
+    Lwt.return (headers, url)
 
   let get_resource ~secrets ~repo_url url =
-    let headers, url = prepare_request ~secrets ~repo_url url in
+    let%lwt headers, url = prepare_request ~secrets ~repo_url url in
     http_request ~headers `GET url
     |> Lwt_result.map_error (fun e -> sprintf "error while querying remote: %s\nfailed to get resource from %s" e url)
 
   let post_resource ~secrets ~repo_url body url =
-    let headers, url = prepare_request ~secrets ~repo_url url in
+    let%lwt headers, url = prepare_request ~secrets ~repo_url url in
     http_request ~headers ~body:(`Raw ("application/json; charset=utf-8", body)) `POST url
     |> Lwt_result.map_error (sprintf "POST to %s failed : %s" url)
 

lib/atd_adapters.ml

@@ -82,3 +82,21 @@ module Strings_to_pipelines_adapter : Atdgen_runtime.Json_adapter.S = struct
     | `Assoc [ ("name", `String s) ] -> `String s
     | _ -> x
 end
+
+(* This adapter is meant to avoid breaking changes in the config because the type for
+   [repo_config] was changed and [gh_token] was removed and [auth] was added. *)
+module GH_token_to_auth_adapter : Atdgen_runtime.Json_adapter.S = struct
+  let normalize (x : Yojson.Safe.t) =
+    match x with
+    | `Assoc ks ->
+      `Assoc
+        (List.map
+           (fun (k, v) ->
+             match k with
+             | "gh_token" -> "auth", `List [ `String "GH_token"; v ]
+             | _ -> k, v)
+           ks)
+    | _ -> x
+
+  let restore (x : Yojson.Safe.t) = x
+end

lib/config.atd

@@ -68,14 +68,22 @@ type webhook = {
   channel : any_channel; (* name of the Slack channel to post the message *)
 }
 
+type app_installation_cfg = {
+  installation_id: string;
+  client_id: string;
+  pem: string;
+}
+
+type repo_auth = [ GH_token of string | AppInstallation of app_installation_cfg ] <ocaml repr="classic">
+
 type repo_config = {
   (* Repository url. Fully qualified (include protocol), without trailing slash. e.g. https://github.com/ahrefs/monorobot *)
   url : string;
   (* GitHub personal access token, if repo access requires it *)
-  ?gh_token : string nullable;
+  ?auth : repo_auth nullable;
   (* GitHub webhook secret token to secure the webhook *)
   ?gh_hook_secret : string nullable;
-}
+} <json adapter.ocaml="Atd_adapters.GH_token_to_auth_adapter">
 
 (* This is the structure of the secrets file which stores sensitive information, and
    shouldn't be checked into version control.  *)

lib/context.ml

@@ -53,10 +53,10 @@ let gh_repo_of_secrets (secrets : Config_t.secrets) repo_url =
   | None -> None
   | Some repo -> Some repo
 
-let gh_token_of_secrets (secrets : Config_t.secrets) repo_url =
+let gh_auth_of_secrets (secrets : Config_t.secrets) repo_url =
   match gh_repo_of_secrets secrets repo_url with
-  | None -> None
-  | Some repo -> repo.gh_token
+  | None | Some { auth = None; _ } -> None
+  | Some { auth; _ } -> auth
 
 let gh_hook_secret_token_of_secrets (secrets : Config_t.secrets) repo_url =
   match gh_repo_of_secrets secrets repo_url with

lib/dune

@@ -12,6 +12,7 @@
   extlib
   lwt
   lwt.unix
+  mirage-crypto-pk
   ocamldiff
   omd
   ptime
@@ -22,6 +23,7 @@
   sqlgg.traits
   sqlite3
   unix
+  x509
   uri
   yojson
   text_cleanup)

lib/github.atd

@@ -312,3 +312,8 @@ type content_api_response = {
   encoding : string;
   content : string;
 }
+
+type installation_token_response = {
+  token: string;
+  expires_at: string;
+}

src/dune

@@ -1,5 +1,14 @@
 (executable
- (libraries monorobotlib cmdliner devkit devkit.core extlib lwt.unix uri unix)
+ (libraries
+  monorobotlib
+  cmdliner
+  devkit
+  devkit.core
+  extlib
+  lwt.unix
+  mirage-crypto-rng.unix
+  uri
+  unix)
  (preprocess
   (pps lwt_ppx))
  (public_name monorobot))

src/monorobot.ml

@@ -200,6 +200,7 @@ let default, info =
   Term.(ret (const (`Help (`Pager, None)))), Cmd.info "monorobot" ~doc ~version:Version.current
 
 let () =
+  Mirage_crypto_rng_unix.use_default ();
   let cmds = [ run; check_gh; check_slack; debug_db ] in
   let group = Cmd.group ~default info cmds in
   exit @@ Cmd.eval group

test/test.ml

@@ -37,7 +37,7 @@ let process_gh_payload ~(secrets : Config_t.secrets) ~config (kind, path, state_
     let%lwt n = Github.parse_exn headers event ~get_build_branch in
     let repo = Github.repo_of_notification n in
     (* overwrite repo url in secrets with that of notification for this test case *)
-    let secrets = { secrets with repos = [ { url = repo.url; gh_token = None; gh_hook_secret = None } ] } in
+    let secrets = { secrets with repos = [ { url = repo.url; auth = None; gh_hook_secret = None } ] } in
     ctx.secrets <- Some secrets;
     let (_ : State_t.repo_state) = State.find_or_add_repo ctx.state repo.url in
     let () =