Feature/get pull request patch

.gitignore

@@ -13,3 +13,4 @@ cabal.sandbox.config
 run.sh
 src/hightlight.js
 src/style.css
+tags

src/GitHub/Data/Comments.hs

@@ -54,6 +54,25 @@ instance Binary NewComment
 instance ToJSON NewComment where
     toJSON (NewComment b) = object [ "body" .= b ]
 
+data NewPullComment = NewPullComment
+    { newPullCommentCommit :: !Text
+    , newPullCommentPath :: !Text
+    , newPullCommentPosition :: !Int
+    , newPullCommentBody :: !Text
+    }
+  deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance NFData NewPullComment where rnf = genericRnf
+instance Binary NewPullComment
+
+instance ToJSON NewPullComment where
+    toJSON (NewPullComment c path pos b) =
+        object [ "body" .= b
+               , "commit_id" .= c
+               , "path" .= path
+               , "position" .= pos
+               ]
+
 data EditComment = EditComment
     { editCommentBody :: !Text
     }

src/GitHub/Data/Request.hs

@@ -142,6 +142,7 @@ data Request (k :: RW) a where
     SimpleQuery   :: FromJSON a => SimpleRequest k a -> Request k a
     StatusQuery   :: StatusMap a -> SimpleRequest k () -> Request k a
     HeaderQuery   :: FromJSON a => Types.RequestHeaders -> SimpleRequest k a -> Request k a
+    RawHeaderQuery :: Types.RequestHeaders -> SimpleRequest k LBS.ByteString -> Request k LBS.ByteString
     RedirectQuery :: SimpleRequest k () -> Request k URI
   deriving (Typeable)
 
@@ -184,7 +185,27 @@ command m ps body = SimpleQuery (Command m ps body)
 deriving instance Eq a => Eq (Request k a)
 deriving instance Eq a => Eq (SimpleRequest k a)
 
-deriving instance Ord a => Ord (Request k a)
+-- deriving instance Ord a => Ord (Request k a)
+instance Ord a => Ord (Request k a) where
+    compare s1 s2 =
+        case (s1,s2) of
+            (SimpleQuery a,SimpleQuery b) -> compare a b
+            (StatusQuery a1 a2,StatusQuery b1 b2) -> compare (a1,a2) (b1,b2)
+            (HeaderQuery a1 a2, HeaderQuery b1 b2) -> compare (a1,a2) (b1,b2)
+            (RawHeaderQuery a1 a2, RawHeaderQuery b1 b2) -> compare (a1,a2) (b1,b2)
+            (RedirectQuery a, RedirectQuery b) -> compare a b
+            (SimpleQuery _ , _) -> LT
+            (StatusQuery _ _, SimpleQuery _) -> GT
+            (StatusQuery _ _, _) -> GT
+            (HeaderQuery _ _, SimpleQuery _) -> GT
+            (HeaderQuery _ _, StatusQuery _ _) -> GT
+            (HeaderQuery _ _, _) -> LT
+            (RawHeaderQuery _ _, SimpleQuery _) -> GT
+            (RawHeaderQuery _ _, StatusQuery _ _) -> GT
+            (RawHeaderQuery _ _, HeaderQuery _ _) -> GT
+            -- (RawHeaderQuery _ _, RedirectQuery _) -> LT -- This case is
+            -- derived, does not type check, in GHC 8.4.1
+            (RedirectQuery _ , _) -> GT
 deriving instance Ord a => Ord (SimpleRequest k a)
 
 instance Show (SimpleRequest k a) where
@@ -220,6 +241,10 @@ instance Show (Request k a) where
             . showsPrec (appPrec + 1) m
             . showString " "
             . showsPrec (appPrec + 1) req
+        RawHeaderQuery m req -> showString "RawHeader "
+            . showsPrec (appPrec + 1) m
+            . showString " "
+            . showsPrec (appPrec + 1) req
         RedirectQuery req -> showString "Redirect "
             . showsPrec (appPrec + 1) req
       where
