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

Author: thomasjm

github.cabal

@@ -264,6 +264,7 @@ test-suite github-test
     , file-embed
     , github
     , hspec                 >=2.6.1 && <2.12
+    , http-client
     , tagged
     , text
     , unordered-containers

spec/GitHub/IssuesSpec.hs

@@ -6,12 +6,13 @@ import qualified GitHub
 import Prelude ()
 import Prelude.Compat
 
-import Data.Either.Compat (isRight)
-import Data.Foldable      (for_)
-import Data.String        (fromString)
-import System.Environment (lookupEnv)
-import Test.Hspec
-       (Spec, describe, expectationFailure, it, pendingWith, shouldSatisfy)
+import Data.Either.Compat  (isRight)
+import Data.Foldable       (for_)
+import Data.String         (fromString)
+import Network.HTTP.Client (newManager, responseBody)
+import System.Environment  (lookupEnv)
+import Test.Hspec          (Spec, describe, expectationFailure, it, pendingWith, shouldSatisfy)
+
 
 fromRightS :: Show a => Either a b -> b
 fromRightS (Right b) = b
@@ -38,6 +39,25 @@ spec = do
                   cms <- GitHub.executeRequest auth $
                     GitHub.commentsR owner repo (GitHub.issueNumber i) 1
                   cms `shouldSatisfy` isRight
+
+    describe "issuesForRepoR paged" $ do
+        it "works" $ withAuth $ \auth -> for_ repos $ \(owner, repo) -> do
+            mgr <- newManager GitHub.tlsManagerSettings
+            ret <- GitHub.executeRequestWithMgrAndRes mgr auth $
+                GitHub.issuesForRepoR owner repo mempty (GitHub.FetchPage (GitHub.PageParams (Just 2) (Just 1)))
+
+            case ret of
+              Left e ->
+                expectationFailure . show $ e
+              Right res -> do
+                let issues = responseBody res
+                length issues `shouldSatisfy` (<= 2)
+
+                for_ issues $ \i -> do
+                  cms <- GitHub.executeRequest auth $
+                    GitHub.commentsR owner repo (GitHub.issueNumber i) 1
+                  cms `shouldSatisfy` isRight
+
     describe "issueR" $ do
         it "fetches issue #428" $ withAuth $ \auth -> do
             resIss <- GitHub.executeRequest auth $

src/GitHub/Data/Request.hs

@@ -14,6 +14,8 @@ module GitHub.Data.Request (
     CommandMethod(..),
     toMethod,
     FetchCount(..),
+    PageParams(..),
+    PageLinks(..),
     MediaType (..),
     Paths,
     IsPathPart(..),
@@ -29,6 +31,7 @@ import GitHub.Internal.Prelude
 import qualified Data.ByteString.Lazy      as LBS
 import qualified Data.Text                 as T
 import qualified Network.HTTP.Types.Method as Method
+import Network.URI (URI)
 
 ------------------------------------------------------------------------------
 -- Path parts
@@ -74,7 +77,10 @@ toMethod Delete = Method.methodDelete
 
 -- | 'PagedQuery' returns just some results, using this data we can specify how
 -- many pages we want to fetch.
-data FetchCount = FetchAtLeast !Word | FetchAll
+data FetchCount =
+    FetchAtLeast !Word
+    | FetchAll
+    | FetchPage PageParams
     deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 
@@ -96,6 +102,37 @@ instance Hashable FetchCount
 instance Binary FetchCount
 instance NFData FetchCount where rnf = genericRnf
 
+-------------------------------------------------------------------------------
+-- PageParams
+-------------------------------------------------------------------------------
+
+-- | Params for specifying the precise page and items per page.
+data PageParams = PageParams {
+    pageParamsPerPage :: Maybe Int
+    , pageParamsPage :: Maybe Int
+    }
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Hashable PageParams
+instance Binary PageParams
+instance NFData PageParams where rnf = genericRnf
+
+-------------------------------------------------------------------------------
+-- PageLinks
+-------------------------------------------------------------------------------
+
+-- | 'PagedQuery' returns just some results, using this data we can specify how
+-- many pages we want to fetch.
+data PageLinks = PageLinks {
+    pageLinksPrev :: Maybe URI
+    , pageLinksNext :: Maybe URI
+    , pageLinksLast :: Maybe URI
+    , pageLinksFirst :: Maybe URI
+    }
+    deriving (Eq, Ord, Show, Generic, Typeable)
+
+instance NFData PageLinks where rnf = genericRnf
+
 -------------------------------------------------------------------------------
 -- MediaType
 -------------------------------------------------------------------------------

src/GitHub/Request.hs

@@ -54,6 +54,7 @@ module GitHub.Request (
     ParseResponse (..),
     makeHttpRequest,
     parseStatus,
+    parsePageLinks,
     StatusMap,
     getNextUrl,
     performPagedRequest,
@@ -79,6 +80,7 @@ import Control.Monad.Trans.Class  (lift)
 import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import Data.Aeson                 (eitherDecode)
 import Data.List                  (find)
+import Data.Maybe                 (fromMaybe)
 import Data.Tagged                (Tagged (..))
 import Data.Version               (showVersion)
 
@@ -87,13 +89,14 @@ import Network.HTTP.Client
        httpLbs, method, newManager, redirectCount, requestBody, requestHeaders,
        setQueryString, setRequestIgnoreStatus)
 import Network.HTTP.Link.Parser (parseLinkHeaderBS)
-import Network.HTTP.Link.Types  (LinkParam (..), href, linkParams)
+import Network.HTTP.Link.Types  (Link(..), LinkParam (..), href, linkParams)
 import Network.HTTP.Types       (Method, RequestHeaders, Status (..))
 import Network.URI
        (URI, escapeURIString, isUnescapedInURIComponent, parseURIReference,
        relativeTo)
 
 import qualified Data.ByteString              as BS
+import           Data.ByteString.Builder      (intDec, toLazyByteString)
 import qualified Data.ByteString.Lazy         as LBS
 import qualified Data.Text                    as T
 import qualified Data.Text.Encoding           as TE
@@ -199,11 +202,6 @@ executeRequest auth req = withOpenSSL $ do
     manager <- newManager tlsManagerSettings
     executeRequestWithMgr manager auth req
 
-lessFetchCount :: Int -> FetchCount -> Bool
-lessFetchCount _ FetchAll         = True
-lessFetchCount i (FetchAtLeast j) = i < fromIntegral j
-
-
 -- | Like 'executeRequest' but with provided 'Manager'.
 executeRequestWithMgr
     :: (AuthMethod am, ParseResponse mt a)
@@ -235,10 +233,13 @@ executeRequestWithMgrAndRes mgr auth req = runExceptT $ do
         res <- httpLbs' httpReq
         (<$ res) <$> unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b))
 
