diff --git a/bot-components/GraphQL_query.ml b/bot-components/GraphQL_query.ml index fc683ddb..245a06a9 100644 --- a/bot-components/GraphQL_query.ml +++ b/bot-components/GraphQL_query.ml @@ -8,7 +8,8 @@ let send_graphql_query ~bot_info ?(extra_headers = []) ~query ~parse variables = let headers = Cohttp.Header.of_list ( [ ("Authorization", "bearer " ^ github_token bot_info) - ; ("User-Agent", bot_info.name) ] + ; ("User-Agent", bot_info.name) + ; ("Content-Type", "application/json") ] @ extra_headers ) in let request_json = diff --git a/src/actions.ml b/src/actions.ml index e0d39b01..842db3bf 100644 --- a/src/actions.ml +++ b/src/actions.ml @@ -2383,35 +2383,25 @@ let pull_request_updated_action ~bot_info ~(action : GitHub_types.pull_request_action) ~(pr_info : GitHub_types.issue_info GitHub_types.pull_request_info) ~gitlab_mapping ~github_mapping = - ( match (action, pr_info.base.branch.repo_url) with + (let open Lwt.Syntax in + let* _ = update_pr pr_info ~bot_info ~gitlab_mapping ~github_mapping in + Lwt.return_unit ) + <&> + match (action, pr_info.base.branch.repo_url) with | PullRequestOpened, "https://github.com/coq/coq" when String.equal pr_info.base.branch.name pr_info.head.branch.name -> - (fun () -> - GitHub_mutations.post_comment ~bot_info ~id:pr_info.issue.id - ~message: - (f - "Hello, thanks for your pull request!\n\ - In the future, we strongly recommend that you *do not* use %s \ - as the name of your branch when submitting a pull request.\n\ - By the way, you may be interested in reading [our contributing \ - guide](https://github.com/coq/coq/blob/master/CONTRIBUTING.md)." - pr_info.base.branch.name ) - >>= GitHub_mutations.report_on_posting_comment ) - |> Lwt.async + GitHub_mutations.post_comment ~bot_info ~id:pr_info.issue.id + ~message: + (f + "Hello, thanks for your pull request!\n\ + In the future, we strongly recommend that you *do not* use %s as \ + the name of your branch when submitting a pull request.\n\ + By the way, you may be interested in reading [our contributing \ + guide](https://github.com/coq/coq/blob/master/CONTRIBUTING.md)." + pr_info.base.branch.name ) + >>= GitHub_mutations.report_on_posting_comment | _ -> - () ) ; - (fun () -> - update_pr pr_info ~bot_info ~gitlab_mapping ~github_mapping - >>= fun _ -> Lwt.return_unit ) - |> Lwt.async ; - Server.respond_string ~status:`OK - ~body: - (f - "Pull request %s/%s#%d was (re)opened / synchronized: (force-)pushing \ - to GitLab." - pr_info.issue.issue.owner pr_info.issue.issue.repo - pr_info.issue.issue.number ) - () + Lwt.return_unit let rec adjust_milestone ~bot_info ~issue ~sleep_time = (* We implement an exponential backoff strategy to try again after @@ -2692,7 +2682,8 @@ let run_bench ~bot_info ?key_value_pairs comment_info = match (allowed_to_bench, process_summary) with | Ok true, Ok (build_id, project_id) -> (* Permission to bench has been granted *) - GitLab_mutations.play_job ~bot_info ~project_id ~build_id ?key_value_pairs () + GitLab_mutations.play_job ~bot_info ~project_id ~build_id ?key_value_pairs + () | Error err, _ | _, Error err -> GitHub_mutations.post_comment ~bot_info ~message:err ~id:pr.id >>= GitHub_mutations.report_on_posting_comment diff --git a/src/actions.mli b/src/actions.mli index 594447e3..e874b018 100644 --- a/src/actions.mli +++ b/src/actions.mli @@ -60,7 +60,7 @@ val pull_request_updated_action : -> pr_info:GitHub_types.issue_info GitHub_types.pull_request_info -> gitlab_mapping:(string, string) Base.Hashtbl.t -> github_mapping:(string, string) Base.Hashtbl.t - -> (Cohttp.Response.t * Cohttp_lwt__.Body.t) Lwt.t + -> unit Lwt.t val adjust_milestone : bot_info:Bot_info.t diff --git a/src/bot.ml b/src/bot.ml index 7eafb023..ffb367ed 100644 --- a/src/bot.ml +++ b/src/bot.ml @@ -44,12 +44,9 @@ let string_of_installation_tokens = Hashtbl.fold ~init:"" ~f:(fun ~key ~data acc -> acc ^ f "Owner: %s, token: %s, expire at: %f\n" key (fst data) (snd data) ) -(* TODO: deprecate unsigned webhooks *) - -let callback _conn req body = - let body = Cohttp_lwt.Body.to_string body in - let extract_minimize_file body = - body +let github_endpoint req body = + let extract_minimize_file arg = + arg |> Str.split (Str.regexp_string "\n```") |> List.hd |> Option.value ~default:"" in @@ -73,6 +70,298 @@ let callback _conn req body = (f "@\\1%s " @@ Str.quote bot_name) body in + match + GitHub_subscriptions.receive_github ~secret:github_webhook_secret + (Request.headers req) body + with + | Ok (_, PushEvent {owner; repo; base_ref; commits_msg}) -> + (fun () -> + init_git_bare_repository ~bot_info + >>= fun () -> + action_as_github_app ~bot_info ~key ~app_id ~owner ~repo + (push_action ~base_ref ~commits_msg) ) + |> Lwt.async ; + Server.respond_string ~status:`OK ~body:"Processing push event." () + | Ok (_, PullRequestUpdated (PullRequestClosed, pr_info)) -> + (fun () -> + 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 + (pull_request_closed_action ~gitlab_mapping ~github_mapping pr_info) + ) + |> Lwt.async ; + Server.respond_string ~status:`OK + ~body: + (f + "Pull request %s/%s#%d was closed: removing the branch from \ + GitLab." + pr_info.issue.issue.owner pr_info.issue.issue.repo + pr_info.issue.issue.number ) + () + | Ok (_, PullRequestUpdated (action, pr_info)) -> + (fun () -> + 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 + (pull_request_updated_action ~action ~pr_info ~gitlab_mapping + ~github_mapping ) ) + |> Lwt.async ; + Server.respond_string ~status:`OK + ~body: + (f + "Pull request %s/%s#%d was (re)opened / synchronized: \ + (force-)pushing to GitLab." + pr_info.issue.issue.owner pr_info.issue.issue.repo + pr_info.issue.issue.number ) + () + | 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 + ~body: + (f "Issue %s/%s#%d was closed: checking its milestone." issue.owner + issue.repo issue.number ) + () + | Ok (_, RemovedFromProject ({issue= Some issue; column_id} as card)) -> + (fun () -> + action_as_github_app ~bot_info ~key ~app_id ~owner:issue.owner + ~repo:issue.repo + (project_action ~issue ~column_id) ) + |> Lwt.async ; + Server.respond_string ~status:`OK + ~body: + (f + "Issue or PR %s/%s#%d was removed from project column %d: \ + checking if this was a backporting column." + issue.owner issue.repo issue.number card.column_id ) + () + | Ok (_, RemovedFromProject _) -> + Server.respond_string ~status:`OK + ~body:"Note card removed from project: nothing to do." () + | Ok (_, IssueOpened ({body= Some body} as issue_info)) -> ( + let body = body |> Helpers.trim_comments |> strip_quoted_bot_name in + match coqbot_minimize_text_of_body body with + | Some script -> + (fun () -> + 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 + (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 ) ) + |> Lwt.async ; + Server.respond_string ~status:`OK ~body:"Handling minimization." () + | None -> + Server.respond_string ~status:`OK + ~body:(f "Unhandled new issue: %s" body) + () ) + | Ok (signed, CommentCreated comment_info) -> ( + let body = + comment_info.body |> Helpers.trim_comments |> strip_quoted_bot_name + in + match coqbot_minimize_text_of_body body with + | Some script -> + (fun () -> + init_git_bare_repository ~bot_info + >>= 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 + ~owner:comment_info.issue.issue.owner + ~repo:comment_info.issue.issue.repo ) ) + |> Lwt.async ; + Server.respond_string ~status:`OK ~body:"Handling minimization." () + | None -> + let parse_minimiation_requests requests = + requests + |> Str.global_replace (Str.regexp "[ ,]+") " " + |> String.split ~on:' ' + |> List.map ~f:Stdlib.String.trim + (* remove trailing : in case the user stuck a : at the end of the line *) + |> List.map ~f:(Str.global_replace (Str.regexp ":$") "") + |> List.filter ~f:(fun r -> not (String.is_empty r)) + in + if + string_match + ~regexp: + ( f "@%s:? [Cc][Ii][- ][Mm]inimize:?\\([^\n]*\\)" + @@ Str.quote bot_name ) + body + then ( + let requests = + Str.matched_group 1 body |> parse_minimiation_requests + in + (fun () -> + init_git_bare_repository ~bot_info + >>= 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 + ~bug_file_contents:None ) ) + |> Lwt.async ; + Server.respond_string ~status:`OK ~body:"Handling CI minimization." + () ) + else if + string_match + ~regexp: + ( f + "@%s:? resume [Cc][Ii][- ][Mm]inimiz\\(e\\|ation\\):?\\([^\n\ + ]*\\)\n\ + +```[^\n\ + ]*\n\ + \\(\\(.\\|\n\ + \\)+\\)" + @@ Str.quote bot_name ) + body + then ( + let requests, bug_file_contents = + (Str.matched_group 2 body, Str.matched_group 3 body) + in + let requests, bug_file_contents = + ( parse_minimiation_requests requests + , extract_minimize_file bug_file_contents ) + in + (fun () -> + init_git_bare_repository ~bot_info + >>= 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 + ~bug_file_contents:(Some bug_file_contents) ) ) + |> Lwt.async ; + Server.respond_string ~status:`OK + ~body:"Handling CI minimization resumption." () ) + else if + string_match + ~regexp: + ( f "@%s:? [Rr]un \\(full\\|light\\|\\) ?[Cc][Ii]" + @@ Str.quote bot_name ) + body + && comment_info.issue.pull_request + && String.equal comment_info.issue.issue.owner "coq" + && String.equal comment_info.issue.issue.repo "coq" + && signed + then + let full_ci = + match Str.matched_group 1 body with + | "full" -> + Some true + | "light" -> + Some false + | "" -> + None + | _ -> + failwith "Impossible group value." + in + init_git_bare_repository ~bot_info + >>= 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 + string_match + ~regexp:(f "@%s:? [Mm]erge now" @@ Str.quote bot_name) + body + && comment_info.issue.pull_request + && String.equal comment_info.issue.issue.owner "coq" + && String.equal comment_info.issue.issue.repo "coq" + && signed + then ( + (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 + ~body:(f "Received a request to merge the PR.") + () ) + else if + string_match + ~regexp:(f "@%s:? [Bb]ench native" @@ Str.quote bot_name) + body + && comment_info.issue.pull_request + && String.equal comment_info.issue.issue.owner "coq" + && String.equal comment_info.issue.issue.repo "coq" + && signed + then ( + (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 ) ) + |> Lwt.async ; + Server.respond_string ~status:`OK + ~body:(f "Received a request to start the bench.") + () ) + else if + string_match ~regexp:(f "@%s:? [Bb]ench" @@ Str.quote bot_name) body + && comment_info.issue.pull_request + && String.equal comment_info.issue.issue.owner "coq" + && String.equal comment_info.issue.issue.repo "coq" + && signed + then ( + (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 + ~body:(f "Received a request to start the bench.") + () ) + else + Server.respond_string ~status:`OK + ~body:(f "Unhandled comment: %s" body) + () ) + | Ok (signed, CheckRunReRequested {external_id}) -> + if not signed then + Server.respond_string ~status:(Code.status_of_code 401) + ~body:"Request to rerun check run must be signed." () + else if String.is_empty external_id then + Server.respond_string ~status:(Code.status_of_code 400) + ~body:"Request to rerun check run but empty external ID." () + else ( + (fun () -> + GitLab_mutations.generic_retry ~bot_info ~url_part:external_id ) + |> Lwt.async ; + Server.respond_string ~status:`OK + ~body: + (f "Received a request to re-run a job / pipeline (GitLab ID : %s)." + external_id ) + () ) + | Ok (_, UnsupportedEvent s) -> + Server.respond_string ~status:`OK ~body:(f "No action taken: %s" s) () + | Ok _ -> + Server.respond_string ~status:`OK + ~body:"No action taken: event or action is not yet supported." () + | Error ("Webhook signed but with wrong signature." as e) -> + Stdio.print_string e ; + Server.respond_string ~status:(Code.status_of_code 401) + ~body:(f "Error: %s" e) () + | Error e -> + Server.respond_string ~status:(Code.status_of_code 400) + ~body:(f "Error: %s" e) () + +(* TODO: deprecate unsigned webhooks *) + +let callback _conn req body = + let body = Cohttp_lwt.Body.to_string body in (* print_endline "Request received."; *) match Uri.path (Request.uri req) with | "/job" | "/pipeline" (* legacy endpoints *) | "/gitlab" -> ( @@ -114,295 +403,10 @@ let callback _conn req body = | Error e -> Server.respond_string ~status:(Code.status_of_code 400) ~body:(f "Error: %s" e) () ) - | "/push" | "/pull_request" (* legacy endpoints *) | "/github" -> ( - body - >>= fun body -> - match - GitHub_subscriptions.receive_github ~secret:github_webhook_secret - (Request.headers req) body - with - | Ok (_, PushEvent {owner; repo; base_ref; commits_msg}) -> - (fun () -> - init_git_bare_repository ~bot_info - >>= fun () -> - action_as_github_app ~bot_info ~key ~app_id ~owner ~repo - (push_action ~base_ref ~commits_msg) ) - |> Lwt.async ; - Server.respond_string ~status:`OK ~body:"Processing push event." () - | Ok (_, PullRequestUpdated (PullRequestClosed, pr_info)) -> - (fun () -> - 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 - (pull_request_closed_action ~gitlab_mapping ~github_mapping - pr_info ) ) - |> Lwt.async ; - Server.respond_string ~status:`OK - ~body: - (f - "Pull request %s/%s#%d was closed: removing the branch from \ - GitLab." - pr_info.issue.issue.owner pr_info.issue.issue.repo - pr_info.issue.issue.number ) - () - | Ok (_, PullRequestUpdated (action, pr_info)) -> - 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 - (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 - ~body: - (f "Issue %s/%s#%d was closed: checking its milestone." - issue.owner issue.repo issue.number ) - () - | Ok (_, RemovedFromProject ({issue= Some issue; column_id} as card)) -> - (fun () -> - action_as_github_app ~bot_info ~key ~app_id ~owner:issue.owner - ~repo:issue.repo - (project_action ~issue ~column_id) ) - |> Lwt.async ; - Server.respond_string ~status:`OK - ~body: - (f - "Issue or PR %s/%s#%d was removed from project column %d: \ - checking if this was a backporting column." - issue.owner issue.repo issue.number card.column_id ) - () - | Ok (_, RemovedFromProject _) -> - Server.respond_string ~status:`OK - ~body:"Note card removed from project: nothing to do." () - | Ok (_, IssueOpened ({body= Some body} as issue_info)) -> ( - let body = body |> Helpers.trim_comments |> strip_quoted_bot_name in - match coqbot_minimize_text_of_body body with - | Some script -> - (fun () -> - 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 - (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 ) - ) - |> Lwt.async ; - Server.respond_string ~status:`OK ~body:"Handling minimization." - () - | None -> - Server.respond_string ~status:`OK - ~body:(f "Unhandled new issue: %s" body) - () ) - | Ok (signed, CommentCreated comment_info) -> ( - let body = - comment_info.body |> Helpers.trim_comments |> strip_quoted_bot_name - in - match coqbot_minimize_text_of_body body with - | Some script -> - (fun () -> - init_git_bare_repository ~bot_info - >>= 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 - ~owner:comment_info.issue.issue.owner - ~repo:comment_info.issue.issue.repo ) ) - |> Lwt.async ; - Server.respond_string ~status:`OK ~body:"Handling minimization." - () - | None -> - let parse_minimiation_requests requests = - requests - |> Str.global_replace (Str.regexp "[ ,]+") " " - |> String.split ~on:' ' - |> List.map ~f:Stdlib.String.trim - (* remove trailing : in case the user stuck a : at the end of the line *) - |> List.map ~f:(Str.global_replace (Str.regexp ":$") "") - |> List.filter ~f:(fun r -> not (String.is_empty r)) - in - if - string_match - ~regexp: - ( f "@%s:? [Cc][Ii][- ][Mm]inimize:?\\([^\n]*\\)" - @@ Str.quote bot_name ) - body - then ( - let requests = - Str.matched_group 1 body |> parse_minimiation_requests - in - (fun () -> - init_git_bare_repository ~bot_info - >>= 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 - ~bug_file_contents:None ) ) - |> Lwt.async ; - Server.respond_string ~status:`OK - ~body:"Handling CI minimization." () ) - else if - string_match - ~regexp: - ( f - "@%s:? resume [Cc][Ii][- \ - ][Mm]inimiz\\(e\\|ation\\):?\\([^\n\ - ]*\\)\n\ - +```[^\n\ - ]*\n\ - \\(\\(.\\|\n\ - \\)+\\)" - @@ Str.quote bot_name ) - body - then ( - let requests, bug_file_contents = - (Str.matched_group 2 body, Str.matched_group 3 body) - in - let requests, bug_file_contents = - ( parse_minimiation_requests requests - , extract_minimize_file bug_file_contents ) - in - (fun () -> - init_git_bare_repository ~bot_info - >>= 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 - ~bug_file_contents:(Some bug_file_contents) ) ) - |> Lwt.async ; - Server.respond_string ~status:`OK - ~body:"Handling CI minimization resumption." () ) - else if - string_match - ~regexp: - ( f "@%s:? [Rr]un \\(full\\|light\\|\\) ?[Cc][Ii]" - @@ Str.quote bot_name ) - body - && comment_info.issue.pull_request - && String.equal comment_info.issue.issue.owner "coq" - && String.equal comment_info.issue.issue.repo "coq" - && signed - then - let full_ci = - match Str.matched_group 1 body with - | "full" -> - Some true - | "light" -> - Some false - | "" -> - None - | _ -> - failwith "Impossible group value." - in - init_git_bare_repository ~bot_info - >>= 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 - string_match - ~regexp:(f "@%s:? [Mm]erge now" @@ Str.quote bot_name) - body - && comment_info.issue.pull_request - && String.equal comment_info.issue.issue.owner "coq" - && String.equal comment_info.issue.issue.repo "coq" - && signed - then ( - (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 - ~body:(f "Received a request to merge the PR.") - () ) - else if - string_match - ~regexp:(f "@%s:? [Bb]ench native" @@ Str.quote bot_name) - body - && comment_info.issue.pull_request - && String.equal comment_info.issue.issue.owner "coq" - && String.equal comment_info.issue.issue.repo "coq" - && signed - then ( - (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 ) ) - |> Lwt.async ; - Server.respond_string ~status:`OK - ~body:(f "Received a request to start the bench.") - () ) - else if - string_match - ~regexp:(f "@%s:? [Bb]ench" @@ Str.quote bot_name) - body - && comment_info.issue.pull_request - && String.equal comment_info.issue.issue.owner "coq" - && String.equal comment_info.issue.issue.repo "coq" - && signed - then ( - (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 - ~body:(f "Received a request to start the bench.") - () ) - else - Server.respond_string ~status:`OK - ~body:(f "Unhandled comment: %s" body) - () ) - | Ok (signed, CheckRunReRequested {external_id}) -> - if not signed then - Server.respond_string ~status:(Code.status_of_code 401) - ~body:"Request to rerun check run must be signed." () - else if String.is_empty external_id then - Server.respond_string ~status:(Code.status_of_code 400) - ~body:"Request to rerun check run but empty external ID." () - else ( - (fun () -> - GitLab_mutations.generic_retry ~bot_info ~url_part:external_id ) - |> Lwt.async ; - Server.respond_string ~status:`OK - ~body: - (f - "Received a request to re-run a job / pipeline (GitLab ID : \ - %s)." - external_id ) - () ) - | Ok (_, UnsupportedEvent s) -> - Server.respond_string ~status:`OK ~body:(f "No action taken: %s" s) () - | Ok _ -> - Server.respond_string ~status:`OK - ~body:"No action taken: event or action is not yet supported." () - | Error ("Webhook signed but with wrong signature." as e) -> - Stdio.print_string e ; - Server.respond_string ~status:(Code.status_of_code 401) - ~body:(f "Error: %s" e) () - | Error e -> - Server.respond_string ~status:(Code.status_of_code 400) - ~body:(f "Error: %s" e) () ) + | "/push" | "/pull_request" (* legacy endpoints *) | "/github" -> + let open Lwt.Syntax in + let* body = body in + github_endpoint req body | "/coq-bug-minimizer" -> body >>= fun body ->