@@ -253,6 +278,10 @@ instance Hashable (Request k a) where
         salt `hashWithSalt` (2 :: Int)
              `hashWithSalt` h
              `hashWithSalt` req
+    hashWithSalt salt (RawHeaderQuery h req) =
+        salt `hashWithSalt` (2 :: Int)
+             `hashWithSalt` h
+             `hashWithSalt` req
     hashWithSalt salt (RedirectQuery req) =
         salt `hashWithSalt` (3 :: Int)
              `hashWithSalt` req

src/GitHub/Endpoints/PullRequests.hs

@@ -12,6 +12,12 @@ module GitHub.Endpoints.PullRequests (
     pullRequest',
     pullRequest,
     pullRequestR,
+    pullRequestDiff',
+    pullRequestDiff,
+    pullRequestDiffR,
+    pullRequestPatch',
+    pullRequestPatch,
+    pullRequestPatchR,
     createPullRequest,
     createPullRequestR,
     updatePullRequest,
@@ -33,6 +39,7 @@ import GitHub.Data
 import GitHub.Internal.Prelude
 import GitHub.Request
 import Prelude ()
+import Data.ByteString.Lazy (ByteString)
 
 -- | All open pull requests for the repo, by owner and repo name.
 --
@@ -60,6 +67,45 @@ pullRequestsForR user repo opts = pagedQuery
     ["repos", toPathPart user, toPathPart repo, "pulls"]
     (prModToQueryString opts)
 
+-- | Obtain the diff of a pull request
+-- See <https://developer.github.com/v3/pulls/#get-a-single-pull-request>
+pullRequestDiff' :: Maybe Auth -> Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error ByteString)
+pullRequestDiff' auth user repo prid =
+    executeRequestMaybe auth $ pullRequestDiffR user repo prid
+
+-- | Obtain the diff of a pull request
+-- See <https://developer.github.com/v3/pulls/#get-a-single-pull-request>
+pullRequestDiff :: Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error ByteString)
+pullRequestDiff = pullRequestDiff' Nothing
+
+-- | Query a single pull request to obtain the diff
+-- See <https://developer.github.com/v3/pulls/#get-a-single-pull-request>
+pullRequestDiffR :: Name Owner -> Name Repo -> Id PullRequest -> Request k ByteString
+pullRequestDiffR user repo prid =
+    RawHeaderQuery
+        [("Accept", "application/vnd.github.v3.diff")]
+        (Query ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid] []) -- XXX change the accept header here
+
+-- | Obtain the patch of a pull request
+--
+-- See <https://developer.github.com/v3/pulls/#get-a-single-pull-request>
+pullRequestPatch' :: Maybe Auth -> Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error ByteString)
+pullRequestPatch' auth user repo prid =
+    executeRequestMaybe auth $ pullRequestPatchR user repo prid
+
+-- | Obtain the patch of a pull request
+-- See <https://developer.github.com/v3/pulls/#get-a-single-pull-request>
+pullRequestPatch :: Name Owner -> Name Repo -> Id PullRequest -> IO (Either Error ByteString)
+pullRequestPatch = pullRequestPatch' Nothing
+
+-- | Query a single pull request to obtain the patch
+-- See <https://developer.github.com/v3/pulls/#get-a-single-pull-request>
+pullRequestPatchR :: Name Owner -> Name Repo -> Id PullRequest -> Request k ByteString
+pullRequestPatchR user repo prid =
+    RawHeaderQuery
+        [("Accept", "application/vnd.github.v3.patch")]
+        (Query ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart prid] []) -- XXX change the accept header here
+
 -- | 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.

src/GitHub/Endpoints/PullRequests/Comments.hs

@@ -10,7 +10,9 @@ module GitHub.Endpoints.PullRequests.Comments (
     pullRequestCommentsR,
     pullRequestComment,
     pullRequestCommentR,
-    module GitHub.Data,
+    createPullComment,
+    createPullCommentR,
+    module GitHub.Data
     ) where
 
 import GitHub.Data
