Skip to content

Commit 0afcf0c

Browse files
thomasjmthomasjm
committed
Enable per-page querying
1 parent 6b9716c commit 0afcf0c

4 files changed

Lines changed: 115 additions & 19 deletions

File tree

‎github.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -268,6 +268,7 @@ test-suite github-test
268268
, file-embed
269269
, github
270270
, hspec >=2.6.1 && <2.12
271+
, http-client
271272
, tagged
272273
, text
273274
, unordered-containers

‎spec/GitHub/IssuesSpec.hs‎

Lines changed: 26 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -6,12 +6,13 @@ import qualified GitHub
66
import Prelude ()
77
import Prelude.Compat
88

9-
import Data.Either.Compat (isRight)
10-
import Data.Foldable (for_)
11-
import Data.String (fromString)
12-
import System.Environment (lookupEnv)
13-
import Test.Hspec
14-
(Spec, describe, expectationFailure, it, pendingWith, shouldSatisfy)
9+
import Data.Either.Compat (isRight)
10+
import Data.Foldable (for_)
11+
import Data.String (fromString)
12+
import Network.HTTP.Client (newManager, responseBody)
13+
import System.Environment (lookupEnv)
14+
import Test.Hspec (Spec, describe, expectationFailure, it, pendingWith, shouldSatisfy)
15+
1516

1617
fromRightS :: Show a => Either a b -> b
1718
fromRightS (Right b) = b
@@ -38,6 +39,25 @@ spec = do
3839
cms <- GitHub.executeRequest auth $
3940
GitHub.commentsR owner repo (GitHub.issueNumber i) 1
4041
cms `shouldSatisfy` isRight
42+
43+
describe "issuesForRepoR paged" $ do
44+
it "works" $ withAuth $ \auth -> for_ repos $ \(owner, repo) -> do
45+
mgr <- newManager GitHub.tlsManagerSettings
46+
ret <- GitHub.executeRequestWithMgrAndRes mgr auth $
47+
GitHub.issuesForRepoR owner repo mempty (GitHub.FetchPage (GitHub.PageParams (Just 2) (Just 1)))
48+
49+
case ret of
50+
Left e ->
51+
expectationFailure . show $ e
52+
Right res -> do
53+
let issues = responseBody res
54+
length issues `shouldSatisfy` (<= 2)
55+
56+
for_ issues $ \i -> do
57+
cms <- GitHub.executeRequest auth $
58+
GitHub.commentsR owner repo (GitHub.issueNumber i) 1
59+
cms `shouldSatisfy` isRight
60+
4161
describe "issueR" $ do
4262
it "fetches issue #428" $ withAuth $ \auth -> do
4363
resIss <- GitHub.executeRequest auth $

‎src/GitHub/Data/Request.hs‎

