From ad0c36164032e1466826e46b7b4ea414d26f350b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Zimmermann?= Date: Thu, 4 Jul 2024 11:36:17 +0200 Subject: [PATCH] Simplify process to generate a new install key and store install ids. --- bot-components/GitHub_app.ml | 53 ++++++++++----------------- bot-components/GitHub_app.mli | 5 +-- src/actions.ml | 8 ++-- src/bot.ml | 33 ++++++----------- src/github_installations.ml | 69 +++++++++++++++++++++++++---------- src/github_installations.mli | 13 ++++++- 6 files changed, 98 insertions(+), 83 deletions(-) diff --git a/bot-components/GitHub_app.ml b/bot-components/GitHub_app.ml index 430bd549..22e06583 100644 --- a/bot-components/GitHub_app.ml +++ b/bot-components/GitHub_app.ml @@ -56,40 +56,26 @@ let post ~bot_info ~body ~token ~url = in Cohttp_lwt.Body.to_string body -let get_installation_token ~bot_info ~owner ~repo ~jwt : +let get_installation_token ~bot_info ~key ~app_id ~install_id : (string * float, string) Result.t Lwt.t = - get ~bot_info ~token:jwt - ~url:(f "https://api.github.com/repos/%s/%s/installation" owner repo) - >>= (fun body -> - try - let json = Yojson.Basic.from_string body in - let access_token_url = - Yojson.Basic.Util.(json |> member "access_tokens_url" |> to_string) - in - post ~bot_info ~body:None ~token:jwt ~url:access_token_url - >|= Result.return - with - | Yojson.Json_error err -> - Lwt.return_error (f "Json error: %s" err) - | Yojson.Basic.Util.Type_error (err, _) -> - Lwt.return_error (f "Json type error: %s" err) ) - >|= Result.bind ~f:(fun resp -> - try - let json = Yojson.Basic.from_string resp in - Ok - (* Installation tokens expire after one hour, let's stop using them after 40 minutes *) - ( Yojson.Basic.Util.(json |> member "token" |> to_string) - , Unix.time () +. (40. *. 60.) ) - with - | Yojson.Json_error err -> - Error (f "Json error: %s" err) - | Yojson.Basic.Util.Type_error (err, _) -> - Error (f "Json type error: %s" err) ) - -let get_installation_token ~bot_info ~key ~app_id ~owner ~repo = match make_jwt ~key ~app_id with - | Ok jwt -> - get_installation_token ~bot_info ~jwt ~owner ~repo + | Ok jwt -> ( + let access_token_url = + f "https://api.github.com/app/installations/%d/access_tokens" install_id + in + post ~bot_info ~body:None ~token:jwt ~url:access_token_url + >|= fun resp -> + try + let json = Yojson.Basic.from_string resp in + Ok + (* Installation tokens expire after one hour, let's stop using them after 40 minutes *) + ( Yojson.Basic.Util.(json |> member "token" |> to_string) + , Unix.time () +. (40. *. 60.) ) + with + | Yojson.Json_error err -> + Error (f "Json error: %s" err) + | Yojson.Basic.Util.Type_error (err, _) -> + Error (f "Json type error: %s" err) ) | Error e -> Lwt.return (Error e) @@ -104,7 +90,8 @@ let get_installations ~bot_info ~key ~app_id = Ok ( json |> to_list |> List.map ~f:(fun json -> - json |> member "account" |> member "login" |> to_string ) ) + ( json |> member "account" |> member "login" |> to_string + , json |> member "id" |> to_int ) ) ) with | Yojson.Json_error err -> Error (f "Json error: %s" err) diff --git a/bot-components/GitHub_app.mli b/bot-components/GitHub_app.mli index 1ad71a41..b9e40058 100644 --- a/bot-components/GitHub_app.mli +++ b/bot-components/GitHub_app.mli @@ -2,12 +2,11 @@ val get_installation_token : bot_info:Bot_info.t -> key:Mirage_crypto_pk.Rsa.priv -> app_id:int - -> owner:string - -> repo:string + -> install_id:int -> (string * float, string) result Lwt.t val get_installations : bot_info:Bot_info.t -> key:Mirage_crypto_pk.Rsa.priv -> app_id:int - -> (string list, string) result Lwt.t + -> ((string * int) list, string) result Lwt.t diff --git a/src/actions.ml b/src/actions.ml index 019b275d..58b35dc6 100644 --- a/src/actions.ml +++ b/src/actions.ml @@ -1963,11 +1963,11 @@ let coq_bug_minimizer_results_action ~bot_info ~ci ~key ~app_id body = let stamp = Str.matched_group 1 body in let message = Str.matched_group 2 body in match Str.split (Str.regexp " ") stamp with - | [id; author; repo_name; branch_name; owner; repo; _ (*pr_number*)] - | [id; author; repo_name; branch_name; owner; repo] -> + | [id; author; repo_name; branch_name; owner; _repo; _ (*pr_number*)] + | [id; author; repo_name; branch_name; owner; _repo] -> (fun () -> Github_installations.action_as_github_app ~bot_info ~key ~app_id - ~owner ~repo + ~owner (GitHub_mutations.post_comment ~id:(GitHub_ID.of_string id) ~message:(if ci then message else f "@%s, %s" author message) ) >>= GitHub_mutations.report_on_posting_comment @@ -2015,7 +2015,7 @@ let coq_bug_minimizer_resume_ci_minimization_action ~bot_info ~key ~app_id body init_git_bare_repository ~bot_info >>= fun () -> Github_installations.action_as_github_app ~bot_info ~key ~app_id - ~owner ~repo + ~owner (run_ci_minimization ~comment_thread_id:(GitHub_ID.of_string comment_thread_id) ~owner ~repo ~base ~pr_number ~head diff --git a/src/bot.ml b/src/bot.ml index b8f13f51..90c01f8a 100644 --- a/src/bot.ml +++ b/src/bot.ml @@ -162,9 +162,9 @@ let callback _conn req body = | Error error_msg -> (fun () -> Lwt_io.printl error_msg) |> Lwt.async ; Server.respond_string ~status:`Bad_request ~body:error_msg () - | Ok (owner, repo) -> + | Ok (owner, _) -> (fun () -> - action_as_github_app ~bot_info ~key ~app_id ~owner ~repo + action_as_github_app ~bot_info ~key ~app_id ~owner (job_action ~gitlab_mapping job_info) ) |> Lwt.async ; Server.respond_string ~status:`OK ~body:"Job event." () ) @@ -174,9 +174,9 @@ let callback _conn req body = | Error error_msg -> (fun () -> Lwt_io.printl error_msg) |> Lwt.async ; Server.respond_string ~status:`Bad_request ~body:error_msg () - | Ok (owner, repo) -> + | Ok (owner, _) -> (fun () -> - action_as_github_app ~bot_info ~key ~app_id ~owner ~repo + action_as_github_app ~bot_info ~key ~app_id ~owner (pipeline_action ~gitlab_mapping pipeline_info) ) |> Lwt.async ; Server.respond_string ~status:`OK ~body:"Pipeline event." () ) @@ -205,10 +205,9 @@ let callback _conn req body = (fun () -> init_git_bare_repository ~bot_info >>= fun () -> - action_as_github_app ~bot_info ~key ~app_id ~owner:"coq" ~repo:"coq" + action_as_github_app ~bot_info ~key ~app_id ~owner:"coq" (coq_push_action ~base_ref ~commits_msg) <&> action_as_github_app ~bot_info ~key ~app_id ~owner:"coq" - ~repo:"coq" (mirror_action ~gitlab_domain:"gitlab.inria.fr" ~owner:"coq" ~repo:"coq" ~base_ref ~head_sha () ) ) |> Lwt.async ; @@ -223,7 +222,7 @@ let callback _conn req body = (fun () -> init_git_bare_repository ~bot_info >>= fun () -> - action_as_github_app ~bot_info ~key ~app_id ~owner ~repo + action_as_github_app ~bot_info ~key ~app_id ~owner (mirror_action ~gitlab_domain:"gitlab.com" ~owner ~repo ~base_ref ~head_sha () ) ) |> Lwt.async ; @@ -238,7 +237,7 @@ let callback _conn req body = (fun () -> init_git_bare_repository ~bot_info >>= fun () -> - action_as_github_app ~bot_info ~key ~app_id ~owner ~repo + action_as_github_app ~bot_info ~key ~app_id ~owner (mirror_action ~gitlab_domain:"gitlab.inria.fr" ~owner ~repo ~base_ref ~head_sha () ) ) |> Lwt.async ; @@ -256,7 +255,7 @@ let callback _conn req body = init_git_bare_repository ~bot_info >>= fun () -> action_as_github_app ~bot_info ~key ~app_id - ~owner:pr_info.issue.issue.owner ~repo:pr_info.issue.issue.repo + ~owner:pr_info.issue.issue.owner (pull_request_closed_action ~gitlab_mapping ~github_mapping pr_info ) ) |> Lwt.async ; @@ -272,14 +271,13 @@ let callback _conn req body = init_git_bare_repository ~bot_info >>= fun () -> action_as_github_app ~bot_info ~key ~app_id - ~owner:pr_info.issue.issue.owner ~repo:pr_info.issue.issue.repo + ~owner:pr_info.issue.issue.owner (pull_request_updated_action ~action ~pr_info ~gitlab_mapping ~github_mapping ) | Ok (_, IssueClosed {issue}) -> (* TODO: only for projects that requested this feature *) (fun () -> action_as_github_app ~bot_info ~key ~app_id ~owner:issue.owner - ~repo:issue.repo (adjust_milestone ~issue ~sleep_time:5.) ) |> Lwt.async ; Server.respond_string ~status:`OK @@ -323,7 +321,7 @@ let callback _conn req body = init_git_bare_repository ~bot_info >>= fun () -> action_as_github_app ~bot_info ~key ~app_id - ~owner:issue_info.issue.owner ~repo:issue_info.issue.repo + ~owner:issue_info.issue.owner (run_coq_minimizer ~script ~comment_thread_id:issue_info.id ~comment_author:issue_info.user ~owner:issue_info.issue.owner ~repo:issue_info.issue.repo @@ -347,7 +345,6 @@ let callback _conn req body = >>= fun () -> action_as_github_app ~bot_info ~key ~app_id ~owner:comment_info.issue.issue.owner - ~repo:comment_info.issue.issue.repo (run_coq_minimizer ~script ~comment_thread_id:comment_info.issue.id ~comment_author:comment_info.author @@ -368,7 +365,6 @@ let callback _conn req body = >>= fun () -> action_as_github_app ~bot_info ~key ~app_id ~owner:comment_info.issue.issue.owner - ~repo:comment_info.issue.issue.repo (ci_minimize ~comment_info ~requests ~comment_on_error:true ~options ~bug_file_contents:(Some bug_file_contents) ) ) |> Lwt.async ; @@ -382,7 +378,6 @@ let callback _conn req body = >>= fun () -> action_as_github_app ~bot_info ~key ~app_id ~owner:comment_info.issue.issue.owner - ~repo:comment_info.issue.issue.repo (ci_minimize ~comment_info ~requests ~comment_on_error:true ~options ~bug_file_contents:None ) ) @@ -416,7 +411,6 @@ let callback _conn req body = >>= fun () -> action_as_github_app ~bot_info ~key ~app_id ~owner:comment_info.issue.issue.owner - ~repo:comment_info.issue.issue.repo (run_ci_action ~comment_info ?full_ci ~gitlab_mapping ~github_mapping () ) else if @@ -432,7 +426,6 @@ let callback _conn req body = (fun () -> action_as_github_app ~bot_info ~key ~app_id ~owner:comment_info.issue.issue.owner - ~repo:comment_info.issue.issue.repo (merge_pull_request_action comment_info) ) |> Lwt.async ; Server.respond_string ~status:`OK @@ -451,7 +444,6 @@ let callback _conn req body = (fun () -> action_as_github_app ~bot_info ~key ~app_id ~owner:comment_info.issue.issue.owner - ~repo:comment_info.issue.issue.repo (run_bench ~key_value_pairs:[("coq_native", "yes")] comment_info ) ) @@ -471,7 +463,6 @@ let callback _conn req body = (fun () -> action_as_github_app ~bot_info ~key ~app_id ~owner:comment_info.issue.issue.owner - ~repo:comment_info.issue.issue.repo (run_bench comment_info) ) |> Lwt.async ; Server.respond_string ~status:`OK @@ -558,11 +549,11 @@ let callback _conn req body = let warn_after = 30 in let close_after = 30 in (fun () -> - action_as_github_app ~bot_info ~key ~app_id ~owner ~repo + action_as_github_app ~bot_info ~key ~app_id ~owner (coq_check_needs_rebase_pr ~owner ~repo ~warn_after ~close_after ~throttle:6 ) >>= fun () -> - action_as_github_app ~bot_info ~key ~app_id ~owner ~repo + action_as_github_app ~bot_info ~key ~app_id ~owner (coq_check_stale_pr ~owner ~repo ~after:close_after ~throttle:4) ) |> Lwt.async ; diff --git a/src/github_installations.ml b/src/github_installations.ml index 59b04a75..69e67769 100644 --- a/src/github_installations.ml +++ b/src/github_installations.ml @@ -1,51 +1,80 @@ open Base open Bot_components +open Helpers open Lwt -let installation_tokens : (string, string * float) Base.Hashtbl.t = +let installation_ids : (string, int) Base.Hashtbl.t = Hashtbl.create (module String) -let action_with_new_installation_token ~bot_info ~key ~app_id ~owner ~repo - action = +let installation_tokens : (int, string * float) Base.Hashtbl.t = + Hashtbl.create (module Int) + +let action_with_new_installation_token ~bot_info ~key ~app_id ~install_id action + = (* Installation tokens expire after one hour, we stop using them after 40 minutes *) - GitHub_app.get_installation_token ~bot_info ~key ~app_id ~owner ~repo + GitHub_app.get_installation_token ~bot_info ~key ~app_id ~install_id >>= function | Ok (install_token, expiration_date) -> let _ = - Hashtbl.add installation_tokens ~key:owner + Hashtbl.add installation_tokens ~key:install_id ~data:(install_token, expiration_date) in let bot_info : Bot_info.t = {bot_info with github_install_token= Some install_token} in action ~bot_info - | Error _ -> - (* If we cannot retrieve an installation token for the repository - repo owned by owner, we execute the action with the github access token. *) - action ~bot_info + | Error err -> + failwith + (f + "We did not manage to get an installation token for installation \ + %d: %s" + install_id err ) -let action_as_github_app ~bot_info ~key ~app_id ~owner ~repo action = +let action_as_github_app_from_install_id ~bot_info ~key ~app_id ~install_id + action = (* Executes an action with an installation token if the repository has the GitHub app installed. Generates a new installation token if the existing one has expired. *) - match Hashtbl.find installation_tokens owner with + match Hashtbl.find installation_tokens install_id with | Some (install_token, expiration_date) -> if Float.(expiration_date < Unix.time ()) then ( - Hashtbl.remove installation_tokens owner ; - action_with_new_installation_token ~bot_info ~key ~app_id ~owner ~repo + Hashtbl.remove installation_tokens install_id ; + action_with_new_installation_token ~bot_info ~key ~app_id ~install_id action ) else let bot_info : Bot_info.t = {bot_info with github_install_token= Some install_token} in action ~bot_info + | None -> + action_with_new_installation_token ~bot_info ~key ~app_id ~install_id + action + +let action_as_github_app ~bot_info ~key ~app_id ~owner action = + (* Executes an action with an installation token if the repository has + the GitHub app installed. + Generates a new installation token if the existing one has expired. *) + match Hashtbl.find installation_ids owner with + | Some install_id -> + action_as_github_app_from_install_id ~bot_info ~key ~app_id ~install_id + action | None -> ( GitHub_app.get_installations ~bot_info ~key ~app_id >>= function - | Ok installs -> - if List.exists installs ~f:(String.equal owner) then - action_with_new_installation_token ~bot_info ~key ~app_id ~owner - ~repo action - else action ~bot_info - | Error _ -> - action ~bot_info ) + | Ok installs -> ( + match + installs + |> List.find_map ~f:(fun (owner', install_id) -> + if String.equal owner owner' then Some install_id else None ) + with + | Some install_id -> + let _ = Hashtbl.add installation_ids ~key:owner ~data:install_id in + action_as_github_app_from_install_id ~bot_info ~key ~app_id + ~install_id action + | None -> + (* If the owner does not have the GitHub app installed, + we execute the action with the github access token. *) + action ~bot_info ) + | Error err -> + failwith + (f "We did not manage to get the list of installations: %s" err) ) diff --git a/src/github_installations.mli b/src/github_installations.mli index 118b519b..5ec7d1df 100644 --- a/src/github_installations.mli +++ b/src/github_installations.mli @@ -1,12 +1,21 @@ open Bot_components -val installation_tokens : (string, string * float) Base.Hashtbl.t +val installation_ids : (string, int) Base.Hashtbl.t + +val installation_tokens : (int, string * float) Base.Hashtbl.t + +val action_as_github_app_from_install_id : + bot_info:Bot_info.t + -> key:Mirage_crypto_pk.Rsa.priv + -> app_id:int + -> install_id:int + -> (bot_info:Bot_info.t -> 'a Lwt.t) + -> 'a Lwt.t val action_as_github_app : bot_info:Bot_info.t -> key:Mirage_crypto_pk.Rsa.priv -> app_id:int -> owner:string - -> repo:string -> (bot_info:Bot_info.t -> 'a Lwt.t) -> 'a Lwt.t