@@ -54,6 +54,7 @@ module GitHub.Request (
54
54
ParseResponse (.. ),
55
55
makeHttpRequest ,
56
56
parseStatus ,
57
+ parsePageLinks ,
57
58
StatusMap ,
58
59
getNextUrl ,
59
60
performPagedRequest ,
@@ -79,6 +80,7 @@ import Control.Monad.Trans.Class (lift)
79
80
import Control.Monad.Trans.Except (ExceptT (.. ), runExceptT )
80
81
import Data.Aeson (eitherDecode )
81
82
import Data.List (find )
83
+ import Data.Maybe (fromMaybe )
82
84
import Data.Tagged (Tagged (.. ))
83
85
import Data.Version (showVersion )
84
86
@@ -87,13 +89,14 @@ import Network.HTTP.Client
87
89
httpLbs , method , newManager , redirectCount , requestBody , requestHeaders ,
88
90
setQueryString , setRequestIgnoreStatus )
89
91
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 )
91
93
import Network.HTTP.Types (Method , RequestHeaders , Status (.. ))
92
94
import Network.URI
93
95
(URI , escapeURIString , isUnescapedInURIComponent , parseURIReference ,
94
96
relativeTo )
95
97
96
98
import qualified Data.ByteString as BS
99
+ import Data.ByteString.Builder (intDec , toLazyByteString )
97
100
import qualified Data.ByteString.Lazy as LBS
98
101
import qualified Data.Text as T
99
102
import qualified Data.Text.Encoding as TE
@@ -199,11 +202,6 @@ executeRequest auth req = withOpenSSL $ do
199
202
manager <- newManager tlsManagerSettings
200
203
executeRequestWithMgr manager auth req
201
204
202
- lessFetchCount :: Int -> FetchCount -> Bool
203
- lessFetchCount _ FetchAll = True
204
- lessFetchCount i (FetchAtLeast j) = i < fromIntegral j
205
-
206
-
207
205
-- | Like 'executeRequest' but with provided 'Manager'.
208
206
executeRequestWithMgr
209
207
:: (AuthMethod am , ParseResponse mt a )
@@ -235,10 +233,13 @@ executeRequestWithMgrAndRes mgr auth req = runExceptT $ do
235
233
res <- httpLbs' httpReq
236
234
(<$ res) <$> unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b ))
237
235
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 )))
242
243
243
244
performHttpReq httpReq (Command _ _ _) = do
244
245
res <- httpLbs' httpReq
@@ -456,15 +457,15 @@ makeHttpRequest auth r = case r of
456
457
$ setReqHeaders
457
458
. unTagged (modifyRequest :: Tagged mt (HTTP. Request -> HTTP. Request ))
458
459
. maybe id setAuthRequest auth
459
- . setQueryString qs
460
+ . setQueryString (qs <> extraQueryItems)
460
461
$ req
461
462
PagedQuery paths qs _ -> do
462
463
req <- parseUrl' $ url paths
463
464
return
464
465
$ setReqHeaders
465
466
. unTagged (modifyRequest :: Tagged mt (HTTP. Request -> HTTP. Request ))
466
467
. maybe id setAuthRequest auth
467
- . setQueryString qs
468
+ . setQueryString (qs <> extraQueryItems)
468
469
$ req
469
470
Command m paths body -> do
470
471
req <- parseUrl' $ url paths
@@ -496,6 +497,14 @@ makeHttpRequest auth r = case r of
496
497
setBody :: LBS. ByteString -> HTTP. Request -> HTTP. Request
497
498
setBody body req = req { requestBody = RequestBodyLBS body }
498
499
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
+
499
508
-- | Query @Link@ header with @rel=next@ from the request headers.
500
509
getNextUrl :: HTTP. Response a -> Maybe URI
501
510
getNextUrl req = do
@@ -542,6 +551,35 @@ performPagedRequest httpLbs' predicate initReq = Tagged $ do
542
551
go (acc <> m) res' req'
543
552
(_, _) -> return (acc <$ res)
544
553
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
+
545
583
-------------------------------------------------------------------------------
546
584
-- Internal
547
585
-------------------------------------------------------------------------------
0 commit comments