Add MtPreview media type: extension point

github.cabal

@@ -206,6 +206,8 @@ test-suite github-test
     , bytestring
     , file-embed
     , github
+    , tagged
+    , text
     , hspec                 >=2.6.1 && <2.8
     , unordered-containers
     , vector

spec/GitHub/PullRequestsSpec.hs

@@ -1,90 +1,103 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TemplateHaskell       #-}
 module GitHub.PullRequestsSpec where
 
-import qualified GitHub
+import qualified GitHub as GH
 
 import Prelude ()
 import Prelude.Compat
 
-import           Data.Aeson         (eitherDecodeStrict)
-import           Data.ByteString    (ByteString)
-import           Data.Either.Compat (isRight)
-import           Data.FileEmbed     (embedFile)
-import           Data.Foldable      (for_)
-import           Data.String        (fromString)
-import qualified Data.Vector        as V
+import           Data.Aeson
+                 (FromJSON (..), eitherDecodeStrict, withObject, (.:))
+import           Data.ByteString            (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LBS8
-import           System.Environment (lookupEnv)
+import           Data.Either.Compat         (isRight)
+import           Data.FileEmbed             (embedFile)
+import           Data.Foldable              (for_)
+import           Data.String                (fromString)
+import           Data.Tagged                (Tagged (..))
+import           Data.Text                  (Text)
+import qualified Data.Vector                as V
+import           System.Environment         (lookupEnv)
 import           Test.Hspec
                  (Spec, describe, it, pendingWith, shouldBe, shouldSatisfy)
 
 fromRightS :: Show a => Either a b -> b
 fromRightS (Right b) = b
 fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a
 
-withAuth :: (GitHub.Auth -> IO ()) -> IO ()
+withAuth :: (GH.Auth -> IO ()) -> IO ()
 withAuth action = do
     mtoken <- lookupEnv "GITHUB_TOKEN"
     case mtoken of
         Nothing    -> pendingWith "no GITHUB_TOKEN"
-        Just token -> action (GitHub.OAuth $ fromString token)
+        Just token -> action (GH.OAuth $ fromString token)
 
 spec :: Spec
 spec = do
     describe "pullRequestsForR" $ do
         it "works" $ withAuth $ \auth -> for_ repos $ \(owner, repo) -> do
-            cs <- GitHub.executeRequest auth $
-                GitHub.pullRequestsForR owner repo opts GitHub.FetchAll
+            cs <- GH.executeRequest auth $
+                GH.pullRequestsForR owner repo opts GH.FetchAll
             cs `shouldSatisfy` isRight
 
     describe "pullRequestPatchR" $
         it "works" $ withAuth $ \auth -> do
-            Right patch <- GitHub.executeRequest auth $
-                GitHub.pullRequestPatchR "phadej" "github" (GitHub.IssueNumber 349)
+            Right patch <- GH.executeRequest auth $
+                GH.pullRequestPatchR "phadej" "github" (GH.IssueNumber 349)
             head (LBS8.lines patch) `shouldBe` "From c0e4ad33811be82e1f72ee76116345c681703103 Mon Sep 17 00:00:00 2001"
 
     describe "decoding pull request payloads" $ do
         it "decodes a pull request 'opened' payload" $ do
-            V.length (GitHub.simplePullRequestRequestedReviewers simplePullRequestOpened)
+            V.length (GH.simplePullRequestRequestedReviewers simplePullRequestOpened)
                 `shouldBe` 0
 
-            V.length (GitHub.pullRequestRequestedReviewers pullRequestOpened)
+            V.length (GH.pullRequestRequestedReviewers pullRequestOpened)
                 `shouldBe` 0
 
         it "decodes a pull request 'review_requested' payload" $ do
-            V.length (GitHub.simplePullRequestRequestedReviewers simplePullRequestReviewRequested)
+            V.length (GH.simplePullRequestRequestedReviewers simplePullRequestReviewRequested)
                 `shouldBe` 1
 
-            V.length (GitHub.pullRequestRequestedReviewers pullRequestReviewRequested)
+            V.length (GH.pullRequestRequestedReviewers pullRequestReviewRequested)
                 `shouldBe` 1
 
     describe "checking if a pull request is merged" $ do
         it "works" $ withAuth $ \auth -> do
-            b <- GitHub.executeRequest auth $ GitHub.isPullRequestMergedR "phadej" "github" (GitHub.IssueNumber 14)
+            b <- GH.executeRequest auth $ GH.isPullRequestMergedR "phadej" "github" (GH.IssueNumber 14)
             b `shouldSatisfy` isRight
             fromRightS b `shouldBe` True
 
+    describe "Draft Pull Request" $ do
+        it "works" $ withAuth $ \auth -> do
+            cs <- GH.executeRequest auth $
+                draftPullRequestsForR "phadej" "github" opts GH.FetchAll
+
+            cs `shouldSatisfy` isRight
+
   where
     repos =
       [ ("thoughtbot", "paperclip")
       , ("phadej", "github")
       ]
-    opts = GitHub.stateClosed
+    opts = GH.stateClosed
 
-    simplePullRequestOpened :: GitHub.SimplePullRequest
+    simplePullRequestOpened :: GH.SimplePullRequest
     simplePullRequestOpened =
         fromRightS (eitherDecodeStrict prOpenedPayload)
 
-    pullRequestOpened :: GitHub.PullRequest
+    pullRequestOpened :: GH.PullRequest
     pullRequestOpened =
         fromRightS (eitherDecodeStrict prOpenedPayload)
 
-    simplePullRequestReviewRequested :: GitHub.SimplePullRequest
+    simplePullRequestReviewRequested :: GH.SimplePullRequest
     simplePullRequestReviewRequested =
         fromRightS (eitherDecodeStrict prReviewRequestedPayload)
 
-    pullRequestReviewRequested :: GitHub.PullRequest
+    pullRequestReviewRequested :: GH.PullRequest
     pullRequestReviewRequested =
         fromRightS (eitherDecodeStrict prReviewRequestedPayload)
 
@@ -93,3 +106,41 @@ spec = do
 
     prReviewRequestedPayload :: ByteString
     prReviewRequestedPayload = $(embedFile "fixtures/pull-request-review-requested.json")
+
+-------------------------------------------------------------------------------
+-- Draft Pull Requests
+-------------------------------------------------------------------------------
+
+draftPullRequestsForR
+    :: GH.Name GH.Owner
+    -> GH.Name GH.Repo
+    -> GH.PullRequestMod
+    -> GH.FetchCount
+    -> GH.GenRequest ('GH.MtPreview ShadowCat) k (V.Vector DraftPR)
+draftPullRequestsForR user repo opts = GH.PagedQuery
+    ["repos", GH.toPathPart user, GH.toPathPart repo, "pulls"]
+    (GH.prModToQueryString opts)
+
+data DraftPR = DraftPR
+    { dprId     :: !(GH.Id GH.PullRequest)
+    , dprNumber :: !GH.IssueNumber
+    , dprTitle  :: !Text
+    , dprDraft  :: !Bool
+    }
+  deriving (Show)
+
+instance FromJSON DraftPR where
+    parseJSON = withObject "DraftPR" $ \obj -> DraftPR
+        <$> obj .: "id"
+        <*> obj .: "number"
+        <*> obj .: "title"
+        <*> obj .: "draft"
+
+-- | @application/vnd.github.shadow-cat-preview+json@ <https://developer.github.com/v3/previews/#draft-pull-requests>
+data ShadowCat
+
+instance GH.PreviewAccept ShadowCat where
+    previewContentType = Tagged "application/vnd.github.shadow-cat-preview+json"
+
+instance FromJSON a => GH.PreviewParseResponse ShadowCat a where
+    previewParseResponse _ res = Tagged (GH.parseResponseJSON res)

src/GitHub/Data/Request.hs

@@ -105,17 +105,18 @@ instance NFData FetchCount where rnf = genericRnf
 -- MediaType
 -------------------------------------------------------------------------------
 
-data MediaType
-    = MtJSON     -- ^ @application/vnd.github.v3+json@
-    | MtRaw      -- ^ @application/vnd.github.v3.raw@ <https://developer.github.com/v3/media/#raw-1>
-    | MtDiff     -- ^ @application/vnd.github.v3.diff@ <https://developer.github.com/v3/media/#diff>
-    | MtPatch    -- ^ @application/vnd.github.v3.patch@ <https://developer.github.com/v3/media/#patch>
-    | MtSha      -- ^ @application/vnd.github.v3.sha@ <https://developer.github.com/v3/media/#sha>
-    | MtStar     -- ^ @application/vnd.github.v3.star+json@ <https://developer.github.com/v3/activity/starring/#alternative-response-with-star-creation-timestamps-1>
-    | MtRedirect -- ^ <https://developer.github.com/v3/repos/contents/#get-archive-link>
-    | MtStatus   -- ^ Parse status
-    | MtUnit     -- ^ Always succeeds
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic)
+data MediaType a
+    = MtJSON       -- ^ @application/vnd.github.v3+json@
+    | MtRaw        -- ^ @application/vnd.github.v3.raw@ <https://developer.github.com/v3/media/#raw-1>
+    | MtDiff       -- ^ @application/vnd.github.v3.diff@ <https://developer.github.com/v3/media/#diff>
+    | MtPatch      -- ^ @application/vnd.github.v3.patch@ <https://developer.github.com/v3/media/#patch>
+    | MtSha        -- ^ @application/vnd.github.v3.sha@ <https://developer.github.com/v3/media/#sha>
+    | MtStar       -- ^ @application/vnd.github.v3.star+json@ <https://developer.github.com/v3/activity/starring/#alternative-response-with-star-creation-timestamps-1>
+    | MtRedirect   -- ^ <https://developer.github.com/v3/repos/contents/#get-archive-link>
+    | MtStatus     -- ^ Parse status
+    | MtUnit       -- ^ Always succeeds
+    | MtPreview  a -- ^ Some other (preview) type; this is an extension point.
+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
 
 ------------------------------------------------------------------------------
 -- RW
@@ -151,7 +152,7 @@ instance IReadOnly 'RA        where iro = ROA
 -- * @a@ is the result type
 --
 -- /Note:/ 'Request' is not 'Functor' on purpose.
-data GenRequest (mt :: MediaType) (rw :: RW) a where
+data GenRequest (mt :: MediaType *) (rw :: RW) a where
     Query        :: Paths -> QueryString -> GenRequest mt rw a
     PagedQuery   :: Paths -> QueryString -> FetchCount -> GenRequest mt rw (Vector a)
 

src/GitHub/Request.hs

@@ -51,6 +51,10 @@ module GitHub.Request (
     StatusMap,
     getNextUrl,
     performPagedRequest,
+    parseResponseJSON,
+    -- ** Preview
+    PreviewAccept (..),
+    PreviewParseResponse (..),
     ) where
 
 import GitHub.Internal.Prelude
@@ -67,9 +71,9 @@ import Data.List                  (find)
 import Data.Tagged                (Tagged (..))
 
 import Network.HTTP.Client
-       (HttpException (..), Manager, RequestBody (..), Response (..),
-       applyBasicAuth, getUri, httpLbs, method, newManager, redirectCount,
-       requestBody, requestHeaders, setQueryString, setRequestIgnoreStatus)
+       (HttpException (..), Manager, RequestBody (..), Response (..), getUri,
+       httpLbs, method, newManager, redirectCount, requestBody, requestHeaders,
+       setQueryString, setRequestIgnoreStatus)
 import Network.HTTP.Client.TLS  (tlsManagerSettings)
 import Network.HTTP.Link.Parser (parseLinkHeaderBS)
 import Network.HTTP.Link.Types  (Link (..), LinkParam (..), href, linkParams)
@@ -179,15 +183,18 @@ unsafeDropAuthRequirements r             =
 -- Parse response
 -------------------------------------------------------------------------------
 
-class Accept (mt :: MediaType) where
+class Accept (mt :: MediaType *) where
     contentType :: Tagged mt BS.ByteString
     contentType = Tagged "application/json" -- default is JSON
 
     modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)
     modifyRequest = Tagged id
 