Lines changed: 38 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,8 @@ module GitHub.Data.Request (
1515
CommandMethod(..),
1616
toMethod,
1717
FetchCount(..),
18+
PageParams(..),
19+
PageLinks(..),
1820
MediaType (..),
1921
Paths,
2022
IsPathPart(..),
@@ -30,6 +32,7 @@ import GitHub.Internal.Prelude
3032
import qualified Data.ByteString.Lazy as LBS
3133
import qualified Data.Text as T
3234
import qualified Network.HTTP.Types.Method as Method
35+
import Network.URI (URI)
3336

3437
------------------------------------------------------------------------------
3538
-- Path parts
@@ -75,7 +78,10 @@ toMethod Delete = Method.methodDelete
7578

7679
-- | 'PagedQuery' returns just some results, using this data we can specify how
7780
-- many pages we want to fetch.
78-
data FetchCount = FetchAtLeast !Word | FetchAll
81+
data FetchCount =
82+
FetchAtLeast !Word
83+
| FetchAll
84+
| FetchPage PageParams
7985
deriving (Eq, Ord, Read, Show, Generic, Typeable)
8086

8187

@@ -97,6 +103,37 @@ instance Hashable FetchCount
97103
instance Binary FetchCount
98104
instance NFData FetchCount where rnf = genericRnf
99105

106+
-------------------------------------------------------------------------------
107+
-- PageParams
108+
-------------------------------------------------------------------------------
109+
110+
-- | Params for specifying the precise page and items per page.
111+
data PageParams = PageParams {
112+
pageParamsPerPage :: Maybe Int
113+
, pageParamsPage :: Maybe Int
114+
}
115+
deriving (Eq, Ord, Read, Show, Generic, Typeable)
116+
117+
instance Hashable PageParams
118+
instance Binary PageParams
119+
instance NFData PageParams where rnf = genericRnf
120+
121+
-------------------------------------------------------------------------------
122+
-- PageLinks
123+
-------------------------------------------------------------------------------
124+
125+
-- | 'PagedQuery' returns just some results, using this data we can specify how
126+
-- many pages we want to fetch.
127+
data PageLinks = PageLinks {
128+
pageLinksPrev :: Maybe URI
129+
, pageLinksNext :: Maybe URI
130+
, pageLinksLast :: Maybe URI
131+
, pageLinksFirst :: Maybe URI
132+
}
133+
deriving (Eq, Ord, Show, Generic, Typeable)
134+
135+
instance NFData PageLinks where rnf = genericRnf
136+
100137
-------------------------------------------------------------------------------
101138
-- MediaType
102139
-------------------------------------------------------------------------------

‎src/GitHub/Request.hs‎

Lines changed: 50 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -54,6 +54,7 @@ module GitHub.Request (
5454
ParseResponse (..),
5555
makeHttpRequest,
5656
parseStatus,
57+
parsePageLinks,
5758
StatusMap,
5859
getNextUrl,
5960
performPagedRequest,
@@ -79,6 +80,7 @@ import Control.Monad.Trans.Class (lift)
7980
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
8081
import Data.Aeson (eitherDecode)
8182
import Data.List (find)
83+
import Data.Maybe (fromMaybe)
8284
import Data.Tagged (Tagged (..))
8385
import Data.Version (showVersion)
8486

@@ -87,13 +89,14 @@ import Network.HTTP.Client
8789
httpLbs, method, newManager, redirectCount, requestBody, requestHeaders,
8890
setQueryString, setRequestIgnoreStatus)
8991
import Network.HTTP.Link.Parser (parseLinkHeaderBS)
90-
import Network.HTTP.Link.Types (LinkParam (..), href, linkParams)
92+
import Network.HTTP.Link.Types (Link(..), LinkParam (..), href, linkParams)
9193
import Network.HTTP.Types (Method, RequestHeaders, Status (..))
9294
import Network.URI
9395
(URI, escapeURIString, isUnescapedInURIComponent, parseURIReference,
9496
relativeTo)
9597

9698
import qualified Data.ByteString as BS
99+
import Data.ByteString.Builder (intDec, toLazyByteString)
97100
import qualified Data.ByteString.Lazy as LBS
98101
import qualified Data.Text as T
99102
import qualified Data.Text.Encoding as TE
@@ -199,11 +202,6 @@ executeRequest auth req = withOpenSSL $ do
199202
manager <- newManager tlsManagerSettings
200203
executeRequestWithMgr manager auth req
201204

202-
lessFetchCount :: Int -> FetchCount -> Bool
203-
lessFetchCount _ FetchAll = True
204-
lessFetchCount i (FetchAtLeast j) = i < fromIntegral j
205-
206-
207205
-- | Like 'executeRequest' but with provided 'Manager'.
208206
executeRequestWithMgr
209207
:: (AuthMethod am, ParseResponse mt a)
@@ -235,10 +233,13 @@ executeRequestWithMgrAndRes mgr auth req = runExceptT $ do
235233
res <- httpLbs' httpReq
236234
(<$ res) <$> unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b))
237235

