{-# LANGUAGE CPP                    #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE UndecidableInstances   #-}

-- |
-- 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 :: forall am req res.
(AuthMethod am, GitHubRW req res) =>
am -> req -> res
github = 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' :: forall req res. GitHubRO req res => req -> res
github' = 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 :: forall am. AuthMethod am => am -> GenRequest mt rw req -> IO res
githubImpl = 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' = 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 :: forall am. AuthMethod am => am -> (a -> req) -> a -> res
githubImpl am
am a -> req
req a
x = 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 = 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 :: forall a. IO a -> IO a
withOpenSSL = 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 :: forall am (mt :: MediaType (*)) a (rw :: RW).
(AuthMethod am, ParseResponse mt a) =>
am -> GenRequest mt rw a -> IO (Either Error a)
executeRequest am
auth GenRequest mt rw a
req = forall a. IO a -> IO a
withOpenSSL forall a b. (a -> b) -> a -> b
$ do
    Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    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 forall a. Ord a => a -> a -> Bool
< 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 :: 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 am
auth GenRequest mt rw a
req =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall body. Response body -> body
responseBody) (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 :: 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 = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    Request
httpReq <- forall am (mt :: MediaType (*)) (rw :: RW) a (m :: * -> *).
(AuthMethod am, MonadThrow m, Accept mt) =>
Maybe am -> GenRequest mt rw a -> m Request
makeHttpRequest (forall a. a -> Maybe a
Just am
auth) GenRequest mt rw a
req
    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' = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Request -> Manager -> IO (Response ByteString)
httpLbs Request
req' Manager
mgr) forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` 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 :: forall (rw :: RW) (mt :: MediaType (*)) b.
ParseResponse mt b =>
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
        (forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Response ByteString
res) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (s :: k) b. Tagged s b -> b
unTagged (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) =
        forall {k} (s :: k) b. Tagged s b -> b
unTagged (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 (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
        (forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Response ByteString
res) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (s :: k) b. Tagged s b -> b
unTagged (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' :: forall (mt :: MediaType (*)) a.
ParseResponse mt a =>
GenRequest mt 'RO a -> IO (Either Error a)
executeRequest' GenRequest mt 'RO a
req = forall a. IO a -> IO a
withOpenSSL forall a b. (a -> b) -> a -> b
$ do
    Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    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' :: forall (mt :: MediaType (*)) a.
ParseResponse mt a =>
Manager -> GenRequest mt 'RO a -> IO (Either Error a)
executeRequestWithMgr' Manager
mgr = 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 :: forall am (mt :: MediaType (*)) a.
(AuthMethod am, ParseResponse mt a) =>
Maybe am -> GenRequest mt 'RO a -> IO (Either Error a)
executeRequestMaybe = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (mt :: MediaType (*)) a.
ParseResponse mt a =>
GenRequest mt 'RO a -> IO (Either Error a)
executeRequest' 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 :: forall (mt :: MediaType (*)) (rw' :: RW) a (rw :: RW).
GenRequest mt rw' a -> GenRequest mt rw a
unsafeDropAuthRequirements (Query Paths
ps QueryString
qs) = forall (mt :: MediaType (*)) (rw :: RW) a.
Paths -> QueryString -> GenRequest mt rw a
Query Paths
ps QueryString
qs
unsafeDropAuthRequirements GenRequest mt rw' a
r             =
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Trying to drop authenatication from" forall a. [a] -> [a] -> [a]
++ 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 = forall {k} (s :: k) b. b -> Tagged s b
Tagged ByteString
"application/json" -- default is JSON

    modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request)
    modifyRequest = forall {k} (s :: k) b. b -> Tagged s b
Tagged 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 :: forall a (m :: * -> *).
(FromJSON a, MonadError Error m) =>
Response ByteString -> m a
parseResponseJSON Response ByteString
res = case forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode (forall body. Response body -> body
responseBody Response ByteString
res) of
    Right a
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    Left [Char]
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error
ParseError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
err

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

instance FromJSON a => ParseResponse 'MtJSON a where
    parseResponse :: forall (m :: * -> *).
MonadError Error m =>
Request -> Response ByteString -> Tagged 'MtJSON (m a)
parseResponse Request
_ Response ByteString
res = forall {k} (s :: k) b. b -> Tagged s b
Tagged (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 = 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 :: forall (m :: * -> *).
MonadError Error m =>
Request -> Response ByteString -> Tagged 'MtStar (m a)
parseResponse Request
_ Response ByteString
res = forall {k} (s :: k) b. b -> Tagged s b
Tagged (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 = 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 = 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 = 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 = 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 :: forall (m :: * -> *).
MonadError Error m =>
Request -> Response ByteString -> Tagged 'MtRaw (m a)
parseResponse Request
_ = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> body
responseBody
instance a ~ LBS.ByteString => ParseResponse 'MtDiff  a where parseResponse :: forall (m :: * -> *).
MonadError Error m =>
Request -> Response ByteString -> Tagged 'MtDiff (m a)
parseResponse Request
_ = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> body
responseBody
instance a ~ LBS.ByteString => ParseResponse 'MtPatch a where parseResponse :: forall (m :: * -> *).
MonadError Error m =>
Request -> Response ByteString -> Tagged 'MtPatch (m a)
parseResponse Request
_ = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> body
responseBody
instance a ~ LBS.ByteString => ParseResponse 'MtSha   a where parseResponse :: forall (m :: * -> *).
MonadError Error m =>
Request -> Response ByteString -> Tagged 'MtSha (m a)
parseResponse Request
_ = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> body
responseBody

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

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

instance b ~ URI => ParseResponse 'MtRedirect b where
    parseResponse :: forall (m :: * -> *).
MonadError Error m =>
Request -> Response ByteString -> Tagged 'MtRedirect (m b)
parseResponse Request
req = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *).
MonadError Error m =>
URI -> Response ByteString -> m URI
parseRedirect URI
originalUri Response ByteString
rsp = do
    let status :: Status
status = forall body. Response body -> Status
responseStatus Response ByteString
rsp
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Int
statusCode Status
status forall a. Eq a => a -> a -> Bool
/= Int
302) forall a b. (a -> b) -> a -> b
$
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Error
ParseError forall a b. (a -> b) -> a -> b
$ Text
"invalid status: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show Status
status)
    ByteString
loc <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. m a
noLocation forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Location" forall a b. (a -> b) -> a -> b
$ forall body. Response body -> ResponseHeaders
responseHeaders Response ByteString
rsp
    case [Char] -> Maybe URI
parseURIReference forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 ByteString
loc of
        Maybe URI
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Error
ParseError forall a b. (a -> b) -> a -> b
$
            Text
"location header does not contain a URI: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show ByteString
loc)
        Just URI
uri -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ URI
uri URI -> URI -> URI
`relativeTo` URI
originalUri
  where
    noLocation :: m a
noLocation = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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 = forall {k} (s :: k) b. b -> Tagged s b
Tagged 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   = forall p. PreviewAccept p => Tagged ('MtPreview p) ByteString
previewContentType
    modifyRequest :: Tagged ('MtPreview p) (Request -> Request)
modifyRequest = forall p.
PreviewAccept p =>
Tagged ('MtPreview p) (Request -> Request)
previewModifyRequest

instance PreviewParseResponse p a => ParseResponse ('MtPreview p) a where
    parseResponse :: forall (m :: * -> *).
MonadError Error m =>
Request -> Response ByteString -> Tagged ('MtPreview p) (m a)
parseResponse = 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 = forall {k} (s :: k) b. b -> Tagged s b
Tagged Request -> Request
setRequestIgnoreStatus

instance HasStatusMap a => ParseResponse 'MtStatus a where
    parseResponse :: forall (m :: * -> *).
MonadError Error m =>
Request -> Response ByteString -> Tagged 'MtStatus (m a)
parseResponse Request
_ = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadError Error m =>
StatusMap a -> Status -> m a
parseStatus forall a. HasStatusMap a => StatusMap a
statusMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *) a.
MonadError Error m =>
StatusMap a -> Status -> m a
parseStatus StatusMap a
m (Status Int
sci ByteString
_) =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
err forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
sci StatusMap a
m
  where
    err :: m a
err = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Error
JsonError forall a b. (a -> b) -> a -> b
$ Text
"invalid status: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (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 :: forall (m :: * -> *).
MonadError Error m =>
Request -> Response ByteString -> Tagged 'MtUnit (m a)
parseResponse Request
_ Response ByteString
_ = forall {k} (s :: k) b. b -> Tagged s b
Tagged (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 :: forall am (mt :: MediaType (*)) (rw :: RW) a (m :: * -> *).
(AuthMethod am, MonadThrow m, Accept mt) =>
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 <- MonadThrow m => [Char] -> m Request
parseUrl' forall a b. (a -> b) -> a -> b
$ Paths -> [Char]
url Paths
paths
        forall (m :: * -> *) a. Monad m => a -> m a
return
            forall a b. (a -> b) -> a -> b
$ Request -> Request
setReqHeaders
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (s :: k) b. Tagged s b -> b
unTagged (forall (mt :: MediaType (*)).
Accept mt =>
Tagged mt (Request -> Request)
modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. AuthMethod a => a -> Request -> Request
setAuthRequest Maybe am
auth
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryString -> Request -> Request
setQueryString QueryString
qs
            forall a b. (a -> b) -> a -> b
$ Request
req
    PagedQuery Paths
paths QueryString
qs FetchCount
_ -> do
        Request
req <- MonadThrow m => [Char] -> m Request
parseUrl' forall a b. (a -> b) -> a -> b
$ Paths -> [Char]
url Paths
paths
        forall (m :: * -> *) a. Monad m => a -> m a
return
            forall a b. (a -> b) -> a -> b
$ Request -> Request
setReqHeaders
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (s :: k) b. Tagged s b -> b
unTagged (forall (mt :: MediaType (*)).
Accept mt =>
Tagged mt (Request -> Request)
modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. AuthMethod a => a -> Request -> Request
setAuthRequest Maybe am
auth
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryString -> Request -> Request
setQueryString QueryString
qs
            forall a b. (a -> b) -> a -> b
$ Request
req
    Command CommandMethod
m Paths
paths ByteString
body -> do
        Request
req <- MonadThrow m => [Char] -> m Request
parseUrl' forall a b. (a -> b) -> a -> b
$ Paths -> [Char]
url Paths
paths
        forall (m :: * -> *) a. Monad m => a -> m a
return
            forall a b. (a -> b) -> a -> b
$ Request -> Request
setReqHeaders
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (s :: k) b. Tagged s b -> b
unTagged (forall (mt :: MediaType (*)).
Accept mt =>
Tagged mt (Request -> Request)
modifyRequest :: Tagged mt (HTTP.Request -> HTTP.Request))
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. AuthMethod a => a -> Request -> Request
setAuthRequest Maybe am
auth
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
setBody ByteString
body
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
setMethod (CommandMethod -> ByteString
toMethod CommandMethod
m)
            forall a b. (a -> b) -> a -> b
$ Request
req
  where
    parseUrl' :: MonadThrow m => String -> m HTTP.Request
    parseUrl' :: MonadThrow m => [Char] -> m Request
parseUrl' = forall (m :: * -> *). MonadThrow m => [Char] -> m Request
HTTP.parseUrlThrow

    url :: Paths -> String
    url :: Paths -> [Char]
url Paths
paths = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"https://api.github.com" Text -> [Char]
T.unpack (forall a. AuthMethod a => a -> Maybe Text
endpoint forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe am
auth) forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"/" [[Char]]
paths' where
        paths' :: [[Char]]
paths' = forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> [Char] -> [Char]
escapeURIString Char -> Bool
isUnescapedInURIComponent 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 :: ResponseHeaders
requestHeaders = ResponseHeaders
reqHeaders forall a. Semigroup a => a -> a -> a
<> Request -> ResponseHeaders
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 :: ResponseHeaders
reqHeaders = [(HeaderName
"User-Agent", ByteString
"github.hs/" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
showVersion Version
version))] -- Version
        forall a. Semigroup a => a -> a -> a
<> [(HeaderName
"Accept", forall {k} (s :: k) b. Tagged s b -> b
unTagged (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 :: forall a. Response a -> Maybe URI
getNextUrl Response a
req = do
    ByteString
linkHeader <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Link" (forall body. Response body -> ResponseHeaders
responseHeaders Response a
req)
    [Link URI]
links <- forall uri. IsURI uri => ByteString -> Maybe [Link uri]
parseLinkHeaderBS ByteString
linkHeader
    Link URI
nextURI <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find forall {uri}. Link uri -> Bool
isRelNext [Link URI]
links
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall uri. IsURI uri => Link uri -> uri
href Link URI
nextURI
  where
    -- isRelNext :: Link -> Bool or Link uri -> Bool
    isRelNext :: Link uri -> Bool
isRelNext = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== (LinkParam, Text)
relNextLinkParam) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: 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 -> m (Response ByteString)
httpLbs' a -> Bool
predicate Request
initReq = forall {k} (s :: k) b. b -> Tagged s b
Tagged forall a b. (a -> b) -> a -> b
$ do
    Response ByteString
res <- Request -> m (Response ByteString)
httpLbs' Request
initReq
    a
m <- forall {k} (s :: k) b. Tagged s b -> b
unTagged (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, forall a. Response a -> Maybe URI
getNextUrl Response ByteString
res) of
            (Bool
True, Just URI
uri) -> do
                Request
req' <- 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 <- forall {k} (s :: k) b. Tagged s b -> b
unTagged (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 forall a. Semigroup a => a -> a -> a
<> a
m) Response ByteString
res' Request
req'
            (Bool
_, Maybe URI
_)           -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
acc forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Response ByteString
res)

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

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