-class Accept mt => ParseResponse (mt :: MediaType) a where
-    parseResponse :: MonadError Error m => HTTP.Request -> HTTP.Response LBS.ByteString -> Tagged mt (m a)
+class Accept mt => ParseResponse (mt :: MediaType *) a where
+    parseResponse
+        :: MonadError Error m
+        => HTTP.Request -> HTTP.Response LBS.ByteString
+        -> Tagged mt (m a)
 
 -------------------------------------------------------------------------------
 -- JSON (+ star)
@@ -258,6 +265,29 @@ parseRedirect originalUri rsp = do
   where
     noLocation = throwError $ ParseError "no location header in response"
 
+-------------------------------------------------------------------------------
+-- Extension point
+-------------------------------------------------------------------------------
+
+class PreviewAccept p where
+    previewContentType :: Tagged ('MtPreview p) BS.ByteString
+
+    previewModifyRequest :: Tagged ('MtPreview p) (HTTP.Request -> HTTP.Request)
+    previewModifyRequest = Tagged id
+
+class PreviewAccept p => PreviewParseResponse p a where
+    previewParseResponse
+        :: MonadError Error m
+        => HTTP.Request -> HTTP.Response LBS.ByteString
+        -> Tagged ('MtPreview p) (m a)
+
+instance PreviewAccept p => Accept ('MtPreview p) where
+    contentType   = previewContentType
+    modifyRequest = previewModifyRequest
+
+instance PreviewParseResponse p a => ParseResponse ('MtPreview p) a where
+    parseResponse = previewParseResponse
+
 -------------------------------------------------------------------------------
 -- Status
 -------------------------------------------------------------------------------