From 139bcdba1756a8d20d221f0c1bc21b9355fc314d Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 5 Jan 2016 21:36:50 +0200 Subject: [PATCH] Add pull request endpoints to Github.All --- Github/All.hs | 25 ++++ Github/PullRequests.hs | 190 +++++++++++++++++--------- Github/PullRequests/ReviewComments.hs | 40 ++++-- Github/Request.hs | 30 ++-- 4 files changed, 200 insertions(+), 85 deletions(-) diff --git a/Github/All.hs b/Github/All.hs index 54e66f66..8143bb7f 100644 --- a/Github/All.hs +++ b/Github/All.hs @@ -125,6 +125,29 @@ module Github.All ( deleteTeamMembershipForR, listTeamsCurrentR, + -- * Pull Requests + -- | See + pullRequestsForR, + pullRequestR, + createPullRequestR, + updatePullRequestR, + pullRequestCommitsR, + pullRequestFilesR, + isPullRequestMergedR, + mergePullRequestR, + + -- ** Review comments + -- | See + -- + -- Missing endpoints: + -- + -- * List comments in a repository + -- * Create a comment + -- * Edit a comment + -- * Delete a comment + pullRequestReviewCommentsR, + pullRequestReviewCommentR, + -- * Search -- | See -- @@ -172,6 +195,8 @@ import Github.Gists.Comments import Github.Organizations import Github.Organizations.Members import Github.Organizations.Teams +import Github.PullRequests +import Github.PullRequests.ReviewComments import Github.Search import Github.Users import Github.Users.Followers diff --git a/Github/PullRequests.hs b/Github/PullRequests.hs index b15a364b..5140a918 100644 --- a/Github/PullRequests.hs +++ b/Github/PullRequests.hs @@ -1,126 +1,194 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DataKinds #-} -- | The pull requests API as documented at -- . module Github.PullRequests ( - pullRequestsFor'' -,pullRequestsFor' -,pullRequest' -,pullRequestCommits' -,pullRequestFiles' -,pullRequestsFor -,pullRequest -,pullRequestCommits -,pullRequestFiles -,isPullRequestMerged -,mergePullRequest -,createPullRequest -,updatePullRequest -,module Github.Data -) where + pullRequestsFor'', + pullRequestsFor', + pullRequestsFor, + pullRequestsForR, + pullRequest', + pullRequest, + pullRequestR, + createPullRequest, + createPullRequestR, + updatePullRequest, + updatePullRequestR, + pullRequestCommits', + pullRequestCommits, + pullRequestCommitsR, + pullRequestFiles', + pullRequestFiles, + pullRequestFilesR, + isPullRequestMerged, + isPullRequestMergedR, + mergePullRequest, + mergePullRequestR, + module Github.Data + ) where +import Github.Auth import Github.Data -import Github.Private +import Github.Request + import Network.HTTP.Types -import qualified Data.Map as M -import Network.HTTP.Conduit (RequestBody(RequestBodyLBS)) -import Data.Aeson +import Data.Aeson.Compat (Value, encode, object, (.=)) -- | All pull requests for the repo, by owner, repo name, and pull request state. -- | With authentification -- --- > pullRequestsFor' (Just ("github-username", "github-password")) "rails" "rails" (Just "open") +-- > pullRequestsFor' (Just ("github-username", "github-password")) (Just "open") "rails" "rails" -- -- State can be one of @all@, @open@, or @closed@. Default is @open@. -- -pullRequestsFor'' :: Maybe GithubAuth -> Maybe String -> String -> String -> IO (Either Error [PullRequest]) -pullRequestsFor'' auth state userName reqRepoName = - githubGetWithQueryString' auth ["repos", userName, reqRepoName, "pulls"] $ - maybe "" ("state=" ++) state +pullRequestsFor'' :: Maybe GithubAuth -> Maybe String -> Name GithubOwner -> Name Repo -> IO (Either Error [PullRequest]) +pullRequestsFor'' auth state user repo = + executeRequestMaybe auth $ pullRequestsForR user repo state -- | All pull requests for the repo, by owner and repo name. -- | With authentification -- -- > pullRequestsFor' (Just ("github-username", "github-password")) "rails" "rails" -pullRequestsFor' :: Maybe GithubAuth -> String -> String -> IO (Either Error [PullRequest]) +pullRequestsFor' :: Maybe GithubAuth -> Name GithubOwner -> Name Repo -> IO (Either Error [PullRequest]) pullRequestsFor' auth = pullRequestsFor'' auth Nothing -- | All pull requests for the repo, by owner and repo name. -- -- > pullRequestsFor "rails" "rails" -pullRequestsFor :: String -> String -> IO (Either Error [PullRequest]) +pullRequestsFor :: Name GithubOwner -> Name Repo -> IO (Either Error [PullRequest]) pullRequestsFor = pullRequestsFor'' Nothing Nothing +-- | List pull requests. +-- See +pullRequestsForR :: Name GithubOwner -> Name Repo + -> Maybe String -- ^ State + -> GithubRequest k [PullRequest] +pullRequestsForR user repo state = + GithubGet ["repos", untagName user, untagName repo, "pulls"] $ + maybe "" ("state=" ++) state + -- | A detailed pull request, which has much more information. This takes the -- repo owner and name along with the number assigned to the pull request. -- | With authentification -- -- > pullRequest' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 562 -pullRequest' :: Maybe GithubAuth -> String -> String -> Int -> IO (Either Error DetailedPullRequest) -pullRequest' auth userName reqRepoName number = - githubGet' auth ["repos", userName, reqRepoName, "pulls", show number] +pullRequest' :: Maybe GithubAuth -> Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> IO (Either Error DetailedPullRequest) +pullRequest' auth user repo prid = + executeRequestMaybe auth $ pullRequestR user repo prid -- | A detailed pull request, which has much more information. This takes the -- repo owner and name along with the number assigned to the pull request. -- -- > pullRequest "thoughtbot" "paperclip" 562 -pullRequest :: String -> String -> Int -> IO (Either Error DetailedPullRequest) +pullRequest :: Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> IO (Either Error DetailedPullRequest) pullRequest = pullRequest' Nothing +-- | Get a single pull request. +-- See +pullRequestR :: Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> GithubRequest k DetailedPullRequest +pullRequestR user repo prid = + GithubGet ["repos", untagName user, untagName repo, "pulls", show $ untagId prid] "" + +createPullRequest :: GithubAuth + -> Name GithubOwner + -> Name Repo + -> CreatePullRequest + -> IO (Either Error DetailedPullRequest) +createPullRequest auth user repo cpr = + executeRequest auth $ createPullRequestR user repo cpr + +-- | Create a pull request. +-- See +createPullRequestR :: Name GithubOwner + -> Name Repo + -> CreatePullRequest + -> GithubRequest 'True DetailedPullRequest +createPullRequestR user repo cpr = + GithubPost Post ["repos", untagName user, untagName repo, "pulls"] (encode cpr) + +-- | Update a pull request +updatePullRequest :: GithubAuth -> Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> EditPullRequest -> IO (Either Error DetailedPullRequest) +updatePullRequest auth user repo prid epr = + executeRequest auth $ updatePullRequestR user repo prid epr + +-- | Update a pull request. +-- See +updatePullRequestR :: Name GithubOwner + -> Name Repo + -> Id DetailedPullRequest + -> EditPullRequest + -> GithubRequest 'True DetailedPullRequest +updatePullRequestR user repo prid epr = + GithubPost Patch ["repos", untagName user, untagName repo, "pulls", show $ untagId prid] (encode epr) + -- | All the commits on a pull request, given the repo owner, repo name, and -- the number of the pull request. -- | With authentification -- -- > pullRequestCommits' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 688 -pullRequestCommits' :: Maybe GithubAuth -> String -> String -> Int -> IO (Either Error [Commit]) -pullRequestCommits' auth userName reqRepoName number = - githubGet' auth ["repos", userName, reqRepoName, "pulls", show number, "commits"] - +pullRequestCommits' :: Maybe GithubAuth -> Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> IO (Either Error [Commit]) +pullRequestCommits' auth user repo prid = + executeRequestMaybe auth $ pullRequestCommitsR user repo prid + -- | All the commits on a pull request, given the repo owner, repo name, and -- the number of the pull request. -- -- > pullRequestCommits "thoughtbot" "paperclip" 688 -pullRequestCommits :: String -> String -> Int -> IO (Either Error [Commit]) +pullRequestCommits :: Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> IO (Either Error [Commit]) pullRequestCommits = pullRequestCommits' Nothing +-- | List commits on a pull request. +-- See +pullRequestCommitsR :: Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> GithubRequest k [Commit] +pullRequestCommitsR user repo prid = + GithubGet ["repos", untagName user, untagName repo, "pulls", show $ untagId prid, "commits"] "" + -- | The individual files that a pull request patches. Takes the repo owner and -- name, plus the number assigned to the pull request. -- | With authentification -- -- > pullRequestFiles' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 688 -pullRequestFiles' :: Maybe GithubAuth -> String -> String -> Int -> IO (Either Error [File]) -pullRequestFiles' auth userName reqRepoName number = - githubGet' auth ["repos", userName, reqRepoName, "pulls", show number, "files"] +pullRequestFiles' :: Maybe GithubAuth -> Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> IO (Either Error [File]) +pullRequestFiles' auth user repo prid = + executeRequestMaybe auth $ pullRequestFilesR user repo prid + -- | The individual files that a pull request patches. Takes the repo owner and -- name, plus the number assigned to the pull request. -- -- > pullRequestFiles "thoughtbot" "paperclip" 688 -pullRequestFiles :: String -> String -> Int -> IO (Either Error [File]) +pullRequestFiles :: Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> IO (Either Error [File]) pullRequestFiles = pullRequestFiles' Nothing +-- | List pull requests files. +-- See +pullRequestFilesR :: Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> GithubRequest k [File] +pullRequestFilesR user repo prid = + GithubGet ["repos", untagName user, untagName repo, "pulls", show $ untagId prid, "files"] "" + -- | Check if pull request has been merged -isPullRequestMerged :: GithubAuth -> String -> String -> Int -> IO(Either Error Status) -isPullRequestMerged auth reqRepoOwner reqRepoName reqPullRequestNumber = - doHttpsStatus "GET" (buildPath ["repos", reqRepoOwner, reqRepoName, "pulls", (show reqPullRequestNumber), "merge"]) auth Nothing +isPullRequestMerged :: GithubAuth -> Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> IO (Either Error Status) +isPullRequestMerged auth user repo prid = + executeRequest auth $ isPullRequestMergedR user repo prid --- | Merge a pull request -mergePullRequest :: GithubAuth -> String -> String -> Int -> Maybe String -> IO(Either Error Status) -mergePullRequest auth reqRepoOwner reqRepoName reqPullRequestNumber commitMessage = - doHttpsStatus "PUT" (buildPath ["repos", reqRepoOwner, reqRepoName, "pulls", (show reqPullRequestNumber), "merge"]) auth (Just . RequestBodyLBS . encode . toJSON $ (buildCommitMessageMap commitMessage)) +-- | Get if a pull request has been merged. +-- See +isPullRequestMergedR :: Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> GithubRequest k Status +isPullRequestMergedR user repo prid = GithubStatus $ + GithubGet ["repos", untagName user, untagName repo, "pulls", show $ untagId prid, "merge"] "" --- | Update a pull request -updatePullRequest :: GithubAuth -> String -> String -> Int -> EditPullRequest -> IO (Either Error DetailedPullRequest) -updatePullRequest auth reqRepoOwner reqRepoName reqPullRequestNumber editPullRequest = - githubPatch auth ["repos", reqRepoOwner, reqRepoName, "pulls", show reqPullRequestNumber] editPullRequest +-- | Merge a pull request. +mergePullRequest :: GithubAuth -> Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> Maybe String -> IO (Either Error Status) +mergePullRequest auth user repo prid commitMessage = + executeRequest auth $ mergePullRequestR user repo prid commitMessage +-- | Merge a pull request (Merge Button) +-- https://developer.github.com/v3/pulls/#merge-a-pull-request-merge-button +mergePullRequestR :: Name GithubOwner -> Name Repo -> Id DetailedPullRequest -> Maybe String -> GithubRequest 'True Status +mergePullRequestR user repo prid commitMessage = GithubStatus $ + GithubPost Put paths (encode $ buildCommitMessageMap commitMessage) + where + paths = ["repos", untagName user, untagName repo, "pulls", show $ untagId prid, "merge"] -buildCommitMessageMap :: Maybe String -> M.Map String String -buildCommitMessageMap (Just commitMessage) = M.singleton "commit_message" commitMessage -buildCommitMessageMap _ = M.empty + buildCommitMessageMap :: Maybe String -> Value + buildCommitMessageMap (Just msg) = object ["commit_message" .= msg ] + buildCommitMessageMap Nothing = object [] -createPullRequest :: GithubAuth - -> String - -> String - -> CreatePullRequest - -> IO (Either Error DetailedPullRequest) -createPullRequest auth reqUserName reqRepoName createPR = - githubPost auth ["repos", reqUserName, reqRepoName, "pulls"] createPR diff --git a/Github/PullRequests/ReviewComments.hs b/Github/PullRequests/ReviewComments.hs index cd7de72f..d33b7c24 100644 --- a/Github/PullRequests/ReviewComments.hs +++ b/Github/PullRequests/ReviewComments.hs @@ -1,24 +1,38 @@ -- | The pull request review comments API as described at -- . module Github.PullRequests.ReviewComments ( - pullRequestReviewComments -,pullRequestReviewComment -,module Github.Data -) where + pullRequestReviewComments, + pullRequestReviewCommentsR, + pullRequestReviewComment, + pullRequestReviewCommentR, + module Github.Data, + ) where import Github.Data -import Github.Private +import Github.Request -- | All the comments on a pull request with the given ID. -- --- > pullRequestReviewComments "thoughtbot" "factory_girl" 256 -pullRequestReviewComments :: String -> String -> Int -> IO (Either Error [Comment]) -pullRequestReviewComments userName repo number = - githubGet ["repos", userName, repo, "pulls", show number, "comments"] +-- > pullRequestReviewComments "thoughtbot" "factory_girl" (Id 256) +pullRequestReviewComments :: Name GithubOwner -> Name Repo -> Id PullRequest -> IO (Either Error [Comment]) +pullRequestReviewComments user repo prid = + executeRequest' $ pullRequestReviewCommentsR user repo prid + +-- | List comments on a pull request. +-- See +pullRequestReviewCommentsR :: Name GithubOwner -> Name Repo -> Id PullRequest -> GithubRequest k [Comment] +pullRequestReviewCommentsR user repo prid = + GithubGet ["repos", untagName user, untagName repo, "pulls", show $ untagId prid, "comments"] "" -- | One comment on a pull request, by the comment's ID. -- --- > pullRequestReviewComment "thoughtbot" "factory_girl" 301819 -pullRequestReviewComment :: String -> String -> Int -> IO (Either Error Comment) -pullRequestReviewComment userName repo ident = - githubGet ["repos", userName, repo, "pulls", "comments", show ident] +-- > pullRequestReviewComment "thoughtbot" "factory_girl" (Id 301819) +pullRequestReviewComment :: Name GithubOwner -> Name Repo -> Id Comment -> IO (Either Error Comment) +pullRequestReviewComment user repo cid = + executeRequest' $ pullRequestReviewCommentR user repo cid + +-- | Get a single comment. +-- See +pullRequestReviewCommentR :: Name GithubOwner -> Name Repo -> Id Comment -> GithubRequest k Comment +pullRequestReviewCommentR user repo cid = + GithubGet ["repos", untagName user, untagName repo, "pulls", "comments", show $ untagId cid] "" diff --git a/Github/Request.hs b/Github/Request.hs index f01b2ed4..0723625c 100644 --- a/Github/Request.hs +++ b/Github/Request.hs @@ -28,6 +28,7 @@ import Data.Aeson.Compat (FromJSON) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Network.HTTP.Conduit (Manager, httpLbs, newManager, tlsManagerSettings) +import Network.HTTP.Types (Status) import qualified Data.ByteString.Lazy as LBS import qualified Network.HTTP.Types.Method as Method @@ -66,13 +67,13 @@ toMethod Put = Method.methodPut -- -- TODO: Add constructor for collection fetches. data GithubRequest (k :: Bool) a where - GithubGet :: Paths -> QueryString -> GithubRequest k a - GithubPost :: PostMethod -> Paths -> LBS.ByteString -> GithubRequest 'True a + GithubGet :: FromJSON a => Paths -> QueryString -> GithubRequest k a + GithubPost :: FromJSON a => PostMethod -> Paths -> LBS.ByteString -> GithubRequest 'True a GithubDelete :: Paths -> GithubRequest 'True () + GithubStatus :: GithubRequest k () -> GithubRequest k Status deriving (Typeable) deriving instance Eq (GithubRequest k a) -deriving instance Ord (GithubRequest k a) instance Show (GithubRequest k a) where showsPrec d r = @@ -92,6 +93,9 @@ instance Show (GithubRequest k a) where GithubDelete ps -> showParen (d > appPrec) $ showString "GithubDelete " . showsPrec (appPrec + 1) ps + GithubStatus req -> showParen (d > appPrec) $ + showString "GithubStatus " + . showsPrec (appPrec + 1) req where appPrec = 10 :: Int ------------------------------------------------------------------------------ @@ -99,7 +103,7 @@ instance Show (GithubRequest k a) where ------------------------------------------------------------------------------ -- | Execute 'GithubRequest' in 'IO' -executeRequest :: (FromJSON a, Show a) +executeRequest :: Show a => GithubAuth -> GithubRequest k a -> IO (Either Error a) executeRequest auth req = do manager <- newManager tlsManagerSettings @@ -110,7 +114,7 @@ executeRequest auth req = do pure x -- | Like 'executeRequest' but with provided 'Manager'. -executeRequestWithMgr :: (FromJSON a, Show a) +executeRequestWithMgr :: Show a => Manager -> GithubAuth -> GithubRequest k a @@ -135,11 +139,13 @@ executeRequestWithMgr mgr auth req = Private.githubAPIDelete' getResponse auth (Private.buildPath paths) + GithubStatus _req' -> + error "executeRequestWithMgr GithubStatus not implemented" where getResponse = flip httpLbs mgr -- | Like 'executeRequest' but without authentication. -executeRequest' :: (FromJSON a, Show a) +executeRequest' :: Show a => GithubRequest 'False a -> IO (Either Error a) executeRequest' req = do manager <- newManager tlsManagerSettings @@ -150,10 +156,10 @@ executeRequest' req = do pure x -- | Like 'executeRequestWithMgr' but without authentication. -executeRequestWithMgr' :: (FromJSON a, Show a) - => Manager - -> GithubRequest 'False a - -> IO (Either Error a) +executeRequestWithMgr' :: Show a + => Manager + -> GithubRequest 'False a + -> IO (Either Error a) executeRequestWithMgr' mgr req = case req of GithubGet paths qs -> @@ -164,13 +170,15 @@ executeRequestWithMgr' mgr req = Nothing where qs' | null qs = "" | otherwise = '?' : qs + GithubStatus (GithubGet _paths _qs) -> + error "executeRequestWithMgr' GithubStatus not implemented" where getResponse = flip httpLbs mgr -- | Helper for picking between 'executeRequest' and 'executeRequest''. -- -- The use is discouraged. -executeRequestMaybe :: (FromJSON a, Show a) +executeRequestMaybe :: Show a => Maybe GithubAuth -> GithubRequest 'False a -> IO (Either Error a) executeRequestMaybe = maybe executeRequest' executeRequest