diff --git a/.gitmodules b/.gitmodules index b836c580..d7906cbf 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,6 @@ [submodule "vendor/ocaml-graphql-server"] path = vendor/ocaml-graphql-server url = git@github.com:andreas/ocaml-graphql-server +[submodule "vendor/graphql_ppx_re"] + path = vendor/graphql_ppx_re + url = https://github.com/baransu/graphql_ppx_re diff --git a/bot-components/.gitignore b/bot-components/.gitignore index 5733865d..4b3c28d5 100644 --- a/bot-components/.gitignore +++ b/bot-components/.gitignore @@ -1,2 +1,3 @@ # file containing secrets .github-token +.graphql_ppx_cache/ diff --git a/bot-components/GitHub_mutations.ml b/bot-components/GitHub_mutations.ml index 68340938..51783c45 100644 --- a/bot-components/GitHub_mutations.ml +++ b/bot-components/GitHub_mutations.ml @@ -14,7 +14,7 @@ let mv_card_to_column ~token let variables = [("card_id", `String card_id); ("column_id", `String column_id)] in - GitHub_queries.graphql_query ~token mutation variables + GitHub_queries.untyped_graphql_query ~token mutation variables >|= function | Ok _ -> () | Error err -> print_endline (f "Error while moving project card: %s" err) @@ -28,7 +28,7 @@ let post_comment ~token ~id ~message = \ }" in let variables = [("id", `String id); ("message", `String message)] in - GitHub_queries.graphql_query ~token mutation variables + GitHub_queries.untyped_graphql_query ~token mutation variables >|= function | Ok _ -> () | Error err -> print_endline (f "Error while posting comment: %s" err) @@ -44,13 +44,13 @@ let update_milestone ~token ~issue ~milestone = let variables = [("issue", `String issue); ("milestone", `String milestone)] in - GitHub_queries.graphql_query ~token mutation variables + GitHub_queries.untyped_graphql_query ~token mutation variables >|= function | Ok _ -> () | Error err -> print_endline (f "Error while updating milestone: %s" err) let reflect_pull_request_milestone ~token - (issue_closer_info : GitHub_queries.issue_closer_info) = + (issue_closer_info : GitHub_queries_bis.issue_closer_info) = match issue_closer_info.closer.milestone_id with | None -> Lwt_io.printf "PR closed without a milestone: doing nothing.\n" | Some milestone -> ( diff --git a/bot-components/GitHub_queries.ml b/bot-components/GitHub_queries.ml index da9473ec..b62fd7de 100644 --- a/bot-components/GitHub_queries.ml +++ b/bot-components/GitHub_queries.ml @@ -1,3 +1,52 @@ +(* Define GraphQL queries before opening Base *) + +module PullRequest_ID_and_Milestone = +[%graphql +{| + query prInfo($owner: String!, $repo: String!, $number: Int!) { + repository(owner: $owner,name: $repo) { + pullRequest(number: $number) { + id + databaseId + milestone { + title + description + } + } + } + } +|}] + +module TeamMembership = +[%graphql +{| + query teamMember($org: String!, $team: String!, $user: String!) { + organization(login:$org) { + team(slug:$team) { + members(query:$user, first:1) { + nodes { login } + } + } + } + } +|}] + +module PullRequest_Refs = +[%graphql +{| + query pull_request_info($owner: String!, $repo: String!, $number: Int!) { + repository(owner: $owner, name:$repo) { + pullRequest(number: $number) { + baseRefName + baseRefOid @bsDecoder(fn: "Yojson.Basic.to_string") + headRefName + headRefOid @bsDecoder(fn: "Yojson.Basic.to_string") + merged + } + } + } +|}] + open Base open Cohttp open Cohttp_lwt @@ -5,28 +54,29 @@ open Cohttp_lwt_unix open Lwt open Utils -let executable_query (query, kvariables, parse) ~token = - kvariables (fun variables -> - let uri = Uri.of_string "https://api.github.com/graphql" in - let headers = - Cohttp.Header.of_list - [("Authorization", "bearer " ^ token); ("User-Agent", "coqbot")] - in - let body = `Assoc [("query", `String query); ("variables", variables)] in - let serialized_body = Yojson.Basic.to_string body in - Cohttp_lwt_unix.Client.post ~headers ~body:(`String serialized_body) uri - >>= fun (rsp, body) -> - Cohttp_lwt.Body.to_string body - >|= fun body' -> - match Cohttp.Code.(code_of_status rsp.status |> is_success) with - | false -> Error body' - | true -> ( - try Ok (Yojson.Basic.from_string body' |> parse) 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 graphql_query ~token query variables = +let send_graphql_query ~token query = + let uri = Uri.of_string "https://api.github.com/graphql" in + let headers = + Cohttp.Header.of_list + [("Authorization", "bearer " ^ token); ("User-Agent", "coqbot")] + in + let body = + `Assoc [("query", `String query#query); ("variables", query#variables)] + in + let serialized_body = Yojson.Basic.to_string body in + Cohttp_lwt_unix.Client.post ~headers ~body:(`String serialized_body) uri + >>= fun (rsp, body) -> + Cohttp_lwt.Body.to_string body + >|= fun body' -> + match Cohttp.Code.(code_of_status rsp.status |> is_success) with + | false -> Error body' + | true -> ( + try Ok (Yojson.Basic.from_string body' |> query#parse) 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 untyped_graphql_query ~token query variables = let body = `Assoc [("query", `String query); ("variables", `Assoc variables)] |> Yojson.pretty_to_string |> Body.of_string @@ -133,26 +183,6 @@ module ProjectCard = struct |> List.map ~f:ProjectColumn.from_json } end -(* Queries *) - -let pull_request_id_db_id_and_milestone = - executable_query - [%graphql - {| - query prInfo($owner: String!, $repo: String!, $number: Int!) { - repository(owner: $owner,name: $repo) { - pullRequest(number: $number) { - id - databaseId - milestone { - title - description - } - } - } - } - |}] - let pull_request_base_milestone_and_cards ~token owner repo number = let query = "query prInfo($owner: String!, $repo: String!, $number: Int!) {\n\ @@ -169,7 +199,7 @@ let pull_request_base_milestone_and_cards ~token owner repo number = let variables = [("owner", `String owner); ("repo", `String repo); ("number", `Int number)] in - graphql_query ~token query variables + untyped_graphql_query ~token query variables >|= function | Ok json -> let pr_json = @@ -210,115 +240,27 @@ let backported_pr_info ~token number base_ref = Stdio.printf "Error in backported_pr_info: %s\n" err ; None -let issue_milestone_query = - executable_query - [%graphql - {| - query issueMilestone($owner: String!, $repo: String!, $number: Int!) { - repository(owner:$owner, name:$repo) { - issue(number:$number) { - id - milestone { id } - timelineItems(itemTypes:[CLOSED_EVENT],last:1) { - nodes { - __typename - ... on ClosedEvent { - closer { - __typename - ... on PullRequest { - id - milestone { id } - } - ... on Commit { - associatedPullRequests(first: 2) { - nodes { - id - milestone { id } - } - } - } - } - } - } - } - } - } - } - |}] - -type closer_info = {pull_request_id: string; milestone_id: string option} - -let closer_info_of_pr pr = - { milestone_id= pr#milestone |> Option.map ~f:(fun milestone -> milestone#id) - ; pull_request_id= pr#id } - -type 'a closed_by = - | ClosedByPullRequest of 'a - | ClosedByCommit - (* Only used when commit is not associated to a PR *) - | ClosedByOther - -let closer_info_option_of_closer closer = - match closer with - | None -> Ok ClosedByOther - | Some (`PullRequest pr) -> Ok (ClosedByPullRequest (closer_info_of_pr pr)) - | Some (`Commit commit) -> ( - match commit#associatedPullRequests with - | None -> Ok ClosedByCommit - | Some prs -> ( - match prs#nodes with - | Some [] -> Ok ClosedByCommit - | Some [Some pr] -> Ok (ClosedByPullRequest (closer_info_of_pr pr)) - | Some (_ :: _) -> - Error "Closing commit associated to several pull requests." - | _ -> Error "Closer query response is not well-formed." ) ) - -type issue_closer_info = - {issue_id: string; milestone_id: string option; closer: closer_info} - -let issue_closer_info_of_resp ~owner ~repo ~number resp = - match resp#repository with - | None -> Error (f "Unknown repository %s/%s." owner repo) - | Some repository -> ( - match repository#issue with - | None -> Error (f "Unknown issue %s/%s#%d." owner repo number) - | Some issue -> ( - match (issue#timelineItems)#nodes with - | Some [Some (`ClosedEvent event)] -> - event#closer |> closer_info_option_of_closer - |> Result.map ~f:(function - | ClosedByPullRequest closer_info -> - ClosedByPullRequest - { issue_id= issue#id - ; milestone_id= - issue#milestone - |> Option.map ~f:(fun milestone -> milestone#id) - ; closer= closer_info } - | (ClosedByCommit | ClosedByOther) as reason -> reason ) - | _ -> Error (f "No close event for issue %s/%s#%d." owner repo number) ) - ) - -let get_issue_closer_info ~token - ({owner; repo; number} : GitHub_subscriptions.issue) = - issue_milestone_query ~token ~owner ~repo ~number () - >|= Result.map_error ~f:(fun err -> - f "Query issue_milestone failed with %s" err ) - >|= Result.bind ~f:(issue_closer_info_of_resp ~owner ~repo ~number) - -let get_team_membership_query = - executable_query - [%graphql - {| - query teamMember($org: String!, $team: String!, $user: String!) { - organization(login:$org) { - team(slug:$team) { - members(query:$user, first:1) { - nodes { login } - } - } - } - } - |}] +let get_pull_request_id_and_milestone ~token ~owner ~repo ~number = + PullRequest_ID_and_Milestone.make ~owner ~repo ~number () + |> send_graphql_query ~token + >|= function + | Ok result -> ( + match result#repository with + | Some repo -> ( + match repo#pullRequest with + | Some pr -> ( + match (pr#databaseId, pr#milestone) with + | Some db_id, Some milestone -> ( + match milestone#description with + | Some description -> ( + match Milestone.get_backport_info "coqbot" description with + | Some bp_info -> Some (pr#id, db_id, bp_info) + | _ -> None ) + | _ -> None ) + | _ -> None ) + | _ -> None ) + | _ -> None ) + | _ -> None let team_membership_of_resp ~org ~team ~user resp = match resp#organization with @@ -330,35 +272,19 @@ let team_membership_of_resp ~org ~team ~user resp = match (resp#members)#nodes with | Some members when members - |> List.exists ~f:(function + |> Array.exists ~f:(function | Some member when String.equal member#login user -> true | _ -> false ) -> Ok true | _ -> Ok false ) ) let get_team_membership ~token ~org ~team ~user = - get_team_membership_query ~token ~org ~team ~user () + TeamMembership.make ~org ~team ~user () + |> send_graphql_query ~token >|= Result.map_error ~f:(fun err -> f "Query get_team_membership failed with %s" err ) >|= Result.bind ~f:(team_membership_of_resp ~org ~team ~user) -let pull_request_info_query = - executable_query - [%graphql - {| - query pull_request_info($owner: String!, $repo: String!, $number: Int!) { - repository(owner: $owner, name:$repo) { - pullRequest(number: $number) { - baseRefName - baseRefOid - headRefName - headRefOid - merged - } - } - } - |}] - let pull_request_info_of_resp ({issue= {owner; repo; number}} as issue : GitHub_subscriptions.issue_info) resp : (GitHub_subscriptions.pull_request_info, string) Result.t = @@ -379,10 +305,11 @@ let pull_request_info_of_resp ; sha= pull_request#headRefOid } ; merged= pull_request#merged } ) -let get_pull_request_info ~token +let get_pull_request_refs ~token ({issue= {owner; repo; number}} as issue : GitHub_subscriptions.issue_info) = - pull_request_info_query ~token ~owner ~repo ~number () + PullRequest_Refs.make ~owner ~repo ~number () + |> send_graphql_query ~token >|= Result.map_error ~f:(fun err -> f "Query pull_request_info failed with %s" err ) >|= Result.bind ~f:(pull_request_info_of_resp issue) diff --git a/bot-components/GitHub_queries_bis.ml b/bot-components/GitHub_queries_bis.ml new file mode 100644 index 00000000..7dbb7062 --- /dev/null +++ b/bot-components/GitHub_queries_bis.ml @@ -0,0 +1,119 @@ +open Base +open Lwt +open Utils + +let executable_query (query, kvariables, parse) ~token = + kvariables (fun variables -> + let uri = Uri.of_string "https://api.github.com/graphql" in + let headers = + Cohttp.Header.of_list + [("Authorization", "bearer " ^ token); ("User-Agent", "coqbot")] + in + let body = `Assoc [("query", `String query); ("variables", variables)] in + let serialized_body = Yojson.Basic.to_string body in + Cohttp_lwt_unix.Client.post ~headers ~body:(`String serialized_body) uri + >>= fun (rsp, body) -> + Cohttp_lwt.Body.to_string body + >|= fun body' -> + match Cohttp.Code.(code_of_status rsp.status |> is_success) with + | false -> Error body' + | true -> ( + try Ok (Yojson.Basic.from_string body' |> parse) 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 issue_milestone_query = + executable_query + [%graphql + {| + query issueMilestone($owner: String!, $repo: String!, $number: Int!) { + repository(owner:$owner, name:$repo) { + issue(number:$number) { + id + milestone { id } + timelineItems(itemTypes:[CLOSED_EVENT],last:1) { + nodes { + __typename + ... on ClosedEvent { + closer { + __typename + ... on PullRequest { + id + milestone { id } + } + ... on Commit { + associatedPullRequests(first: 2) { + nodes { + id + milestone { id } + } + } + } + } + } + } + } + } + } + } + |}] + +type closer_info = {pull_request_id: string; milestone_id: string option} + +let closer_info_of_pr pr = + { milestone_id= pr#milestone |> Option.map ~f:(fun milestone -> milestone#id) + ; pull_request_id= pr#id } + +type 'a closed_by = + | ClosedByPullRequest of 'a + | ClosedByCommit + (* Only used when commit is not associated to a PR *) + | ClosedByOther + +let closer_info_option_of_closer closer = + match closer with + | None -> Ok ClosedByOther + | Some (`PullRequest pr) -> Ok (ClosedByPullRequest (closer_info_of_pr pr)) + | Some (`Commit commit) -> ( + match commit#associatedPullRequests with + | None -> Ok ClosedByCommit + | Some prs -> ( + match prs#nodes with + | Some [] -> Ok ClosedByCommit + | Some [Some pr] -> Ok (ClosedByPullRequest (closer_info_of_pr pr)) + | Some (_ :: _) -> + Error "Closing commit associated to several pull requests." + | _ -> Error "Closer query response is not well-formed." ) ) + +type issue_closer_info = + {issue_id: string; milestone_id: string option; closer: closer_info} + +let issue_closer_info_of_resp ~owner ~repo ~number resp = + match resp#repository with + | None -> Error (f "Unknown repository %s/%s." owner repo) + | Some repository -> ( + match repository#issue with + | None -> Error (f "Unknown issue %s/%s#%d." owner repo number) + | Some issue -> ( + match (issue#timelineItems)#nodes with + | Some [Some (`ClosedEvent event)] -> + event#closer |> closer_info_option_of_closer + |> Result.map ~f:(function + | ClosedByPullRequest closer_info -> + ClosedByPullRequest + { issue_id= issue#id + ; milestone_id= + issue#milestone + |> Option.map ~f:(fun milestone -> milestone#id) + ; closer= closer_info } + | (ClosedByCommit | ClosedByOther) as reason -> reason ) + | _ -> Error (f "No close event for issue %s/%s#%d." owner repo number) ) + ) + +let get_issue_closer_info ~token + ({owner; repo; number} : GitHub_subscriptions.issue) = + issue_milestone_query ~token ~owner ~repo ~number () + >|= Result.map_error ~f:(fun err -> + f "Query issue_milestone failed with %s" err ) + >|= Result.bind ~f:(issue_closer_info_of_resp ~owner ~repo ~number) diff --git a/bot-components/dune b/bot-components/dune index 90126b3c..c98976b2 100644 --- a/bot-components/dune +++ b/bot-components/dune @@ -3,7 +3,9 @@ (public_name bot-components) (libraries base cohttp-lwt-unix hex nocrypto stdio str yojson) (preprocess - (pps ppx_graphql)) + (per_module + ((pps graphql_ppx) GitHub_queries) + ((pps ppx_graphql) GitHub_queries_bis))) (preprocessor_deps (file schema.json))) diff --git a/bot.ml b/bot.ml index 2b7eeec4..d47c4af9 100644 --- a/bot.ml +++ b/bot.ml @@ -227,30 +227,6 @@ let generic_get relative_uri ?(header_list = []) ~default json_handler = >>= (fun (_response, body) -> Cohttp_lwt.Body.to_string body) >|= handle_json json_handler default -let get_pull_request_info pr_number = - GitHub_queries.pull_request_id_db_id_and_milestone ~token:github_access_token - ~owner:"coq" ~repo:"coq" ~number:pr_number () - >|= function - | Ok result -> ( - match result#repository with - | Some repo -> ( - match repo#pullRequest with - | Some pr -> ( - match (pr#databaseId, pr#milestone) with - | Some db_id, Some milestone -> ( - match milestone#description with - | Some description -> ( - match - GitHub_queries.Milestone.get_backport_info "coqbot" description - with - | Some bp_info -> Some (pr#id, db_id, bp_info) - | _ -> None ) - | _ -> None ) - | _ -> None ) - | _ -> None ) - | _ -> None ) - | _ -> None - let get_status_check ~repo_full_name ~commit ~context = generic_get (Printf.sprintf "repos/%s/commits/%s/statuses" repo_full_name commit) @@ -331,7 +307,8 @@ let pull_request_closed (pr_info : GitHub_subscriptions.pull_request_info) () = Lwt.return () let project_action ~(issue : GitHub_subscriptions.issue) ~column_id () = - get_pull_request_info issue.number + GitHub_queries.get_pull_request_id_and_milestone ~token:github_access_token + ~owner:"coq" ~repo:"coq" ~number:issue.number >>= function | None -> Lwt_io.printf "Could not find backporting info for PR.\n" | Some (id, _, {request_inclusion_column; rejected_milestone}) @@ -359,7 +336,8 @@ let push_action json = let pr_number = Str.matched_group 1 commit_msg |> Int.of_string in Lwt_io.printf "%s\nPR #%d was merged.\n" commit_msg pr_number >>= fun () -> - get_pull_request_info pr_number + GitHub_queries.get_pull_request_id_and_milestone + ~token:github_access_token ~owner:"coq" ~repo:"coq" ~number:pr_number >>= fun pr_info -> match pr_info with | Some @@ -723,13 +701,13 @@ let callback _conn req body = after 5, 25, and 125 seconds, if the issue was closed by a commit not yet associated to a pull request. *) let rec adjust_milestone sleep_time () = - GitHub_queries.get_issue_closer_info ~token:github_access_token + GitHub_queries_bis.get_issue_closer_info ~token:github_access_token issue >>= function - | Ok (GitHub_queries.ClosedByPullRequest result) -> + | Ok (GitHub_queries_bis.ClosedByPullRequest result) -> GitHub_mutations.reflect_pull_request_milestone ~token:github_access_token result - | Ok GitHub_queries.ClosedByCommit -> + | Ok GitHub_queries_bis.ClosedByCommit -> (* May be worth trying again later. *) if Float.(sleep_time > 200.) then Lwt_io.print @@ -741,7 +719,7 @@ let callback _conn req body = sleep_time >>= (fun () -> Lwt_unix.sleep sleep_time) >>= adjust_milestone (sleep_time *. 5.) - | Ok GitHub_queries.ClosedByOther -> + | Ok GitHub_queries_bis.ClosedByOther -> (* Not worth trying again *) Lwt_io.print "Not closed by pull request or commit." | Error err -> Lwt_io.print (f "Error: %s\n" err) @@ -788,7 +766,7 @@ let callback _conn req body = match comment_info.pull_request with | Some pr_info -> pull_request_updated pr_info () | None -> - GitHub_queries.get_pull_request_info + GitHub_queries.get_pull_request_refs ~token:github_access_token comment_info.issue >>= fun pr_info -> pull_request_updated pr_info () ) else diff --git a/default.nix b/default.nix index 169b2c41..f00eb098 100644 --- a/default.nix +++ b/default.nix @@ -29,7 +29,11 @@ stdenv.mkDerivation rec { yojson # Dependencies of vendored dependencies menhir + ocaml-migrate-parsetree ppx_metaquot + ppx_tools_versioned + reason + result rresult # Publishing heroku diff --git a/vendor/graphql_ppx_re b/vendor/graphql_ppx_re new file mode 160000 index 00000000..0344ce28 --- /dev/null +++ b/vendor/graphql_ppx_re @@ -0,0 +1 @@ +Subproject commit 0344ce28df9218ba2b9c8a8f45edfb3a8910d7ed