-    performHttpReq httpReq (PagedQuery _ _ l) =
-        unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b)))
-      where
-        predicate v = lessFetchCount (length v) l
+    performHttpReq httpReq (PagedQuery _ _ (FetchPage _)) = do
+        (res, _pageLinks) <- unTagged (performPerPageRequest httpLbs' httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b, PageLinks)))
+        return res
+    performHttpReq httpReq (PagedQuery _ _ FetchAll) =
+        unTagged (performPagedRequest httpLbs' (const True) httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b)))
+    performHttpReq httpReq (PagedQuery _ _ (FetchAtLeast j)) =
+        unTagged (performPagedRequest httpLbs' (\v -> length v < fromIntegral j) httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b)))
 
     performHttpReq httpReq (Command _ _ _) = do
         res <- httpLbs' httpReq
@@ -456,15 +457,15 @@ makeHttpRequest auth r = case r of
             $ setReqHeaders
             . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
             . maybe id setAuthRequest auth
-            . setQueryString qs
+            . setQueryString (qs <> extraQueryItems)
             $ req
     PagedQuery paths qs _ -> do
         req <- parseUrl' $ url paths
         return
             $ setReqHeaders
             . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
             . maybe id setAuthRequest auth
-            . setQueryString qs
+            . setQueryString (qs <> extraQueryItems)
             $ req
     Command m paths body -> do
         req <- parseUrl' $ url paths
@@ -496,6 +497,14 @@ makeHttpRequest auth r = case r of
     setBody :: LBS.ByteString -> HTTP.Request -> HTTP.Request
     setBody body req = req { requestBody = RequestBodyLBS body }
 
+    extraQueryItems :: [(BS.ByteString, Maybe BS.ByteString)]
+    extraQueryItems = case r of
+      PagedQuery _ _ (FetchPage pp) -> catMaybes [
+          (\page -> ("page", Just (BS.toStrict $ toLazyByteString $ intDec page))) <$> pageParamsPage pp
+          , (\perPage -> ("per_page", Just (BS.toStrict $ toLazyByteString $ intDec perPage))) <$> pageParamsPerPage pp
+          ]
+      _ -> []
+
 -- | Query @Link@ header with @rel=next@ from the request headers.
 getNextUrl :: HTTP.Response a -> Maybe URI
 getNextUrl req = do
@@ -542,6 +551,35 @@ performPagedRequest httpLbs' predicate initReq = Tagged $ do
                 go (acc <> m) res' req'
             (_, _)           -> return (acc <$ res)
 
+-- | Helper for requesting a single page, as specified by 'PageParams'.
+--
+-- This parses and returns the 'PageLinks' alongside the HTTP response.
+performPerPageRequest
+    :: forall a m mt. (ParseResponse mt a, MonadCatch m, MonadError Error m)
+    => (HTTP.Request -> m (HTTP.Response LBS.ByteString))  -- ^ `httpLbs` analogue
+    -> HTTP.Request                                        -- ^ initial request
+    -> Tagged mt (m (HTTP.Response a, PageLinks))
+performPerPageRequest httpLbs' initReq = Tagged $ do
+    res <- httpLbs' initReq
+    m <- unTagged (parseResponse initReq res :: Tagged mt (m a))
+    return (m <$ res, parsePageLinks res)
+
+-- | Parse the 'PageLinks' from an HTTP response, where the information is
+-- encoded in the Link header.
+parsePageLinks :: HTTP.Response a -> PageLinks
+parsePageLinks res = PageLinks {
+    pageLinksPrev = linkToUri <$> find (elem (Rel, "prev") . linkParams) links
+    , pageLinksNext = linkToUri <$> find (elem (Rel, "next") . linkParams) links
+    , pageLinksLast = linkToUri <$> find (elem (Rel, "last") . linkParams) links
+    , pageLinksFirst = linkToUri <$> find (elem (Rel, "first") . linkParams) links
+    }
+    where
+        links :: [Link URI]
+        links = fromMaybe [] (lookup "Link" (responseHeaders res) >>= parseLinkHeaderBS)
+
+        linkToUri :: Link URI -> URI
+        linkToUri (Link uri _) = uri
+
 -------------------------------------------------------------------------------
 -- Internal
 -------------------------------------------------------------------------------