@@ -43,3 +45,20 @@ pullRequestComment user repo cid =
 pullRequestCommentR :: Name Owner -> Name Repo -> Id Comment -> Request k Comment
 pullRequestCommentR user repo cid =
     query ["repos", toPathPart user, toPathPart repo, "pulls", "comments", toPathPart cid] []
+
+-- | Create a new comment.
+--
+-- > createPullComment (User (user, password)) user repo issue commit path position
+-- >  "some words"
+createPullComment :: Auth -> Name Owner -> Name Repo -> Id Issue -> Text -> Text -> Int -> Text
+            -> IO (Either Error Comment)
+createPullComment auth user repo iss commit path position body =
+    executeRequest auth $ createPullCommentR user repo iss commit path position body
+
+-- | Create a comment.
+-- See <https://developer.github.com/v3/pulls/comments/#create-a-comment>
+createPullCommentR :: Name Owner -> Name Repo -> Id Issue -> Text -> Text -> Int -> Text -> Request 'RW Comment
+createPullCommentR user repo iss commit path position body =
+    command Post parts (encode $ NewPullComment commit path position body)
+  where
+    parts = ["repos", toPathPart user, toPathPart repo, "pulls", toPathPart iss, "comments"]

src/GitHub/Request.hs

@@ -124,13 +124,18 @@ executeRequestWithMgr mgr auth req = runExceptT $ do
         performHttpReq' httpReq sreq
     performHttpReq httpReq (HeaderQuery _ sreq) =
         performHttpReq' httpReq sreq
+    performHttpReq httpReq (RawHeaderQuery _ sreq) =
+        performHttpReqRaw httpReq sreq
     performHttpReq httpReq (StatusQuery sm _)   = do
         res <- httpLbs' httpReq
         parseStatus sm  . responseStatus $ res
     performHttpReq httpReq (RedirectQuery _)   = do
         res <- httpLbs' httpReq
         parseRedirect (getUri httpReq) res
 
+    performHttpReqRaw :: HTTP.Request -> SimpleRequest k b -> ExceptT Error IO LBS.ByteString
+    performHttpReqRaw httpReq Query {} = responseBody <$> httpLbs' httpReq
+
     performHttpReq' :: FromJSON b => HTTP.Request -> SimpleRequest k b -> ExceptT Error IO b
     performHttpReq' httpReq Query {} = do
         res <- httpLbs' httpReq
@@ -174,13 +179,17 @@ executeRequestWithMgr' mgr req = runExceptT $ do
         performHttpReq' httpReq sreq
     performHttpReq httpReq (HeaderQuery _ sreq) =
         performHttpReq' httpReq sreq
+    performHttpReq httpReq (RawHeaderQuery _ sreq) =
+        performHttpReqRaw httpReq sreq
     performHttpReq httpReq (StatusQuery sm _)   = do
         res <- httpLbs' httpReq
         parseStatus sm  . responseStatus $ res
     performHttpReq httpReq (RedirectQuery _)   = do
         res <- httpLbs' httpReq
         parseRedirect (getUri httpReq) res
 
+    performHttpReqRaw :: HTTP.Request -> SimpleRequest 'RO LBS.ByteString -> ExceptT Error IO LBS.ByteString
+    performHttpReqRaw httpReq Query {} = responseBody <$> httpLbs' httpReq
     performHttpReq' :: FromJSON b => HTTP.Request -> SimpleRequest 'RO b -> ExceptT Error IO b
     performHttpReq' httpReq Query {} = do
         res <- httpLbs' httpReq
@@ -230,6 +239,9 @@ makeHttpRequest auth r = case r of
     HeaderQuery h req -> do
         req' <- makeHttpSimpleRequest auth req
         return $ req' { requestHeaders = h <> requestHeaders req' }
+    RawHeaderQuery h req -> do
+        req' <- makeHttpSimpleRequest auth req
+        return $ req' { requestHeaders = h <> requestHeaders req' }
     RedirectQuery req -> do
         req' <- makeHttpSimpleRequest auth req
         return $ setRequestIgnoreStatus $ req' { redirectCount = 0 }