Merge pull request haskell-github#72 from nataren/implement_update_pull_request

jwiegley · jwiegley · commit b402a3f26ff8 · 2014-08-12T11:44:34.000-05:00
Implement updating a pull request.
diff --git a/Github/Data.hs b/Github/Data.hs
@@ -353,6 +353,16 @@ instance FromJSON PullRequest where
         <*> o .: "id"
   parseJSON _ = fail "Could not build a PullRequest"
 
+instance ToJSON EditPullRequestState where
+  toJSON (EditPullRequestStateOpen) = String "open"
+  toJSON (EditPullRequestStateClosed) = String "closed"
+
+instance ToJSON EditPullRequest where
+  toJSON (EditPullRequest t b s) =
+    object $ filter notNull [ "title" .= t, "body" .= b, "state" .= s ]
+    where notNull (_, Null) = False
+          notNull (_, _) = True
+
 instance FromJSON DetailedPullRequest where
   parseJSON (Object o) =
       DetailedPullRequest
diff --git a/Github/Data/Definitions.hs b/Github/Data/Definitions.hs
@@ -356,6 +356,12 @@ data DetailedPullRequest = DetailedPullRequest {
   ,detailedPullRequestMergeable :: Maybe Bool
 } deriving (Show, Data, Typeable, Eq, Ord)
 
+data EditPullRequest = EditPullRequest {
+   editPullRequestTitle :: Maybe String
+  ,editPullRequestBody :: Maybe String
+  ,editPullRequestState :: Maybe EditPullRequestState
+} deriving (Show)
+
 data PullRequestLinks = PullRequestLinks {
    pullRequestLinksReviewComments :: String
   ,pullRequestLinksComments :: String
@@ -543,3 +549,8 @@ data PingEvent = PingEvent {
   ,pingEventHook :: RepoWebhook
   ,pingEventHookId :: Int
 } deriving (Show, Data, Typeable, Eq, Ord)
+
+data EditPullRequestState =
+    EditPullRequestStateOpen
+  | EditPullRequestStateClosed
+  deriving Show
diff --git a/Github/PullRequests.hs b/Github/PullRequests.hs
@@ -12,6 +12,7 @@ module Github.PullRequests (
 ,pullRequestFiles
 ,isPullRequestMerged
 ,mergePullRequest
+,updatePullRequest
 ,module Github.Data
 ) where
 
@@ -93,6 +94,12 @@ mergePullRequest :: GithubAuth -> String -> String -> Int -> Maybe String -> IO(
 mergePullRequest auth reqRepoOwner reqRepoName reqPullRequestNumber commitMessage =
   doHttpsStatus "PUT" (buildUrl ["repos", reqRepoOwner, reqRepoName, "pulls", (show reqPullRequestNumber), "merge"]) auth (Just . RequestBodyLBS . encode . toJSON $ (buildCommitMessageMap commitMessage))
 
+-- | 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
+
+
 buildCommitMessageMap :: Maybe String -> M.Map String String
 buildCommitMessageMap (Just commitMessage) = M.singleton "commit_message" commitMessage
 buildCommitMessageMap _ = M.empty
diff --git a/samples/Pulls/UpdatePull.hs b/samples/Pulls/UpdatePull.hs
@@ -0,0 +1,11 @@
+module MergePullRequest where
+
+import qualified Github.PullRequests as Github
+import Github.Auth
+
+main :: IO ()
+main = do
+  mergeResult  <- Github.updatePullRequest (GithubOAuth "authtoken") "repoOwner" "repoName" 22 (EditPullRequest { editPullRequestTitle = Just "Brand new title", editPullRequestBody = Nothing, editPullRequestState = Just EditPullRequestStateClosed })
+  case mergeResult of
+       (Left err) -> putStrLn $ "Error: " ++ (show err)
+       (Right dpr) -> putStrLn . show $ dpr
