Skip to content

Commit 899180c

Browse files
phadejphadej
committed
Add MtPreview media type: extension point
1 parent d8f87ff commit 899180c

4 files changed

Lines changed: 129 additions & 45 deletions

File tree

‎github.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -206,6 +206,8 @@ test-suite github-test
206206
, bytestring
207207
, file-embed
208208
, github
209+
, tagged
210+
, text
209211
, hspec >=2.6.1 && <2.8
210212
, unordered-containers
211213
, vector

‎spec/GitHub/PullRequestsSpec.hs‎

Lines changed: 78 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -1,90 +1,103 @@
1-
{-# LANGUAGE OverloadedStrings #-}
2-
{-# LANGUAGE TemplateHaskell #-}
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleInstances #-}
3+
{-# LANGUAGE MultiParamTypeClasses #-}
4+
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE TemplateHaskell #-}
36
module GitHub.PullRequestsSpec where
47

5-
import qualified GitHub
8+
import qualified GitHub as GH
69

710
import Prelude ()
811
import Prelude.Compat
912

10-
import Data.Aeson (eitherDecodeStrict)
11-
import Data.ByteString (ByteString)
12-
import Data.Either.Compat (isRight)
13-
import Data.FileEmbed (embedFile)
14-
import Data.Foldable (for_)
15-
import Data.String (fromString)
16-
import qualified Data.Vector as V
13+
import Data.Aeson
14+
(FromJSON (..), eitherDecodeStrict, withObject, (.:))
15+
import Data.ByteString (ByteString)
1716
import qualified Data.ByteString.Lazy.Char8 as LBS8
18-
import System.Environment (lookupEnv)
17+
import Data.Either.Compat (isRight)
18+
import Data.FileEmbed (embedFile)
19+
import Data.Foldable (for_)
20+
import Data.String (fromString)
21+
import Data.Tagged (Tagged (..))
22+
import Data.Text (Text)
23+
import qualified Data.Vector as V
24+
import System.Environment (lookupEnv)
1925
import Test.Hspec
2026
(Spec, describe, it, pendingWith, shouldBe, shouldSatisfy)
2127

2228
fromRightS :: Show a => Either a b -> b
2329
fromRightS (Right b) = b
2430
fromRightS (Left a) = error $ "Expected a Right and got a Left" ++ show a
2531

26-
withAuth :: (GitHub.Auth -> IO ()) -> IO ()
32+
withAuth :: (GH.Auth -> IO ()) -> IO ()
2733
withAuth action = do
2834
mtoken <- lookupEnv "GITHUB_TOKEN"
2935
case mtoken of
3036
Nothing -> pendingWith "no GITHUB_TOKEN"
31-
Just token -> action (GitHub.OAuth $ fromString token)
37+
Just token -> action (GH.OAuth $ fromString token)
3238

3339
spec :: Spec
3440
spec = do
3541
describe "pullRequestsForR" $ do
3642
it "works" $ withAuth $ \auth -> for_ repos $ \(owner, repo) -> do
37-
cs <- GitHub.executeRequest auth $
38-
GitHub.pullRequestsForR owner repo opts GitHub.FetchAll
43+
cs <- GH.executeRequest auth $
44+
GH.pullRequestsForR owner repo opts GH.FetchAll
3945
cs `shouldSatisfy` isRight
4046

4147
describe "pullRequestPatchR" $
4248
it "works" $ withAuth $ \auth -> do
43-
Right patch <- GitHub.executeRequest auth $
44-
GitHub.pullRequestPatchR "phadej" "github" (GitHub.IssueNumber 349)
49+
Right patch <- GH.executeRequest auth $
50+
GH.pullRequestPatchR "phadej" "github" (GH.IssueNumber 349)
4551
head (LBS8.lines patch) `shouldBe` "From c0e4ad33811be82e1f72ee76116345c681703103 Mon Sep 17 00:00:00 2001"
4652

4753
describe "decoding pull request payloads" $ do
4854
it "decodes a pull request 'opened' payload" $ do
49-
V.length (GitHub.simplePullRequestRequestedReviewers simplePullRequestOpened)
55+
V.length (GH.simplePullRequestRequestedReviewers simplePullRequestOpened)
5056
`shouldBe` 0
5157

52-
V.length (GitHub.pullRequestRequestedReviewers pullRequestOpened)
58+
V.length (GH.pullRequestRequestedReviewers pullRequestOpened)
5359
`shouldBe` 0
5460

5561
it "decodes a pull request 'review_requested' payload" $ do
56-
V.length (GitHub.simplePullRequestRequestedReviewers simplePullRequestReviewRequested)
62+
V.length (GH.simplePullRequestRequestedReviewers simplePullRequestReviewRequested)
5763
`shouldBe` 1
5864

59-
V.length (GitHub.pullRequestRequestedReviewers pullRequestReviewRequested)
65+
V.length (GH.pullRequestRequestedReviewers pullRequestReviewRequested)
6066
`shouldBe` 1
6167

6268
describe "checking if a pull request is merged" $ do
6369
it "works" $ withAuth $ \auth -> do
64-
b <- GitHub.executeRequest auth $ GitHub.isPullRequestMergedR "phadej" "github" (GitHub.IssueNumber 14)
70+
b <- GH.executeRequest auth $ GH.isPullRequestMergedR "phadej" "github" (GH.IssueNumber 14)
6571
b `shouldSatisfy` isRight
6672
fromRightS b `shouldBe` True
6773

74+
describe "Draft Pull Request" $ do
75+
it "works" $ withAuth $ \auth -> do
76+
cs <- GH.executeRequest auth $
77+
draftPullRequestsForR "phadej" "github" opts GH.FetchAll
78+
79+
cs `shouldSatisfy` isRight
80+
6881
where
6982
repos =
7083
[ ("thoughtbot", "paperclip")
7184
, ("phadej", "github")
7285
]
73-
opts = GitHub.stateClosed
86+
opts = GH.stateClosed
7487

75-
simplePullRequestOpened :: GitHub.SimplePullRequest
88+
simplePullRequestOpened :: GH.SimplePullRequest
7689
simplePullRequestOpened =
7790
fromRightS (eitherDecodeStrict prOpenedPayload)
7891

79-
pullRequestOpened :: GitHub.PullRequest
92+
pullRequestOpened :: GH.PullRequest
8093
pullRequestOpened =
8194
fromRightS (eitherDecodeStrict prOpenedPayload)
8295

83-
simplePullRequestReviewRequested :: GitHub.SimplePullRequest
96+
simplePullRequestReviewRequested :: GH.SimplePullRequest
8497
simplePullRequestReviewRequested =
8598
fromRightS (eitherDecodeStrict prReviewRequestedPayload)
8699

87-
pullRequestReviewRequested :: GitHub.PullRequest
100+
pullRequestReviewRequested :: GH.PullRequest
88101
pullRequestReviewRequested =
89102
fromRightS (eitherDecodeStrict prReviewRequestedPayload)
90103

@@ -93,3 +106,41 @@ spec = do
93106

94107
prReviewRequestedPayload :: ByteString
95108
prReviewRequestedPayload = $(embedFile "fixtures/pull-request-review-requested.json")
109+
110+
-------------------------------------------------------------------------------
111+
-- Draft Pull Requests
112+
-------------------------------------------------------------------------------
113+
114+
draftPullRequestsForR
115+
:: GH.Name GH.Owner
116+
-> GH.Name GH.Repo
117+
-> GH.PullRequestMod
118+
-> GH.FetchCount
119+
-> GH.GenRequest ('GH.MtPreview ShadowCat) k (V.Vector DraftPR)
120+
draftPullRequestsForR user repo opts = GH.PagedQuery
121+
["repos", GH.toPathPart user, GH.toPathPart repo, "pulls"]
122+
(GH.prModToQueryString opts)
123+
124+
data DraftPR = DraftPR
125+
{ dprId :: !(GH.Id GH.PullRequest)
126+
, dprNumber :: !GH.IssueNumber
127+
, dprTitle :: !Text
128+
, dprDraft :: !Bool
129+
}
130+
deriving (Show)
131+
132+
instance FromJSON DraftPR where
133+
parseJSON = withObject "DraftPR" $ \obj -> DraftPR
134+
<$> obj .: "id"
135+
<*> obj .: "number"
136+
<*> obj .: "title"
137+
<*> obj .: "draft"
138+
139+
-- | @application/vnd.github.shadow-cat-preview+json@ <https://developer.github.com/v3/previews/#draft-pull-requests>
140+
data ShadowCat
141+
142+
instance GH.PreviewAccept ShadowCat where
143+
previewContentType = Tagged "application/vnd.github.shadow-cat-preview+json"
144+
145+
instance FromJSON a => GH.PreviewParseResponse ShadowCat a where
146+
previewParseResponse _ res = Tagged (GH.parseResponseJSON res)

‎src/GitHub/Data/Request.hs‎

Lines changed: 13 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -105,17 +105,18 @@ instance NFData FetchCount where rnf = genericRnf
105105
-- MediaType
106106
-------------------------------------------------------------------------------
107107

108-
data MediaType
109-
= MtJSON -- ^ @application/vnd.github.v3+json@
110-
| MtRaw -- ^ @application/vnd.github.v3.raw@ <https://developer.github.com/v3/media/#raw-1>
111-
| MtDiff -- ^ @application/vnd.github.v3.diff@ <https://developer.github.com/v3/media/#diff>
112-
| MtPatch -- ^ @application/vnd.github.v3.patch@ <https://developer.github.com/v3/media/#patch>
113-
| MtSha -- ^ @application/vnd.github.v3.sha@ <https://developer.github.com/v3/media/#sha>
114-
| MtStar -- ^ @application/vnd.github.v3.star+json@ <https://developer.github.com/v3/activity/starring/#alternative-response-with-star-creation-timestamps-1>
115-
| MtRedirect -- ^ <https://developer.github.com/v3/repos/contents/#get-archive-link>
116-
| MtStatus -- ^ Parse status
117-
| MtUnit -- ^ Always succeeds
118-
deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic)
108+
data MediaType a
109+
= MtJSON -- ^ @application/vnd.github.v3+json@
110+
| MtRaw -- ^ @application/vnd.github.v3.raw@ <https://developer.github.com/v3/media/#raw-1>
111+
| MtDiff -- ^ @application/vnd.github.v3.diff@ <https://developer.github.com/v3/media/#diff>
112+
| MtPatch -- ^ @application/vnd.github.v3.patch@ <https://developer.github.com/v3/media/#patch>
113+
| MtSha -- ^ @application/vnd.github.v3.sha@ <https://developer.github.com/v3/media/#sha>
114+
| MtStar -- ^ @application/vnd.github.v3.star+json@ <https://developer.github.com/v3/activity/starring/#alternative-response-with-star-creation-timestamps-1>
115+
| MtRedirect -- ^ <https://developer.github.com/v3/repos/contents/#get-archive-link>
116+
| MtStatus -- ^ Parse status
117+
| MtUnit -- ^ Always succeeds
118+
| MtPreview a -- ^ Some other (preview) type; this is an extension point.
119+
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
119120

120121
------------------------------------------------------------------------------
121122
-- RW
@@ -151,7 +152,7 @@ instance IReadOnly 'RA where iro = ROA
151152
-- * @a@ is the result type
152153
--
153154
-- /Note:/ 'Request' is not 'Functor' on purpose.
154-
data GenRequest (mt :: MediaType) (rw :: RW) a where
155+
data GenRequest (mt :: MediaType *) (rw :: RW) a where
155156
Query :: Paths -> QueryString -> GenRequest mt rw a
156157
PagedQuery :: Paths -> QueryString -> FetchCount -> GenRequest mt rw (Vector a)
157158

‎src/GitHub/Request.hs‎

Lines changed: 36 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,10 @@ module GitHub.Request (
5151
StatusMap,
5252
getNextUrl,
5353
performPagedRequest,
54+
parseResponseJSON,
55+
-- ** Preview
56+
PreviewAccept (..),
57+
PreviewParseResponse (..),
5458
) where
5559

5660
import GitHub.Internal.Prelude
@@ -67,9 +71,9 @@ import Data.List (find)
6771
import Data.Tagged (Tagged (..))
6872

6973
import Network.HTTP.Client
70-
(HttpException (..), Manager, RequestBody (..), Response (..),
71-
applyBasicAuth, getUri, httpLbs, method, newManager, redirectCount,
72-
requestBody, requestHeaders, setQueryString, setRequestIgnoreStatus)
74+
(HttpException (..), Manager, RequestBody (..), Response (..), getUri,
75+
httpLbs, method, newManager, redirectCount, requestBody, requestHeaders,
76+
setQueryString, setRequestIgnoreStatus)
7377
import Network.HTTP.Client.TLS (tlsManagerSettings)
7478
import Network.HTTP.Link.Parser (parseLinkHeaderBS)
7579
import Network.HTTP.Link.Types (Link (..), LinkParam (..), href, linkParams)
@@ -179,15 +183,18 @@ unsafeDropAuthRequirements r =
179183
-- Parse response
180184
-------------------------------------------------------------------------------
181185

182-
class Accept (mt :: MediaType) where
186+
class Accept (mt :: MediaType *) where
183187
contentType :: Tagged mt BS.ByteString
184188
contentType = Tagged "application/json" -- default is JSON
185189

186190
modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)
187191
modifyRequest = Tagged id
188192

189-
class Accept mt => ParseResponse (mt :: MediaType) a where
190-
parseResponse :: MonadError Error m => HTTP.Request -> HTTP.Response LBS.ByteString -> Tagged mt (m a)
193+
class Accept mt => ParseResponse (mt :: MediaType *) a where
194+
parseResponse
195+
:: MonadError Error m
196+
=> HTTP.Request -> HTTP.Response LBS.ByteString
197+
-> Tagged mt (m a)
191198

192199
-------------------------------------------------------------------------------
193200
-- JSON (+ star)
@@ -258,6 +265,29 @@ parseRedirect originalUri rsp = do
258265
where
259266
noLocation = throwError $ ParseError "no location header in response"
260267

268+
-------------------------------------------------------------------------------
269+
-- Extension point
270+
-------------------------------------------------------------------------------
271+
272+
class PreviewAccept p where
273+
previewContentType :: Tagged ('MtPreview p) BS.ByteString
274+
275+
previewModifyRequest :: Tagged ('MtPreview p) (HTTP.Request -> HTTP.Request)
276+
previewModifyRequest = Tagged id
277+
278+
class PreviewAccept p => PreviewParseResponse p a where
279+
previewParseResponse
280+
:: MonadError Error m
281+
=> HTTP.Request -> HTTP.Response LBS.ByteString
282+
-> Tagged ('MtPreview p) (m a)
283+
284+
instance PreviewAccept p => Accept ('MtPreview p) where
285+
contentType = previewContentType
286+
modifyRequest = previewModifyRequest
287+
288+
instance PreviewParseResponse p a => ParseResponse ('MtPreview p) a where
289+
parseResponse = previewParseResponse
290+
261291
-------------------------------------------------------------------------------
262292
-- Status
263293
-------------------------------------------------------------------------------

0 commit comments

Comments
 (0)