From 0628a1e5665d2900a0a23358022339385529fcda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Zimmermann?= Date: Thu, 12 Nov 2020 20:56:20 +0100 Subject: [PATCH] Refactoring preliminary to extending the info stored in pipeline_info. --- bot-components/GitLab_subscriptions.ml | 25 +++--- bot-components/GitLab_subscriptions.mli | 2 +- bot-components/GitLab_types.mli | 18 ++--- src/actions.ml | 100 ++++++++++++------------ src/actions.mli | 47 +++++------ src/bot.ml | 3 +- 6 files changed, 95 insertions(+), 100 deletions(-) diff --git a/bot-components/GitLab_subscriptions.ml b/bot-components/GitLab_subscriptions.ml index 37d2a9f4..d5016765 100644 --- a/bot-components/GitLab_subscriptions.ml +++ b/bot-components/GitLab_subscriptions.ml @@ -32,38 +32,37 @@ let job_info_of_json json = let commit = json |> extract_commit in let branch = json |> member "ref" |> to_string in let repo_url = json |> member "repository" |> member "url" |> to_string in - let failure_reason, allow_fail = - if String.equal build_status "failed" then - ( json |> member "build_failure_reason" |> to_string |> Option.some - , json |> member "build_allow_failure" |> to_bool |> Option.some ) - else (None, None) + let failure_reason = + json |> member "build_failure_reason" |> to_string |> Option.some in + let allow_fail = json |> member "build_allow_failure" |> to_bool in { build_status ; build_id ; build_name - ; commit - ; branch - ; repo_url - ; project_id ; failure_reason - ; allow_fail } + ; allow_fail + ; common_info= {commit; branch; repo_url; project_id} } let pipeline_info_of_json json = let open Yojson.Basic.Util in let pipeline_json = json |> member "object_attributes" in let state = pipeline_json |> member "status" |> to_string in - let id = pipeline_json |> member "id" |> to_int in + let pipeline_id = pipeline_json |> member "id" |> to_int in let commit = json |> extract_commit in let branch = json |> member "object_attributes" |> member "ref" |> to_string in let project = json |> member "project" in + let repo_url = project |> member "web_url" |> to_string in let project_path = project |> member "path_with_namespace" |> to_string in let project_id = project |> member "id" |> to_int in - {state; id; commit; branch; project_path; project_id} + { state + ; pipeline_id + ; project_path + ; common_info= {commit; branch; repo_url; project_id} } type msg = - | JobEvent of job_info + | JobEvent of ci_common_info job_info | PipelineEvent of pipeline_info | UnsupportedEvent of string diff --git a/bot-components/GitLab_subscriptions.mli b/bot-components/GitLab_subscriptions.mli index 9a24788f..f485832c 100644 --- a/bot-components/GitLab_subscriptions.mli +++ b/bot-components/GitLab_subscriptions.mli @@ -1,7 +1,7 @@ open GitLab_types type msg = - | JobEvent of job_info + | JobEvent of ci_common_info job_info | PipelineEvent of pipeline_info | UnsupportedEvent of string diff --git a/bot-components/GitLab_types.mli b/bot-components/GitLab_types.mli index b9faa2c5..10beeccd 100644 --- a/bot-components/GitLab_types.mli +++ b/bot-components/GitLab_types.mli @@ -1,18 +1,16 @@ -type job_info = +type ci_common_info = + {commit: string; branch: string; repo_url: string; project_id: int} + +type 'a job_info = { build_status: string ; build_id: int ; build_name: string - ; commit: string - ; branch: string - ; repo_url: string - ; project_id: int ; failure_reason: string option - ; allow_fail: bool option } + ; allow_fail: bool + ; common_info: 'a } type pipeline_info = { state: string - ; id: int - ; commit: string - ; branch: string + ; pipeline_id: int ; project_path: string - ; project_id: int } + ; common_info: ci_common_info } diff --git a/src/actions.ml b/src/actions.ml index 187c59b4..bd0df636 100644 --- a/src/actions.ml +++ b/src/actions.ml @@ -14,12 +14,9 @@ let owner_team_map = (module String) [("martijnbastiaan-test-org", "martijnbastiaan-test-team")] -let send_status_check ~bot_info (job_info : job_info) ~pr_num - (gh_owner, gh_repo) ~github_repo_full_name ~gitlab_repo_full_name ~context - ~failure_reason ~external_id ~trace = - let allow_fail = - match job_info.allow_fail with Some f -> f | None -> false - in +let send_status_check ~bot_info job_info ~pr_num (gh_owner, gh_repo) + ~github_repo_full_name ~gitlab_repo_full_name ~context ~failure_reason + ~external_id ~trace = let job_url = f "https://gitlab.com/%s/-/jobs/%d" gitlab_repo_full_name job_info.build_id in @@ -50,7 +47,7 @@ let send_status_check ~bot_info (job_info : job_info) ~pr_num trace is available [here](%s))." job_url in - if allow_fail then + if job_info.allow_fail then Lwt_io.printf "Job is allowed to fail.\n" <&> ( match bot_info.github_token with | ACCESS_TOKEN _ -> @@ -62,8 +59,9 @@ let send_status_check ~bot_info (job_info : job_info) ~pr_num >>= function | Ok repo_id -> GitHub_mutations.create_check_run ~bot_info ~name:context - ~repo_id ~head_sha:job_info.commit ~conclusion:NEUTRAL - ~status:COMPLETED ~title ~details_url:job_url + ~repo_id ~head_sha:job_info.common_info.commit + ~conclusion:NEUTRAL ~status:COMPLETED ~title + ~details_url:job_url ~summary: ("This job is allowed to fail.\n\n" ^ trace_description) ~text ~external_id () @@ -83,13 +81,14 @@ let send_status_check ~bot_info (job_info : job_info) ~pr_num >>= function | Ok {issue= id; head} (* Commits reported back by get_pull_request_refs are surrounded in double quotes *) - when String.equal head.sha (f "\"%s\"" job_info.commit) -> + when String.equal head.sha (f "\"%s\"" job_info.common_info.commit) + -> GitHub_mutations.post_comment ~bot_info ~id ~message | Ok {head} -> Lwt_io.printf "We are on a PR branch but the commit (%s) is not the current \ head of the PR (%s). Doing nothing.\n" - job_info.commit head.sha + job_info.common_info.commit head.sha | Error err -> Lwt_io.printf "Couldn't get a database id for %s#%d because the following \ @@ -105,15 +104,15 @@ let send_status_check ~bot_info (job_info : job_info) ~pr_num match bot_info.github_token with | ACCESS_TOKEN _t -> GitHub_mutations.send_status_check ~repo_full_name:github_repo_full_name - ~commit:job_info.commit ~state:"failure" ~url:job_url ~context - ~description:title ~bot_info + ~commit:job_info.common_info.commit ~state:"failure" ~url:job_url + ~context ~description:title ~bot_info | INSTALL_TOKEN _t -> ( GitHub_queries.get_repository_id ~bot_info ~owner:gh_owner ~repo:gh_repo >>= function | Ok repo_id -> GitHub_mutations.create_check_run ~bot_info ~name:context ~repo_id - ~head_sha:job_info.commit ~conclusion:FAILURE ~status:COMPLETED - ~title ~details_url:job_url + ~head_sha:job_info.common_info.commit ~conclusion:FAILURE + ~status:COMPLETED ~title ~details_url:job_url ~summary: ( "This job has failed. If you need to, you can restart it \ directly in the GitHub interface using the \"Re-run\" \ @@ -122,21 +121,21 @@ let send_status_check ~bot_info (job_info : job_info) ~pr_num | Error e -> Lwt_io.printf "No repo id: %s\n" e ) -let send_doc_url_aux ~bot_info (job_info : job_info) (kind, url) = +let send_doc_url_aux ~bot_info job_info (kind, url) = let context = f "%s: %s artifact" job_info.build_name kind in let description_base = f "Link to %s build artifact" kind in url |> Uri.of_string |> Client.get >>= fun (resp, _) -> if resp |> Response.status |> Code.code_of_status |> Int.equal 200 then GitHub_mutations.send_status_check ~repo_full_name:"coq/coq" - ~commit:job_info.commit ~state:"success" ~url ~context + ~commit:job_info.common_info.commit ~state:"success" ~url ~context ~description:(description_base ^ ".") ~bot_info else Lwt_io.printf "But we didn't get a 200 code when checking the URL.\n" <&> let job_url = f "https://gitlab.com/coq/coq/-/jobs/%d" job_info.build_id in GitHub_mutations.send_status_check ~repo_full_name:"coq/coq" - ~commit:job_info.commit ~state:"failure" ~url:job_url ~context + ~commit:job_info.common_info.commit ~state:"failure" ~url:job_url ~context ~description:(description_base ^ ": not found.") ~bot_info @@ -227,9 +226,11 @@ let trace_action ~repo_full_name trace = Ignore ) else Warn trace -let job_failure ~bot_info ({project_id; build_id} as job_info) ~pr_num - (gh_owner, gh_repo) ~github_repo_full_name ~gitlab_repo_full_name ~context - ~failure_reason ~external_id = +let job_failure ~bot_info job_info ~pr_num (gh_owner, gh_repo) + ~github_repo_full_name ~gitlab_repo_full_name ~context ~failure_reason + ~external_id = + let build_id = job_info.build_id in + let project_id = job_info.common_info.project_id in Lwt_io.printf "Failed job %d of project %d.\nFailure reason: %s\n" build_id project_id failure_reason >>= fun () -> @@ -253,10 +254,11 @@ let job_failure ~bot_info ({project_id; build_id} as job_info) ~pr_num | Ignore -> Lwt.return () ) -let job_success_or_pending ~bot_info (gh_owner, gh_repo) (job_info : job_info) - ~github_repo_full_name ~gitlab_repo_full_name ~context ~state ~external_id = +let job_success_or_pending ~bot_info (gh_owner, gh_repo) + ({build_id} as job_info) ~github_repo_full_name ~gitlab_repo_full_name + ~context ~state ~external_id = GitHub_queries.get_status_check ~bot_info ~owner:gh_owner ~repo:gh_repo - ~commit:job_info.commit ~context + ~commit:job_info.common_info.commit ~context >>= function | Ok true -> ( Lwt_io.printf @@ -264,8 +266,7 @@ let job_success_or_pending ~bot_info (gh_owner, gh_repo) (job_info : job_info) it.\n" <&> let job_url = - f "https://gitlab.com/%s/-/jobs/%d" gitlab_repo_full_name - job_info.build_id + f "https://gitlab.com/%s/-/jobs/%d" gitlab_repo_full_name build_id in let state, status, conclusion, description = match state with @@ -292,15 +293,16 @@ let job_success_or_pending ~bot_info (gh_owner, gh_repo) (job_info : job_info) match bot_info.github_token with | ACCESS_TOKEN _t -> GitHub_mutations.send_status_check ~bot_info - ~repo_full_name:github_repo_full_name ~commit:job_info.commit ~state - ~url:job_url ~context ~description + ~repo_full_name:github_repo_full_name + ~commit:job_info.common_info.commit ~state ~url:job_url ~context + ~description | INSTALL_TOKEN _t -> ( GitHub_queries.get_repository_id ~bot_info ~owner:gh_owner ~repo:gh_repo >>= function | Ok repo_id -> GitHub_mutations.create_check_run ~bot_info ~name:context ~status - ~repo_id ~head_sha:job_info.commit ?conclusion + ~repo_id ~head_sha:job_info.common_info.commit ?conclusion ~title:description ~details_url:job_url ~summary:"" ~external_id () | Error e -> @@ -310,11 +312,11 @@ let job_success_or_pending ~bot_info (gh_owner, gh_repo) (job_info : job_info) | Error e -> Lwt_io.printf "%s\n" e -let job_action ~bot_info (job_info : job_info) ~gitlab_mapping = - let pr_num, branch_or_pr = pr_from_branch job_info.branch in - let context = f "GitLab CI job %s (%s)" job_info.build_name branch_or_pr in +let job_action ~bot_info ({build_name} as job_info) ~gitlab_mapping = + let pr_num, branch_or_pr = pr_from_branch job_info.common_info.branch in + let context = f "GitLab CI job %s (%s)" build_name branch_or_pr in let owner, repo = - let repo_url = job_info.repo_url in + let repo_url = job_info.common_info.repo_url in if not (string_match ~regexp:".*:\\(.*\\)/\\(.*\\).git" repo_url) then failwith "Could not match project name on repository url.\n" ; (Str.matched_group 1 repo_url, Str.matched_group 2 repo_url) @@ -325,7 +327,7 @@ let job_action ~bot_info (job_info : job_info) ~gitlab_mapping = in let github_repo_full_name = gh_owner ^ "/" ^ gh_repo in let external_id = - f "projects/%d/jobs/%d" job_info.project_id job_info.build_id + f "projects/%d/jobs/%d" job_info.common_info.project_id job_info.build_id in match job_info.build_status with | "failed" -> @@ -362,10 +364,12 @@ let pipeline_action ~bot_info pipeline_info ~gitlab_mapping : unit Lwt.t = Lwt.return () | _ -> ( let pipeline_url = - f "https://gitlab.com/%s/pipelines/%d" gitlab_full_name pipeline_info.id + f "https://gitlab.com/%s/pipelines/%d" gitlab_full_name + pipeline_info.pipeline_id in let external_id = - f "projects/%d/pipelines/%d" pipeline_info.project_id pipeline_info.id + f "projects/%d/pipelines/%d" pipeline_info.common_info.project_id + pipeline_info.pipeline_id in match bot_info.github_token with | ACCESS_TOKEN _t -> @@ -385,10 +389,10 @@ let pipeline_action ~bot_info pipeline_info ~gitlab_mapping : unit Lwt.t = ("error", "Unknown pipeline status: " ^ s) in GitHub_mutations.send_status_check ~repo_full_name - ~commit:pipeline_info.commit ~state ~url:pipeline_url + ~commit:pipeline_info.common_info.commit ~state ~url:pipeline_url ~context: (f "GitLab CI pipeline (%s)" - (pr_from_branch pipeline_info.branch |> snd)) + (pr_from_branch pipeline_info.common_info.branch |> snd)) ~description ~bot_info | INSTALL_TOKEN _t -> ( let owner, repo = @@ -402,17 +406,17 @@ let pipeline_action ~bot_info pipeline_info ~gitlab_mapping : unit Lwt.t = GitHub_mutations.create_check_run ~bot_info ~name: (f "GitLab CI pipeline (%s)" - (pr_from_branch pipeline_info.branch |> snd)) - ~repo_id ~head_sha:pipeline_info.commit ~status:QUEUED - ~title:"Pipeline is pending on GitLab CI" + (pr_from_branch pipeline_info.common_info.branch |> snd)) + ~repo_id ~head_sha:pipeline_info.common_info.commit + ~status:QUEUED ~title:"Pipeline is pending on GitLab CI" ~details_url:pipeline_url ~summary:"" ~external_id () | "running" -> GitHub_mutations.create_check_run ~bot_info ~name: (f "GitLab CI pipeline (%s)" - (pr_from_branch pipeline_info.branch |> snd)) - ~repo_id ~head_sha:pipeline_info.commit ~status:IN_PROGRESS - ~title:"Pipeline is running on GitLab CI" + (pr_from_branch pipeline_info.common_info.branch |> snd)) + ~repo_id ~head_sha:pipeline_info.common_info.commit + ~status:IN_PROGRESS ~title:"Pipeline is running on GitLab CI" ~details_url:pipeline_url ~summary:"" ~external_id () | _ -> let conclusion, title = @@ -429,10 +433,10 @@ let pipeline_action ~bot_info pipeline_info ~gitlab_mapping : unit Lwt.t = GitHub_mutations.create_check_run ~bot_info ~name: (f "GitLab CI pipeline (%s)" - (pr_from_branch pipeline_info.branch |> snd)) - ~repo_id ~head_sha:pipeline_info.commit ~status:COMPLETED - ~conclusion ~title ~details_url:pipeline_url ~summary:"" - ~external_id () ) + (pr_from_branch pipeline_info.common_info.branch |> snd)) + ~repo_id ~head_sha:pipeline_info.common_info.commit + ~status:COMPLETED ~conclusion ~title ~details_url:pipeline_url + ~summary:"" ~external_id () ) | Error e -> Lwt_io.printf "No repo id: %s\n" e ) ) diff --git a/src/actions.mli b/src/actions.mli index 59e3e64a..bb3b7780 100644 --- a/src/actions.mli +++ b/src/actions.mli @@ -1,70 +1,63 @@ +open Bot_components + val job_action : - bot_info:Bot_components.Bot_info.t - -> Bot_components.GitLab_types.job_info + bot_info:Bot_info.t + -> GitLab_types.ci_common_info GitLab_types.job_info -> gitlab_mapping:(string, string) Base.Hashtbl.t -> unit Lwt.t val pipeline_action : - bot_info:Bot_components.Bot_info.t - -> Bot_components.GitLab_types.pipeline_info + bot_info:Bot_info.t + -> GitLab_types.pipeline_info -> gitlab_mapping:(string, string) Base.Hashtbl.t -> unit Lwt.t val coq_bug_minimizer_results_action : - bot_info:Bot_components.Bot_info.t - -> coq_minimizer_repo_token:Bot_components.Bot_info.github_token + bot_info:Bot_info.t + -> coq_minimizer_repo_token:Bot_info.github_token -> key:Mirage_crypto_pk.Rsa.priv -> app_id:int -> string -> (Cohttp.Response.t * Cohttp_lwt__Body.t) Lwt.t val merge_pull_request_action : - bot_info:Bot_components.Bot_info.t - -> ?t:float - -> Bot_components.GitHub_types.comment_info - -> unit Lwt.t + bot_info:Bot_info.t -> ?t:float -> GitHub_types.comment_info -> unit Lwt.t val run_ci_action : - bot_info:Bot_components.Bot_info.t - -> comment_info:Bot_components.GitHub_types.comment_info + bot_info:Bot_info.t + -> comment_info:GitHub_types.comment_info -> gitlab_mapping:(string, string) Base.Hashtbl.t -> github_mapping:(string, string) Base.Hashtbl.t -> signed:bool -> (Cohttp.Response.t * Cohttp_lwt__Body.t) Lwt.t val pull_request_closed_action : - bot_info:Bot_components.Bot_info.t - -> Bot_components.GitHub_types.issue_info - Bot_components.GitHub_types.pull_request_info + bot_info:Bot_info.t + -> GitHub_types.issue_info GitHub_types.pull_request_info -> gitlab_mapping:(string, string) Base.Hashtbl.t -> github_mapping:(string, string) Base.Hashtbl.t -> unit Lwt.t val pull_request_updated_action : - bot_info:Bot_components.Bot_info.t - -> action:Bot_components.GitHub_types.pull_request_action - -> pr_info: - Bot_components.GitHub_types.issue_info - Bot_components.GitHub_types.pull_request_info + bot_info:Bot_info.t + -> action:GitHub_types.pull_request_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 -> signed:bool -> (Cohttp.Response.t * Cohttp_lwt__.Body.t) Lwt.t val adjust_milestone : - bot_info:Bot_components.Bot_info.t - -> issue:Bot_components.GitHub_types.issue + bot_info:Bot_info.t + -> issue:GitHub_types.issue -> sleep_time:float -> unit Lwt.t val project_action : - bot_info:Bot_components.Bot_info.t - -> issue:Bot_components.GitHub_types.issue - -> column_id:int - -> unit Lwt.t + bot_info:Bot_info.t -> issue:GitHub_types.issue -> column_id:int -> unit Lwt.t val push_action : - bot_info:Bot_components.Bot_info.t + bot_info:Bot_info.t -> base_ref:string -> commits_msg:string list -> unit Lwt.t diff --git a/src/bot.ml b/src/bot.ml index df7c6126..3083b269 100644 --- a/src/bot.ml +++ b/src/bot.ml @@ -56,7 +56,8 @@ let callback _conn req body = | Ok (_, JobEvent job_info) -> (fun () -> let gh_owner, gh_repo = - github_repo_of_gitlab_url ~gitlab_mapping job_info.repo_url + github_repo_of_gitlab_url ~gitlab_mapping + job_info.common_info.repo_url in action_as_github_app ~bot_info ~key ~app_id ~owner:gh_owner ~repo:gh_repo