diff --git a/github.cabal b/github.cabal index e97f8b41..f9e8e8db 100644 --- a/github.cabal +++ b/github.cabal @@ -264,7 +264,6 @@ test-suite github-test , file-embed , github , hspec >=2.6.1 && <2.12 - , http-client , tagged , text , unordered-containers diff --git a/spec/GitHub/IssuesSpec.hs b/spec/GitHub/IssuesSpec.hs index e673975f..2a7f5e7b 100644 --- a/spec/GitHub/IssuesSpec.hs +++ b/spec/GitHub/IssuesSpec.hs @@ -6,13 +6,12 @@ import qualified GitHub import Prelude () import Prelude.Compat -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) - +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) fromRightS :: Show a => Either a b -> b fromRightS (Right b) = b @@ -39,25 +38,6 @@ 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 $ diff --git a/src/GitHub/Data/Request.hs b/src/GitHub/Data/Request.hs index c8138c1a..7b4eac40 100644 --- a/src/GitHub/Data/Request.hs +++ b/src/GitHub/Data/Request.hs @@ -14,8 +14,6 @@ module GitHub.Data.Request ( CommandMethod(..), toMethod, FetchCount(..), - PageParams(..), - PageLinks(..), MediaType (..), Paths, IsPathPart(..), @@ -31,7 +29,6 @@ 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 @@ -77,10 +74,7 @@ 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 - | FetchPage PageParams +data FetchCount = FetchAtLeast !Word | FetchAll deriving (Eq, Ord, Read, Show, Generic, Typeable) @@ -102,37 +96,6 @@ 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 ------------------------------------------------------------------------------- diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs index 332d1124..c5eb006c 100644 --- a/src/GitHub/Request.hs +++ b/src/GitHub/Request.hs @@ -54,7 +54,6 @@ module GitHub.Request ( ParseResponse (..), makeHttpRequest, parseStatus, - parsePageLinks, StatusMap, getNextUrl, performPagedRequest, @@ -80,7 +79,6 @@ 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) @@ -89,14 +87,13 @@ import Network.HTTP.Client httpLbs, method, newManager, redirectCount, requestBody, requestHeaders, setQueryString, setRequestIgnoreStatus) import Network.HTTP.Link.Parser (parseLinkHeaderBS) -import Network.HTTP.Link.Types (Link(..), LinkParam (..), href, linkParams) +import Network.HTTP.Link.Types (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 @@ -202,6 +199,11 @@ 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) @@ -233,13 +235,10 @@ executeRequestWithMgrAndRes mgr auth req = runExceptT $ do res <- httpLbs' httpReq (<$ res) <$> unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) - 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 (PagedQuery _ _ l) = + unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b))) + where + predicate v = lessFetchCount (length v) l performHttpReq httpReq (Command _ _ _) = do res <- httpLbs' httpReq @@ -457,7 +456,7 @@ makeHttpRequest auth r = case r of $ setReqHeaders . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) . maybe id setAuthRequest auth - . setQueryString (qs <> extraQueryItems) + . setQueryString qs $ req PagedQuery paths qs _ -> do req <- parseUrl' $ url paths @@ -465,7 +464,7 @@ makeHttpRequest auth r = case r of $ setReqHeaders . unTagged (modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)) . maybe id setAuthRequest auth - . setQueryString (qs <> extraQueryItems) + . setQueryString qs $ req Command m paths body -> do req <- parseUrl' $ url paths @@ -497,14 +496,6 @@ 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 @@ -551,35 +542,6 @@ 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 -------------------------------------------------------------------------------