Skip to content

Commit

Permalink
Partially switch from ppx_graphql to graphql_ppx_re.
Browse files Browse the repository at this point in the history 
Dependency graphql_ppx_re is vendored as a git submodule.

We keep using ppx_graphql for the only query that graphql_ppx_re does
not support because of unions.

To compile, run:

GRAPHQL_PPX_SCHEMA=$(pwd)/bot-components/schema.json dune build
  • Loading branch information
@Zimmi48
Zimmi48 committed Nov 1, 2019
1 parent cf553f4 commit 8a2f209
Show file tree
Hide file tree
Showing 9 changed files with 244 additions and 209 deletions.
3 changes: 3 additions & 0 deletions .gitmodules
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,3 +4,6 @@
[submodule "vendor/ocaml-graphql-server"]
path = vendor/ocaml-graphql-server
url = [email protected]:andreas/ocaml-graphql-server
[submodule "vendor/graphql_ppx_re"]
path = vendor/graphql_ppx_re
url = https://github.com/baransu/graphql_ppx_re
1 change: 1 addition & 0 deletions bot-components/.gitignore
View file
Original file line number Diff line number Diff line change
@@ -1,2 +1,3 @@
# file containing secrets
.github-token
.graphql_ppx_cache/
8 changes: 4 additions & 4 deletions bot-components/GitHub_mutations.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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)
Expand All @@ -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 -> (
Expand Down
273 changes: 100 additions & 173 deletions bot-components/GitHub_queries.ml
View file
Original file line number Diff line number Diff line change
@@ -1,32 +1,82 @@
(* 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
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
Expand Down Expand Up @@ -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\
Expand All @@ -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 =
Expand Down Expand Up @@ -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
Expand All @@ -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 =
Expand All @@ -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)
Loading

0 comments on commit 8a2f209

Please sign in to comment.