{-# LANGUAGE CPP                    #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE UndecidableInstances   #-}
-----------------------------------------------------------------------------
-- |
-- License     :  BSD-3-Clause
-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>
--
-- This module provides data types and helper methods, which makes possible
-- to build alternative API request intepreters in addition to provided
-- 'IO' functions.
--
-- Simple example using @operational@ package. See @samples\/Operational\/Operational.hs@
--
-- > type GithubMonad a = Program (GH.Request 'False) a
-- >
-- > -- | Intepret GithubMonad value into IO
-- > runMonad :: Manager -> GH.Auth -> GithubMonad a -> ExceptT GH.Error IO a
-- > runMonad mgr auth m = case view m of
-- >    Return a   -> return a
-- >    req :>>= k -> do
-- >        b <- ExceptT $ GH.executeRequestWithMgr mgr auth req
-- >        runMonad mgr auth (k b)
-- >
-- > -- | Lift request into Monad
-- > githubRequest :: GH.Request 'False a -> GithubMonad a
-- > githubRequest = singleton
module GitHub.Request (
    -- * A convenient execution of requests
    github,
    github',
    GitHubRW,
    GitHubRO,
    -- * Types
    Request,
    GenRequest (..),
    CommandMethod(..),
    toMethod,
    Paths,
    QueryString,
    -- * Request execution in IO
    executeRequest,
    executeRequestWithMgr,
    executeRequestWithMgrAndRes,
    executeRequest',
    executeRequestWithMgr',
    executeRequestMaybe,
    unsafeDropAuthRequirements,
    -- * Helpers
    Accept (..),
    ParseResponse (..),
    makeHttpRequest,
    parseStatus,
    StatusMap,
    getNextUrl,
    performPagedRequest,
    parseResponseJSON,
    -- ** Preview
    PreviewAccept (..),
    PreviewParseResponse (..),
    -- * SSL
    -- | This always exist, independently of @openssl@ configuration flag.
    -- They change accordingly, to make use of the library simpler.
    withOpenSSL,
    tlsManagerSettings,
    ) where

import GitHub.Internal.Prelude
import Prelude ()

import Control.Monad.Error.Class (MonadError (..))

import Control.Monad              (when)
import Control.Monad.Catch        (MonadCatch (..), MonadThrow)
import Control.Monad.Trans.Class  (lift)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Data.Aeson                 (eitherDecode)
import Data.List                  (find)
import Data.Tagged                (Tagged (..))
import Data.Version               (showVersion)

import Network.HTTP.Client
       (HttpException (..), Manager, RequestBody (..), Response (..), getUri,
       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.Types       (Method, RequestHeaders, Status (..))
import Network.URI
       (URI, escapeURIString, isUnescapedInURIComponent, parseURIReference,
       relativeTo)

import qualified Data.ByteString              as BS
import qualified Data.ByteString.Lazy         as LBS
import qualified Data.Text                    as T
import qualified Data.Text.Encoding           as TE
import qualified Network.HTTP.Client          as HTTP
import qualified Network.HTTP.Client.Internal as HTTP

#ifdef MIN_VERSION_http_client_tls
import Network.HTTP.Client.TLS (tlsManagerSettings)
#else
import Network.HTTP.Client.OpenSSL (opensslManagerSettings, withOpenSSL)

import qualified OpenSSL.Session          as SSL
import qualified OpenSSL.X509.SystemStore as SSL
#endif

import GitHub.Auth              (AuthMethod, endpoint, setAuthRequest)
import GitHub.Data              (Error (..))
import GitHub.Data.PullRequests (MergeResult (..))
import GitHub.Data.Request

import Paths_github (version)

-------------------------------------------------------------------------------
-- Convenience
-------------------------------------------------------------------------------

-- | A convenience function to turn functions returning @'Request' rw x@,
-- into functions returning @IO (Either 'Error' x)@.
--
-- >>> :t \auth -> github auth userInfoForR
-- \auth -> github auth userInfoForR
--   :: AuthMethod am => am -> Name User -> IO (Either Error User)
--
-- >>> :t github pullRequestsForR
-- \auth -> github auth pullRequestsForR
--   :: AuthMethod am =>
--      am
--      -> Name Owner
--      -> Name Repo
--      -> PullRequestMod
--      -> FetchCount
--      -> IO (Either Error (Data.Vector.Vector SimplePullRequest))
--
github :: (AuthMethod am, GitHubRW req res) => am -> req -> res
github :: am -> req -> res
github = am -> req -> res
forall req res am.
(GitHubRW req res, AuthMethod am) =>
am -> req -> res
githubImpl

-- | Like 'github'' but for 'RO' i.e. read-only requests.
-- Note that GitHub has low request limit for non-authenticated requests.
--
-- >>> :t github' userInfoForR
-- github' userInfoForR :: Name User -> IO (Either Error User)
--
github' :: GitHubRO req res => req -> res
github' :: req -> res
github' = req -> res
forall req res. GitHubRO req res => req -> res
githubImpl'

-- | A type-class implementing 'github'.
class GitHubRW req res | req -> res where
    githubImpl :: AuthMethod am => am -> req -> res

-- | A type-class implementing 'github''.
class GitHubRO req res | req -> res where
    githubImpl' :: req -> res

instance (ParseResponse mt req, res ~ Either Error req) => GitHubRW (GenRequest mt rw req) (IO res) where
    githubImpl :: am -> GenRequest mt rw req -> IO res
githubImpl = am -> GenRequest mt rw req -> IO res
forall am (mt :: MediaType *) a (rw :: RW).
(AuthMethod am, ParseResponse mt a) =>
am -> GenRequest mt rw a -> IO (Either Error a)
executeRequest

instance (ParseResponse mt req, res ~ Either Error req, rw ~ 'RO) => GitHubRO (GenRequest mt rw req) (IO res) where
    githubImpl' :: GenRequest mt rw req -> IO res
githubImpl' = GenRequest mt rw req -> IO res
forall (mt :: MediaType *) a.
ParseResponse mt a =>
GenRequest mt 'RO a -> IO (Either Error a)
executeRequest'

instance GitHubRW req res => GitHubRW (a -> req) (a -> res) where
    githubImpl :: am -> (a -> req) -> a -> res
githubImpl am
am a -> req
req a
x = am -> req -> res
forall req res am.
(GitHubRW req res, AuthMethod am) =>
am -> req -> res
githubImpl am
am (a -> req
req a
x)

instance GitHubRO req res => GitHubRO (a -> req) (a -> res) where
    githubImpl' :: (a -> req) -> a -> res
githubImpl' a -> req
req a
x = req -> res
forall req res. GitHubRO req res => req -> res
githubImpl' (a -> req
req a
x)

-------------------------------------------------------------------------------
-- Execution
-------------------------------------------------------------------------------

#ifdef MIN_VERSION_http_client_tls
withOpenSSL :: IO a -> IO a
withOpenSSL :: IO a -> IO a
withOpenSSL = IO a -> IO a
forall a. a -> a
id
#else
tlsManagerSettings :: HTTP.ManagerSettings
tlsManagerSettings = opensslManagerSettings $ do
    ctx <- SSL.context
    SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2
    SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3
    SSL.contextAddOption ctx SSL.SSL_OP_NO_TLSv1
    SSL.contextSetCiphers ctx "ECDHE-ECDSA-AES256-GCM-SHA384:ECDHE-RSA-AES256-GCM-SHA384:ECDHE-ECDSA-CHACHA20-POLY1305:ECDHE-RSA-CHACHA20-POLY1305:ECDHE-ECDSA-AES128-GCM-SHA256:ECDHE-RSA-AES128-GCM-SHA256:ECDHE-ECDSA-AES256-SHA384:ECDHE-RSA-AES256-SHA384:ECDHE-ECDSA-AES128-SHA256:ECDHE-RSA-AES128-SHA256"
    SSL.contextLoadSystemCerts ctx
    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing
    return ctx
#endif

-- | Execute 'Request' in 'IO'
executeRequest
    :: (AuthMethod am, ParseResponse mt a)
    => am
    -> GenRequest mt rw a
    -> IO (Either Error a)
executeRequest :: am -> GenRequest mt rw a -> IO (Either Error a)
executeRequest am
auth GenRequest mt rw a
req = IO (Either Error a) -> IO (Either Error a)
forall a. IO a -> IO a
withOpenSSL (IO (Either Error a) -> IO (Either Error a))
-> IO (Either Error a) -> IO (Either Error a)
forall a b. (a -> b) -> a -> b
$ do
    Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    Manager -> am -> GenRequest mt rw a -> IO (Either Error a)
forall am (mt :: MediaType *) a (rw :: RW).
(AuthMethod am, ParseResponse mt a) =>
Manager -> am -> GenRequest mt rw a -> IO (Either Error a)
executeRequestWithMgr Manager
manager am
auth GenRequest mt rw a
req

lessFetchCount :: Int -> FetchCount -> Bool
lessFetchCount :: Int -> FetchCount -> Bool
lessFetchCount Int
_ FetchCount
FetchAll         = Bool
True
lessFetchCount Int
i (FetchAtLeast Word
j) = Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
j


-- | Like 'executeRequest' but with provided 'Manager'.
executeRequestWithMgr
    :: (AuthMethod am, ParseResponse mt a)
    => Manager
    -> am
    -> GenRequest mt rw a
    -> IO (Either Error a)
executeRequestWithMgr :: Manager -> am -> GenRequest mt rw a -> IO (Either Error a)
executeRequestWithMgr Manager
mgr am
auth GenRequest mt rw a
req =
    (Either Error (Response a) -> Either Error a)
-> IO (Either Error (Response a)) -> IO (Either Error a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Response a -> a) -> Either Error (Response a) -> Either Error a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response a -> a
forall body. Response body -> body
responseBody) (Manager
-> am -> GenRequest mt rw a -> IO (Either Error (Response a))
forall am (mt :: MediaType *) a (rw :: RW).
(AuthMethod am, ParseResponse mt a) =>
Manager
-> am -> GenRequest mt rw a -> IO (Either Error (Response a))
executeRequestWithMgrAndRes Manager
mgr am
auth GenRequest mt rw a
req)

-- | Execute request and return the last received 'HTTP.Response'.
--
-- @since 0.24
executeRequestWithMgrAndRes
    :: (AuthMethod am, ParseResponse mt a)
    => Manager
    -> am
    -> GenRequest mt rw a
    -> IO (Either Error (HTTP.Response a))
executeRequestWithMgrAndRes :: Manager
-> am -> GenRequest mt rw a -> IO (Either Error (Response a))
executeRequestWithMgrAndRes Manager
mgr am
auth GenRequest mt rw a
req = ExceptT Error IO (Response a) -> IO (Either Error (Response a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Error IO (Response a) -> IO (Either Error (Response a)))
-> ExceptT Error IO (Response a) -> IO (Either Error (Response a))
forall a b. (a -> b) -> a -> b
$ do
    Request
httpReq <- Maybe am -> GenRequest mt rw a -> ExceptT Error IO Request
forall am (mt :: MediaType *) (rw :: RW) a (m :: * -> *).
(AuthMethod am, MonadThrow m, Accept mt) =>
Maybe am -> GenRequest mt rw a -> m Request
makeHttpRequest (am -> Maybe am
forall a. a -> Maybe a
Just am
auth) GenRequest mt rw a
req
    Request -> GenRequest mt rw a -> ExceptT Error IO (Response a)
forall (rw :: RW) (mt :: MediaType *) b.
ParseResponse mt b =>
Request -> GenRequest mt rw b -> ExceptT Error IO (Response b)
performHttpReq Request
httpReq GenRequest mt rw a
req
  where
    httpLbs' :: HTTP.Request -> ExceptT Error IO (HTTP.Response LBS.ByteString)
    httpLbs' :: Request -> ExceptT Error IO (Response ByteString)
httpLbs' Request
req' = IO (Response ByteString) -> ExceptT Error IO (Response ByteString)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Request -> Manager -> IO (Response ByteString)
httpLbs Request
req' Manager
mgr) ExceptT Error IO (Response ByteString)
-> (HttpException -> ExceptT Error IO (Response ByteString))
-> ExceptT Error IO (Response ByteString)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` HttpException -> ExceptT Error IO (Response ByteString)
forall (m :: * -> *) a. MonadError Error m => HttpException -> m a
onHttpException

    performHttpReq :: forall rw mt b. ParseResponse mt b => HTTP.Request -> GenRequest mt rw b -> ExceptT Error IO (HTTP.Response b)
    performHttpReq :: Request -> GenRequest mt rw b -> ExceptT Error IO (Response b)
performHttpReq Request
httpReq Query {} = do
        Response ByteString
res <- Request -> ExceptT Error IO (Response ByteString)
httpLbs' Request
httpReq
        (b -> Response ByteString -> Response b
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Response ByteString
res) (b -> Response b)
-> ExceptT Error IO b -> ExceptT Error IO (Response b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged mt (ExceptT Error IO b) -> ExceptT Error IO b
forall k (s :: k) b. Tagged s b -> b
unTagged (Request -> Response ByteString -> Tagged mt (ExceptT Error IO b)
forall (mt :: MediaType *) a (m :: * -> *).
(ParseResponse mt a, MonadError Error m) =>
Request -> Response ByteString -> Tagged mt (m a)
parseResponse Request
httpReq Response ByteString
res :: Tagged mt (ExceptT Error IO b))

    performHttpReq Request
httpReq (PagedQuery Paths
_ QueryString
_ FetchCount
l) =
        Tagged mt (ExceptT Error IO (Response b))
-> ExceptT Error IO (Response b)
forall k (s :: k) b. Tagged s b -> b
unTagged ((Request -> ExceptT Error IO (Response ByteString))
-> (t b -> Bool)
-> Request
-> Tagged mt (ExceptT Error IO (Response (t b)))
forall a (m :: * -> *) (mt :: MediaType *).
(ParseResponse mt a, Semigroup a, MonadCatch m,
 MonadError Error m) =>
(Request -> m (Response ByteString))
-> (a -> Bool) -> Request -> Tagged mt (m (Response a))
performPagedRequest Request -> ExceptT Error IO (Response ByteString)
httpLbs' t b -> Bool
predicate Request
httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b)))
      where
        predicate :: t b -> Bool
predicate t b
v = Int -> FetchCount -> Bool
lessFetchCount (t b -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t b
v) FetchCount
l

    performHttpReq Request
httpReq (Command CommandMethod
_ Paths
_ ByteString
_) = do
        Response ByteString
res <- Request -> ExceptT Error IO (Response ByteString)
httpLbs' Request
httpReq
        (b -> Response ByteString -> Response b
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Response ByteString
res) (b -> Response b)
-> ExceptT Error IO b -> ExceptT Error IO (Response b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged mt (ExceptT Error IO b) -> ExceptT Error IO b
forall k (s :: k) b. Tagged s b -> b
unTagged (Request -> Response ByteString -> Tagged mt (ExceptT Error IO b)
forall (mt :: MediaType *) a (m :: * -> *).
(ParseResponse mt a, MonadError Error m) =>
Request -> Response ByteString -> Tagged mt (m a)
parseResponse Request
httpReq Response ByteString
res :: Tagged mt (ExceptT Error IO b))

-- | Like 'executeRequest' but without authentication.
executeRequest' :: ParseResponse mt a => GenRequest mt 'RO a -> IO (Either Error a)
executeRequest' :: GenRequest mt 'RO a -> IO (Either Error a)
executeRequest' GenRequest mt 'RO a
req = IO (Either Error a) -> IO (Either Error a)
forall a. IO a -> IO a
withOpenSSL (IO (Either Error a) -> IO (Either Error a))
-> IO (Either Error a) -> IO (Either Error a)
forall a b. (a -> b) -> a -> b
$ do
    Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    Manager -> GenRequest mt 'RO a -> IO (Either Error a)
forall (mt :: MediaType *) a.
ParseResponse mt a =>
Manager -> GenRequest mt 'RO a -> IO (Either Error a)
executeRequestWithMgr' Manager
manager GenRequest mt 'RO a
req

-- | Like 'executeRequestWithMgr' but without authentication.
executeRequestWithMgr'
    :: ParseResponse mt a
    => Manager
    -> GenRequest mt 'RO a
    -> IO (Either Error a)
executeRequestWithMgr' :: Manager -> GenRequest mt 'RO a -> IO (Either Error a)
executeRequestWithMgr' Manager
mgr = Manager -> () -> GenRequest mt 'RO a -> IO (Either Error a)
forall am (mt :: MediaType *) a (rw :: RW).
(AuthMethod am, ParseResponse mt a) =>
Manager -> am -> GenRequest mt rw a -> IO (Either Error a)
executeRequestWithMgr Manager
mgr ()

-- | Helper for picking between 'executeRequest' and 'executeRequest''.
--
-- The use is discouraged.
executeRequestMaybe
    :: (AuthMethod am, ParseResponse mt a)
    => Maybe am
    -> GenRequest mt 'RO a
    -> IO (Either Error a)
executeRequestMaybe :: Maybe am -> GenRequest mt 'RO a -> IO (Either Error a)
executeRequestMaybe = (GenRequest mt 'RO a -> IO (Either Error a))
-> (am -> GenRequest mt 'RO a -> IO (Either Error a))
-> Maybe am
-> GenRequest mt 'RO a
-> IO (Either Error a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GenRequest mt 'RO a -> IO (Either Error a)
forall (mt :: MediaType *) a.
ParseResponse mt a =>
GenRequest mt 'RO a -> IO (Either Error a)
executeRequest' am -> GenRequest mt 'RO a -> IO (Either Error a)
forall am (mt :: MediaType *) a (rw :: RW).
(AuthMethod am, ParseResponse mt a) =>
am -> GenRequest mt rw a -> IO (Either Error a)
executeRequest

-- | Partial function to drop authentication need.
unsafeDropAuthRequirements :: GenRequest mt rw' a -> GenRequest mt rw a
unsafeDropAuthRequirements :: GenRequest mt rw' a -> GenRequest mt rw a
unsafeDropAuthRequirements (Query Paths
ps QueryString
qs) = Paths -> QueryString -> GenRequest mt rw a
forall (mt :: MediaType *) (rw :: RW) a.
Paths -> QueryString -> GenRequest mt rw a
Query Paths
ps QueryString
qs
unsafeDropAuthRequirements GenRequest mt rw' a
r             =
    [Char] -> GenRequest mt rw a
forall a. HasCallStack => [Char] -> a
error ([Char] -> GenRequest mt rw a) -> [Char] -> GenRequest mt rw a
forall a b. (a -> b) -> a -> b
$ [Char]
"Trying to drop authenatication from" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenRequest mt rw' a -> [Char]
forall a. Show a => a -> [Char]
show GenRequest mt rw' a
r

-------------------------------------------------------------------------------
-- Parse response
-------------------------------------------------------------------------------

class Accept (mt :: MediaType *) where
    contentType :: Tagged mt BS.ByteString
    contentType = ByteString -> Tagged mt ByteString
forall k (s :: k) b. b -> Tagged s b
Tagged ByteString
"application/json" -- default is JSON

    modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)
    modifyRequest = (Request -> Request) -> Tagged mt (Request -> Request)
forall k (s :: k) b. b -> Tagged s b
Tagged Request -> Request
forall a. a -> a
id

class Accept mt => ParseResponse (mt :: MediaType *) a where
    parseResponse
        :: MonadError Error m
        => HTTP.Request -> HTTP.Response LBS.ByteString
        -> Tagged mt (m a)

-------------------------------------------------------------------------------
-- JSON (+ star)
-------------------------------------------------------------------------------

-- | Parse API response.
--
-- @
-- parseResponse :: 'FromJSON' a => 'HTTP.Response' 'LBS.ByteString' -> 'Either' 'Error' a
-- @
parseResponseJSON :: (FromJSON a, MonadError Error m) => HTTP.Response LBS.ByteString -> m a
parseResponseJSON :: Response ByteString -> m a
parseResponseJSON Response ByteString
res = case ByteString -> Either [Char] a
forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res) of
    Right a
x  -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    Left [Char]
err -> Error -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> m a) -> ([Char] -> Error) -> [Char] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error
ParseError (Text -> Error) -> ([Char] -> Text) -> [Char] -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char]
err

instance Accept 'MtJSON where
    contentType :: Tagged 'MtJSON ByteString
contentType = ByteString -> Tagged 'MtJSON ByteString
forall k (s :: k) b. b -> Tagged s b
Tagged ByteString
"application/vnd.github.v3+json"

instance FromJSON a => ParseResponse 'MtJSON a where
    parseResponse :: Request -> Response ByteString -> Tagged 'MtJSON (m a)
parseResponse Request
_ Response ByteString
res = m a -> Tagged 'MtJSON (m a)
forall k (s :: k) b. b -> Tagged s b
Tagged (Response ByteString -> m a
forall a (m :: * -> *).
(FromJSON a, MonadError Error m) =>
Response ByteString -> m a
parseResponseJSON Response ByteString
res)

instance Accept 'MtStar where
    contentType :: Tagged 'MtStar ByteString
contentType = ByteString -> Tagged 'MtStar ByteString
forall k (s :: k) b. b -> Tagged s b
Tagged ByteString
"application/vnd.github.v3.star+json"

instance FromJSON a => ParseResponse 'MtStar a where
    parseResponse :: Request -> Response ByteString -> Tagged 'MtStar (m a)
parseResponse Request
_ Response ByteString
res = m a -> Tagged 'MtStar (m a)
forall k (s :: k) b. b -> Tagged s b
Tagged (Response ByteString -> m a
forall a (m :: * -> *).
(FromJSON a, MonadError Error m) =>
Response ByteString -> m a
parseResponseJSON Response ByteString
res)

-------------------------------------------------------------------------------
-- Raw / Diff / Patch / Sha
-------------------------------------------------------------------------------

instance Accept 'MtRaw   where contentType :: Tagged 'MtRaw ByteString
contentType = ByteString -> Tagged 'MtRaw ByteString
forall k (s :: k) b. b -> Tagged s b
Tagged ByteString
"application/vnd.github.v3.raw"
instance Accept 'MtDiff  where contentType :: Tagged 'MtDiff ByteString
contentType = ByteString -> Tagged 'MtDiff ByteString
forall k (s :: k) b. b -> Tagged s b
Tagged ByteString
"application/vnd.github.v3.diff"
instance Accept 'MtPatch where contentType :: Tagged 'MtPatch ByteString
contentType = ByteString -> Tagged 'MtPatch ByteString
forall k (s :: k) b. b -> Tagged s b
Tagged ByteString
"application/vnd.github.v3.patch"
instance Accept 'MtSha   where contentType :: Tagged 'MtSha ByteString
contentType = ByteString -> Tagged 'MtSha ByteString
forall k (s :: k) b. b -> Tagged s b
Tagged ByteString
"application/vnd.github.v3.sha"

instance a ~ LBS.ByteString => ParseResponse 'MtRaw   a where parseResponse :: Request -> Response ByteString -> Tagged 'MtRaw (m a)
parseResponse Request
_ = m a -> Tagged 'MtRaw (m a)
forall k (s :: k) b. b -> Tagged s b
Tagged (m a -> Tagged 'MtRaw (m a))
-> (Response a -> m a) -> Response a -> Tagged 'MtRaw (m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> (Response a -> a) -> Response a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> a
forall body. Response body -> body
responseBody
instance a ~ LBS.ByteString => ParseResponse 'MtDiff  a where parseResponse :: Request -> Response ByteString -> Tagged 'MtDiff (m a)
parseResponse Request
_ = m a -> Tagged 'MtDiff (m a)
forall k (s :: k) b. b -> Tagged s b
Tagged (m a -> Tagged 'MtDiff (m a))
-> (Response a -> m a) -> Response a -> Tagged 'MtDiff (m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> (Response a -> a) -> Response a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> a
forall body. Response body -> body
responseBody
instance a ~ LBS.ByteString => ParseResponse 'MtPatch a where parseResponse :: Request -> Response ByteString -> Tagged 'MtPatch (m a)
parseResponse Request
_ = m a -> Tagged 'MtPatch (m a)
forall k (s :: k) b. b -> Tagged s b
Tagged (m a -> Tagged 'MtPatch (m a))
-> (Response a -> m a) -> Response a -> Tagged 'MtPatch (m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> (Response a -> a) -> Response a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> a
forall body. Response body -> body
responseBody
instance a ~ LBS.ByteString => ParseResponse 'MtSha   a where parseResponse :: Request -> Response ByteString -> Tagged 'MtSha (m a)
parseResponse Request
_ = m a -> Tagged 'MtSha (m a)
forall k (s :: k) b. b -> Tagged s b
Tagged (m a -> Tagged 'MtSha (m a))
-> (Response a -> m a) -> Response a -> Tagged 'MtSha (m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> (Response a -> a) -> Response a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> a
forall body. Response body -> body
responseBody

-------------------------------------------------------------------------------
-- Redirect
-------------------------------------------------------------------------------

instance Accept 'MtRedirect where
    modifyRequest :: Tagged 'MtRedirect (Request -> Request)
modifyRequest = (Request -> Request) -> Tagged 'MtRedirect (Request -> Request)
forall k (s :: k) b. b -> Tagged s b
Tagged ((Request -> Request) -> Tagged 'MtRedirect (Request -> Request))
-> (Request -> Request) -> Tagged 'MtRedirect (Request -> Request)
forall a b. (a -> b) -> a -> b
$ \Request
req ->
        Request -> Request
setRequestIgnoreStatus (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
req { redirectCount :: Int
redirectCount = Int
0 }

instance b ~ URI => ParseResponse 'MtRedirect b where
    parseResponse :: Request -> Response ByteString -> Tagged 'MtRedirect (m b)
parseResponse Request
req = m URI -> Tagged 'MtRedirect (m URI)
forall k (s :: k) b. b -> Tagged s b
Tagged (m URI -> Tagged 'MtRedirect (m URI))
-> (Response ByteString -> m URI)
-> Response ByteString
-> Tagged 'MtRedirect (m URI)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Response ByteString -> m URI
forall (m :: * -> *).
MonadError Error m =>
URI -> Response ByteString -> m URI
parseRedirect (Request -> URI
getUri Request
req)

-- | Helper for handling of 'RequestRedirect'.
--
-- @
-- parseRedirect :: 'HTTP.Response' 'LBS.ByteString' -> 'Either' 'Error' a
-- @
parseRedirect :: MonadError Error m => URI -> HTTP.Response LBS.ByteString -> m URI
parseRedirect :: URI -> Response ByteString -> m URI
parseRedirect URI
originalUri Response ByteString
rsp = do
    let status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
rsp
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Int
statusCode Status
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
302) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Error -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> m ()) -> Error -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Error
ParseError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"invalid status: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Status -> [Char]
forall a. Show a => a -> [Char]
show Status
status)
    ByteString
loc <- m ByteString
-> (ByteString -> m ByteString) -> Maybe ByteString -> m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ByteString
forall a. m a
noLocation ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> m ByteString)
-> Maybe ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ByteString
rsp
    case [Char] -> Maybe URI
parseURIReference ([Char] -> Maybe URI) -> [Char] -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 ByteString
loc of
        Maybe URI
Nothing -> Error -> m URI
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> m URI) -> Error -> m URI
forall a b. (a -> b) -> a -> b
$ Text -> Error
ParseError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$
            Text
"location header does not contain a URI: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
loc)
        Just URI
uri -> URI -> m URI
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> m URI) -> URI -> m URI
forall a b. (a -> b) -> a -> b
$ URI
uri URI -> URI -> URI
`relativeTo` URI
originalUri
  where
    noLocation :: m a
noLocation = Error -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> m a) -> Error -> m a
forall a b. (a -> b) -> a -> b
$ Text -> Error
ParseError Text
"no location header in response"

-------------------------------------------------------------------------------
-- Extension point
-------------------------------------------------------------------------------

class PreviewAccept p where
    previewContentType :: Tagged ('MtPreview p) BS.ByteString

    previewModifyRequest :: Tagged ('MtPreview p) (HTTP.Request -> HTTP.Request)
    previewModifyRequest = (Request -> Request) -> Tagged ('MtPreview p) (Request -> Request)
forall k (s :: k) b. b -> Tagged s b
Tagged Request -> Request
forall a. a -> a
id

class PreviewAccept p => PreviewParseResponse p a where
    previewParseResponse
        :: MonadError Error m
        => HTTP.Request -> HTTP.Response LBS.ByteString
        -> Tagged ('MtPreview p) (m a)

instance PreviewAccept p => Accept ('MtPreview p) where
    contentType :: Tagged ('MtPreview p) ByteString
contentType   = Tagged ('MtPreview p) ByteString
forall p. PreviewAccept p => Tagged ('MtPreview p) ByteString
previewContentType
    modifyRequest :: Tagged ('MtPreview p) (Request -> Request)
modifyRequest = Tagged ('MtPreview p) (Request -> Request)
forall p.
PreviewAccept p =>
Tagged ('MtPreview p) (Request -> Request)
previewModifyRequest

instance PreviewParseResponse p a => ParseResponse ('MtPreview p) a where
    parseResponse :: Request -> Response ByteString -> Tagged ('MtPreview p) (m a)
parseResponse = Request -> Response ByteString -> Tagged ('MtPreview p) (m a)
forall p a (m :: * -> *).
(PreviewParseResponse p a, MonadError Error m) =>
Request -> Response ByteString -> Tagged ('MtPreview p) (m a)
previewParseResponse

-------------------------------------------------------------------------------
-- Status
-------------------------------------------------------------------------------

instance Accept 'MtStatus where
    modifyRequest :: Tagged 'MtStatus (Request -> Request)
modifyRequest = (Request -> Request) -> Tagged 'MtStatus (Request -> Request)
forall k (s :: k) b. b -> Tagged s b
Tagged Request -> Request
setRequestIgnoreStatus

instance HasStatusMap a => ParseResponse 'MtStatus a where
    parseResponse :: Request -> Response ByteString -> Tagged 'MtStatus (m a)
parseResponse Request
_ = m a -> Tagged 'MtStatus (m a)
forall k (s :: k) b. b -> Tagged s b
Tagged (m a -> Tagged 'MtStatus (m a))
-> (Response ByteString -> m a)
-> Response ByteString
-> Tagged 'MtStatus (m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusMap a -> Status -> m a
forall (m :: * -> *) a.
MonadError Error m =>
StatusMap a -> Status -> m a
parseStatus StatusMap a
forall a. HasStatusMap a => StatusMap a
statusMap (Status -> m a)
-> (Response ByteString -> Status) -> Response ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> Status
forall body. Response body -> Status
responseStatus

type StatusMap a = [(Int, a)]

class HasStatusMap a where
    statusMap :: StatusMap a

instance HasStatusMap Bool where
    statusMap :: StatusMap Bool
statusMap =
        [ (Int
204, Bool
True)
        , (Int
404, Bool
False)
        ]

instance HasStatusMap MergeResult where
    statusMap :: StatusMap MergeResult
statusMap =
        [ (Int
200, MergeResult
MergeSuccessful)
        , (Int
405, MergeResult
MergeCannotPerform)
        , (Int
409, MergeResult
MergeConflict)
        ]

-- | Helper for handling of 'RequestStatus'.
--
-- @
-- parseStatus :: 'StatusMap' a -> 'Status' -> 'Either' 'Error' a
-- @
parseStatus :: MonadError Error m => StatusMap a -> Status -> m a
parseStatus :: StatusMap a -> Status -> m a
parseStatus StatusMap a
m (Status Int
sci ByteString
_) =
    m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
err a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m a) -> Maybe a -> m a
forall a b. (a -> b) -> a -> b
$ Int -> StatusMap a -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
sci StatusMap a
m
  where
    err :: m a
err = Error -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> m a) -> Error -> m a
forall a b. (a -> b) -> a -> b
$ Text -> Error
JsonError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> b
$ Text
"invalid status: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
sci)

-------------------------------------------------------------------------------
-- Unit
-------------------------------------------------------------------------------

-- | Note: we don't ignore response status.
--
-- We only accept any response body.
instance Accept 'MtUnit where

instance a ~ () => ParseResponse 'MtUnit a where
    parseResponse :: Request -> Response ByteString -> Tagged 'MtUnit (m a)
parseResponse Request
_ Response ByteString
_ = m () -> Tagged 'MtUnit (m ())
forall k (s :: k) b. b -> Tagged s b
Tagged (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

------------------------------------------------------------------------------
-- Tools
------------------------------------------------------------------------------

-- | Create @http-client@ 'Request'.
--
-- * for 'PagedQuery', the initial request is created.
-- * for 'Status', the 'Request' for underlying 'Request' is created,
--   status checking is modifying accordingly.
--
makeHttpRequest
    :: forall am mt rw a m. (AuthMethod am, MonadThrow m, Accept mt)
    => Maybe am
    -> GenRequest mt rw a
    -> m HTTP.Request
makeHttpRequest :: Maybe am -> GenRequest mt rw a -> m Request
makeHttpRequest Maybe am
auth GenRequest mt rw a
r = case GenRequest mt rw a
r of
    Query Paths
paths QueryString
qs -> do
        Request
req <- [Char] -> m Request
MonadThrow m => [Char] -> m Request
parseUrl' ([Char] -> m Request) -> [Char] -> m Request
forall a b. (a -> b) -> a -> b
$ Paths -> [Char]
url Paths
paths
        Request -> m Request
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Request -> m Request) -> Request -> m Request
forall a b. (a -> b) -> a -> b
$ Request -> Request
setReqHeaders
            (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged mt (Request -> Request) -> Request -> Request
forall k (s :: k) b. Tagged s b -> b
unTagged (Tagged mt (Request -> Request)
forall (mt :: MediaType *).
Accept mt =>
Tagged mt (Request -> Request)
modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
            (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request -> Request)
-> (am -> Request -> Request) -> Maybe am -> Request -> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request -> Request
forall a. a -> a
id am -> Request -> Request
forall a. AuthMethod a => a -> Request -> Request
setAuthRequest Maybe am
auth
            (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryString -> Request -> Request
setQueryString QueryString
qs
            (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
req
    PagedQuery Paths
paths QueryString
qs FetchCount
_ -> do
        Request
req <- [Char] -> m Request
MonadThrow m => [Char] -> m Request
parseUrl' ([Char] -> m Request) -> [Char] -> m Request
forall a b. (a -> b) -> a -> b
$ Paths -> [Char]
url Paths
paths
        Request -> m Request
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Request -> m Request) -> Request -> m Request
forall a b. (a -> b) -> a -> b
$ Request -> Request
setReqHeaders
            (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged mt (Request -> Request) -> Request -> Request
forall k (s :: k) b. Tagged s b -> b
unTagged (Tagged mt (Request -> Request)
forall (mt :: MediaType *).
Accept mt =>
Tagged mt (Request -> Request)
modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
            (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request -> Request)
-> (am -> Request -> Request) -> Maybe am -> Request -> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request -> Request
forall a. a -> a
id am -> Request -> Request
forall a. AuthMethod a => a -> Request -> Request
setAuthRequest Maybe am
auth
            (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryString -> Request -> Request
setQueryString QueryString
qs
            (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
req
    Command CommandMethod
m Paths
paths ByteString
body -> do
        Request
req <- [Char] -> m Request
MonadThrow m => [Char] -> m Request
parseUrl' ([Char] -> m Request) -> [Char] -> m Request
forall a b. (a -> b) -> a -> b
$ Paths -> [Char]
url Paths
paths
        Request -> m Request
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Request -> m Request) -> Request -> m Request
forall a b. (a -> b) -> a -> b
$ Request -> Request
setReqHeaders
            (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged mt (Request -> Request) -> Request -> Request
forall k (s :: k) b. Tagged s b -> b
unTagged (Tagged mt (Request -> Request)
forall (mt :: MediaType *).
Accept mt =>
Tagged mt (Request -> Request)
modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
            (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request -> Request)
-> (am -> Request -> Request) -> Maybe am -> Request -> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request -> Request
forall a. a -> a
id am -> Request -> Request
forall a. AuthMethod a => a -> Request -> Request
setAuthRequest Maybe am
auth
            (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
setBody ByteString
body
            (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
setMethod (CommandMethod -> ByteString
toMethod CommandMethod
m)
            (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
req
  where
    parseUrl' :: MonadThrow m => String -> m HTTP.Request
    parseUrl' :: [Char] -> m Request
parseUrl' = [Char] -> m Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
HTTP.parseUrlThrow

    url :: Paths -> String
    url :: Paths -> [Char]
url Paths
paths = [Char] -> (Text -> [Char]) -> Maybe Text -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"https://api.github.com" Text -> [Char]
T.unpack (am -> Maybe Text
forall a. AuthMethod a => a -> Maybe Text
endpoint (am -> Maybe Text) -> Maybe am -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe am
auth) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"/" [[Char]]
paths' where
        paths' :: [[Char]]
paths' = (Text -> [Char]) -> Paths -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> [Char] -> [Char]
escapeURIString Char -> Bool
isUnescapedInURIComponent ([Char] -> [Char]) -> (Text -> [Char]) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) Paths
paths

    setReqHeaders :: HTTP.Request -> HTTP.Request
    setReqHeaders :: Request -> Request
setReqHeaders Request
req = Request
req { requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = [(HeaderName, ByteString)]
reqHeaders [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. Semigroup a => a -> a -> a
<> Request -> [(HeaderName, ByteString)]
requestHeaders Request
req }

    setMethod :: Method -> HTTP.Request -> HTTP.Request
    setMethod :: ByteString -> Request -> Request
setMethod ByteString
m Request
req = Request
req { method :: ByteString
method = ByteString
m }

    reqHeaders :: RequestHeaders
    reqHeaders :: [(HeaderName, ByteString)]
reqHeaders = [(HeaderName
"User-Agent", ByteString
"github.hs/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
showVersion Version
version))] -- Version
        [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. Semigroup a => a -> a -> a
<> [(HeaderName
"Accept", Tagged mt ByteString -> ByteString
forall k (s :: k) b. Tagged s b -> b
unTagged (Tagged mt ByteString
forall (mt :: MediaType *). Accept mt => Tagged mt ByteString
contentType :: Tagged mt BS.ByteString))]

    setBody :: LBS.ByteString -> HTTP.Request -> HTTP.Request
    setBody :: ByteString -> Request -> Request
setBody ByteString
body Request
req = Request
req { requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
body }

-- | Query @Link@ header with @rel=next@ from the request headers.
getNextUrl :: HTTP.Response a -> Maybe URI
getNextUrl :: Response a -> Maybe URI
getNextUrl Response a
req = do
    ByteString
linkHeader <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Link" (Response a -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response a
req)
    [Link URI]
links <- ByteString -> Maybe [Link URI]
forall uri. IsURI uri => ByteString -> Maybe [Link uri]
parseLinkHeaderBS ByteString
linkHeader
    Link URI
nextURI <- (Link URI -> Bool) -> [Link URI] -> Maybe (Link URI)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Link URI -> Bool
forall uri. Link uri -> Bool
isRelNext [Link URI]
links
    URI -> Maybe URI
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> Maybe URI) -> URI -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Link URI -> URI
forall uri. IsURI uri => Link uri -> uri
href Link URI
nextURI
  where
    -- isRelNext :: Link -> Bool or Link uri -> Bool
    isRelNext :: Link uri -> Bool
isRelNext = ((LinkParam, Text) -> Bool) -> [(LinkParam, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((LinkParam, Text) -> (LinkParam, Text) -> Bool
forall a. Eq a => a -> a -> Bool
== (LinkParam, Text)
relNextLinkParam) ([(LinkParam, Text)] -> Bool)
-> (Link uri -> [(LinkParam, Text)]) -> Link uri -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Link uri -> [(LinkParam, Text)]
forall uri. Link uri -> [(LinkParam, Text)]
linkParams

    relNextLinkParam :: (LinkParam, Text)
    relNextLinkParam :: (LinkParam, Text)
relNextLinkParam = (LinkParam
Rel, Text
"next")

-- | Helper for making paginated requests. Responses, @a@ are combined monoidally.
--
-- The result is wrapped in the last received 'HTTP.Response'.
--
-- @
-- performPagedRequest :: ('FromJSON' a, 'Semigroup' a)
--                     => ('HTTP.Request' -> 'ExceptT' 'Error' 'IO' ('HTTP.Response' 'LBS.ByteString'))
--                     -> (a -> 'Bool')
--                     -> 'HTTP.Request'
--                     -> 'ExceptT' 'Error' 'IO' ('HTTP.Response' a)
-- @
performPagedRequest
    :: forall a m mt. (ParseResponse mt a, Semigroup a, MonadCatch m, MonadError Error m)
    => (HTTP.Request -> m (HTTP.Response LBS.ByteString))  -- ^ `httpLbs` analogue
    -> (a -> Bool)                                         -- ^ predicate to continue iteration
    -> HTTP.Request                                        -- ^ initial request
    -> Tagged mt (m (HTTP.Response a))
performPagedRequest :: (Request -> m (Response ByteString))
-> (a -> Bool) -> Request -> Tagged mt (m (Response a))
performPagedRequest Request -> m (Response ByteString)
httpLbs' a -> Bool
predicate Request
initReq = m (Response a) -> Tagged mt (m (Response a))
forall k (s :: k) b. b -> Tagged s b
Tagged (m (Response a) -> Tagged mt (m (Response a)))
-> m (Response a) -> Tagged mt (m (Response a))
forall a b. (a -> b) -> a -> b
$ do
    Response ByteString
res <- Request -> m (Response ByteString)
httpLbs' Request
initReq
    a
m <- Tagged mt (m a) -> m a
forall k (s :: k) b. Tagged s b -> b
unTagged (Request -> Response ByteString -> Tagged mt (m a)
forall (mt :: MediaType *) a (m :: * -> *).
(ParseResponse mt a, MonadError Error m) =>
Request -> Response ByteString -> Tagged mt (m a)
parseResponse Request
initReq Response ByteString
res :: Tagged mt (m a))
    a -> Response ByteString -> Request -> m (Response a)
go a
m Response ByteString
res Request
initReq
  where
    go :: a -> HTTP.Response LBS.ByteString -> HTTP.Request -> m (HTTP.Response a)
    go :: a -> Response ByteString -> Request -> m (Response a)
go a
acc Response ByteString
res Request
req =
        case (a -> Bool
predicate a
acc, Response ByteString -> Maybe URI
forall a. Response a -> Maybe URI
getNextUrl Response ByteString
res) of
            (Bool
True, Just URI
uri) -> do
                Request
req' <- Request -> URI -> m Request
forall (m :: * -> *). MonadThrow m => Request -> URI -> m Request
HTTP.setUri Request
req URI
uri
                Response ByteString
res' <- Request -> m (Response ByteString)
httpLbs' Request
req'
                a
m <- Tagged mt (m a) -> m a
forall k (s :: k) b. Tagged s b -> b
unTagged (Request -> Response ByteString -> Tagged mt (m a)
forall (mt :: MediaType *) a (m :: * -> *).
(ParseResponse mt a, MonadError Error m) =>
Request -> Response ByteString -> Tagged mt (m a)
parseResponse Request
req' Response ByteString
res' :: Tagged mt (m a))
                a -> Response ByteString -> Request -> m (Response a)
go (a
acc a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
m) Response ByteString
res' Request
req'
            (Bool
_, Maybe URI
_)           -> Response a -> m (Response a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
acc a -> Response ByteString -> Response a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Response ByteString
res)

-------------------------------------------------------------------------------
-- Internal
-------------------------------------------------------------------------------

onHttpException :: MonadError Error m => HttpException -> m a
onHttpException :: HttpException -> m a
onHttpException = Error -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> m a) -> (HttpException -> Error) -> HttpException -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> Error
HTTPError