238-
performHttpReq httpReq (PagedQuery _ _ l) =
239-
unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b)))
240-
where
241-
predicate v = lessFetchCount (length v) l
236+
performHttpReq httpReq (PagedQuery _ _ (FetchPage _)) = do
237+
(res, _pageLinks) <- unTagged (performPerPageRequest httpLbs' httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b, PageLinks)))
238+
return res
239+
performHttpReq httpReq (PagedQuery _ _ FetchAll) =
240+
unTagged (performPagedRequest httpLbs' (const True) httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b)))
241+
performHttpReq httpReq (PagedQuery _ _ (FetchAtLeast j)) =
242+
unTagged (performPagedRequest httpLbs' (\v -> length v < fromIntegral j) httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b)))
242243

243244
performHttpReq httpReq (Command _ _ _) = do
244245
res <- httpLbs' httpReq
@@ -456,15 +457,15 @@ makeHttpRequest auth r = case r of
456457
$ setReqHeaders
457458
. unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
458459
. maybe id setAuthRequest auth
459-
. setQueryString qs
460+
. setQueryString (qs <> extraQueryItems)
460461
$ req
461462
PagedQuery paths qs _ -> do
462463
req <- parseUrl' $ url paths
463464
return
464465
$ setReqHeaders
465466
. unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
466467
. maybe id setAuthRequest auth
467-
. setQueryString qs
468+
. setQueryString (qs <> extraQueryItems)
468469
$ req
469470
Command m paths body -> do
470471
req <- parseUrl' $ url paths
@@ -496,6 +497,14 @@ makeHttpRequest auth r = case r of
496497
setBody :: LBS.ByteString -> HTTP.Request -> HTTP.Request
497498
setBody body req = req { requestBody = RequestBodyLBS body }
498499

500+
extraQueryItems :: [(BS.ByteString, Maybe BS.ByteString)]
501+
extraQueryItems = case r of
502+
PagedQuery _ _ (FetchPage pp) -> catMaybes [
503+
(\page -> ("page", Just (BS.toStrict $ toLazyByteString $ intDec page))) <$> pageParamsPage pp
504+
, (\perPage -> ("per_page", Just (BS.toStrict $ toLazyByteString $ intDec perPage))) <$> pageParamsPerPage pp
505+
]
506+
_ -> []
507+
499508
-- | Query @Link@ header with @rel=next@ from the request headers.
500509
getNextUrl :: HTTP.Response a -> Maybe URI
501510
getNextUrl req = do
@@ -542,6 +551,35 @@ performPagedRequest httpLbs' predicate initReq = Tagged $ do
542551
go (acc <> m) res' req'
543552
(_, _) -> return (acc <$ res)
544553

554+
-- | Helper for requesting a single page, as specified by 'PageParams'.
555+
--
556+
-- This parses and returns the 'PageLinks' alongside the HTTP response.
557+
performPerPageRequest
558+
:: forall a m mt. (ParseResponse mt a, MonadCatch m, MonadError Error m)
559+
=> (HTTP.Request -> m (HTTP.Response LBS.ByteString)) -- ^ `httpLbs` analogue
560+
-> HTTP.Request -- ^ initial request
561+
-> Tagged mt (m (HTTP.Response a, PageLinks))
562+
performPerPageRequest httpLbs' initReq = Tagged $ do
563+
res <- httpLbs' initReq
564+
m <- unTagged (parseResponse initReq res :: Tagged mt (m a))
565+
return (m <$ res, parsePageLinks res)
566+
567+
-- | Parse the 'PageLinks' from an HTTP response, where the information is
568+
-- encoded in the Link header.
569+
parsePageLinks :: HTTP.Response a -> PageLinks
570+
parsePageLinks res = PageLinks {
571+
pageLinksPrev = linkToUri <$> find (elem (Rel, "prev") . linkParams) links
572+
, pageLinksNext = linkToUri <$> find (elem (Rel, "next") . linkParams) links
573+
, pageLinksLast = linkToUri <$> find (elem (Rel, "last") . linkParams) links
574+
, pageLinksFirst = linkToUri <$> find (elem (Rel, "first") . linkParams) links
575+
}
576+
where
577+
links :: [Link URI]
578+
links = fromMaybe [] (lookup "Link" (responseHeaders res) >>= parseLinkHeaderBS)
579+
580+
linkToUri :: Link URI -> URI
581+
linkToUri (Link uri _) = uri
582+
545583
-------------------------------------------------------------------------------
546584
-- Internal
547585
-------------------------------------------------------------------------------

0 commit comments

Comments
 (0)