Skip to content

Commit 2bed394

Browse files
authored
Support pagination (#503)
* Working on PerPageQuery * Add issuesForRepoPagedR + failing test * Testing, todo REVERT * About to try integrating paging into the normal executeRequest calls * API is looking better, call this v2 * Clean up some debugging stuff * More cleanup * More cleanup * Another slight refactor * Another cleanup * Improve test
1 parent 529e357 commit 2bed394

File tree

4 files changed

+115
-19
lines changed

4 files changed

+115
-19
lines changed

github.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -264,6 +264,7 @@ test-suite github-test
264264
, file-embed
265265
, github
266266
, hspec >=2.6.1 && <2.12
267+
, http-client
267268
, tagged
268269
, text
269270
, 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
@@ -14,6 +14,8 @@ module GitHub.Data.Request (
1414
CommandMethod(..),
1515
toMethod,
1616
FetchCount(..),
17+
PageParams(..),
18+
PageLinks(..),
1719
MediaType (..),
1820
Paths,
1921
IsPathPart(..),
@@ -29,6 +31,7 @@ import GitHub.Internal.Prelude
2931
import qualified Data.ByteString.Lazy as LBS
3032
import qualified Data.Text as T
3133
import qualified Network.HTTP.Types.Method as Method
34+
import Network.URI (URI)
3235

3336
------------------------------------------------------------------------------
3437
-- Path parts
@@ -74,7 +77,10 @@ toMethod Delete = Method.methodDelete
7477

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

8086

@@ -96,6 +102,37 @@ instance Hashable FetchCount
96102
instance Binary FetchCount
97103
instance NFData FetchCount where rnf = genericRnf
98104

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

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)