{-# LANGUAGE ExplicitForAll    #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}

-- | A simple http client to request OAuth2 tokens and several utils.

module Network.OAuth.OAuth2.HttpClient (
-- * Token management
  fetchAccessToken,
  fetchAccessToken2,
  refreshAccessToken,
  refreshAccessToken2,
  doSimplePostRequest,
-- * AUTH requests
  authGetJSON,
  authGetBS,
  authGetBS2,
  authPostJSON,
  authPostBS,
  authPostBS2,
  authPostBS3,
  authRequest
) where

import           Data.Aeson
import           Data.Bifunctor                    (first)
import qualified Data.ByteString.Char8             as BS
import qualified Data.ByteString.Lazy.Char8        as BSL
import qualified Data.HashMap.Strict               as HM (fromList)
import           Data.Maybe
import qualified Data.Text.Encoding                as T
import           Network.HTTP.Conduit
import qualified Network.HTTP.Types                as HT
import           Network.HTTP.Types.URI            (parseQuery)
import           Network.OAuth.OAuth2.Internal
import qualified Network.OAuth.OAuth2.TokenRequest as TR
import           URI.ByteString

--------------------------------------------------
-- * Token management
--------------------------------------------------

-- | Fetch OAuth2 Token with authenticate in request header.
--
-- OAuth2 spec allows `client_id` and `client_secret` to
-- either be sent in the header (as basic authentication)
-- OR as form/url params.
-- The OAuth server can choose to implement only one, or both.
-- Unfortunately, there is no way for the OAuth client (i.e. this library) to
-- know which method to use. Please take a look at the documentation of the
-- service that you are integrating with and either use `fetchAccessToken` or `fetchAccessToken2`
fetchAccessToken :: Manager                                   -- ^ HTTP connection manager
                   -> OAuth2                                  -- ^ OAuth Data
                   -> ExchangeToken                           -- ^ OAuth2 Code
                   -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token
fetchAccessToken :: Manager
-> OAuth2 -> ExchangeToken -> IO (OAuth2Result Errors OAuth2Token)
fetchAccessToken Manager
manager OAuth2
oa ExchangeToken
code = Manager
-> OAuth2
-> URI
-> PostBody
-> IO (OAuth2Result Errors OAuth2Token)
forall err a.
(FromJSON err, FromJSON a) =>
Manager -> OAuth2 -> URI -> PostBody -> IO (OAuth2Result err a)
doJSONPostRequest Manager
manager OAuth2
oa URI
uri PostBody
body
                           where (URI
uri, PostBody
body) = OAuth2 -> ExchangeToken -> (URI, PostBody)
accessTokenUrl OAuth2
oa ExchangeToken
code

-- | Please read the docs of `fetchAccessToken`.
--
fetchAccessToken2 :: Manager                                   -- ^ HTTP connection manager
                   -> OAuth2                                  -- ^ OAuth Data
                   -> ExchangeToken                           -- ^ OAuth 2 Tokens
                   -> IO (OAuth2Result TR.Errors OAuth2Token) -- ^ Access Token
fetchAccessToken2 :: Manager
-> OAuth2 -> ExchangeToken -> IO (OAuth2Result Errors OAuth2Token)
fetchAccessToken2 Manager
mgr OAuth2
oa ExchangeToken
code = do
  let (URI
url, PostBody
body1) = OAuth2 -> ExchangeToken -> (URI, PostBody)
accessTokenUrl OAuth2
oa ExchangeToken
code
  let secret :: Text -> [(a, ByteString)]
secret Text
x = [(a
"client_secret", Text -> ByteString
T.encodeUtf8 Text
x)]
  let extraBody :: PostBody
extraBody = (ByteString
"client_id", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauthClientId OAuth2
oa) (ByteString, ByteString) -> PostBody -> PostBody
forall a. a -> [a] -> [a]
: PostBody -> (Text -> PostBody) -> Maybe Text -> PostBody
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> PostBody
forall a. IsString a => Text -> [(a, ByteString)]
secret (OAuth2 -> Maybe Text
oauthClientSecret OAuth2
oa)
  Manager
-> OAuth2
-> URI
-> PostBody
-> IO (OAuth2Result Errors OAuth2Token)
forall err a.
(FromJSON err, FromJSON a) =>
Manager -> OAuth2 -> URI -> PostBody -> IO (OAuth2Result err a)
doJSONPostRequest Manager
mgr OAuth2
oa URI
url (PostBody
extraBody PostBody -> PostBody -> PostBody
forall a. [a] -> [a] -> [a]
++ PostBody
body1)

-- | Fetch a new AccessToken with the Refresh Token with authentication in request header.
-- OAuth2 spec allows `client_id` and `client_secret` to
-- either be sent in the header (as basic authentication)
-- OR as form/url params.
-- The OAuth server can choose to implement only one, or both.
-- Unfortunately, there is no way for the OAuth client (i.e. this library) to
-- know which method to use. Please take a look at the documentation of the
-- service that you are integrating with and either use `refreshAccessToken` or `refreshAccessToken2`
refreshAccessToken :: Manager                         -- ^ HTTP connection manager.
                     -> OAuth2                       -- ^ OAuth context
                     -> RefreshToken                 -- ^ refresh token gained after authorization
                     -> IO (OAuth2Result TR.Errors OAuth2Token)
refreshAccessToken :: Manager
-> OAuth2 -> RefreshToken -> IO (OAuth2Result Errors OAuth2Token)
refreshAccessToken Manager
manager OAuth2
oa RefreshToken
token = Manager
-> OAuth2
-> URI
-> PostBody
-> IO (OAuth2Result Errors OAuth2Token)
forall err a.
(FromJSON err, FromJSON a) =>
Manager -> OAuth2 -> URI -> PostBody -> IO (OAuth2Result err a)
doJSONPostRequest Manager
manager OAuth2
oa URI
uri PostBody
body
                              where (URI
uri, PostBody
body) = OAuth2 -> RefreshToken -> (URI, PostBody)
refreshAccessTokenUrl OAuth2
oa RefreshToken
token

-- | Please read the docs of `refreshAccessToken`.
--
refreshAccessToken2 :: Manager                         -- ^ HTTP connection manager.
                     -> OAuth2                       -- ^ OAuth context
                     -> RefreshToken                 -- ^ refresh token gained after authorization
                     -> IO (OAuth2Result TR.Errors OAuth2Token)
refreshAccessToken2 :: Manager
-> OAuth2 -> RefreshToken -> IO (OAuth2Result Errors OAuth2Token)
refreshAccessToken2 Manager
manager OAuth2
oa RefreshToken
token = do
  let (URI
uri, PostBody
body) = OAuth2 -> RefreshToken -> (URI, PostBody)
refreshAccessTokenUrl OAuth2
oa RefreshToken
token
  let secret :: Text -> [(a, ByteString)]
secret Text
x = [(a
"client_secret", Text -> ByteString
T.encodeUtf8 Text
x)]
  let extraBody :: PostBody
extraBody = (ByteString
"client_id", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauthClientId OAuth2
oa) (ByteString, ByteString) -> PostBody -> PostBody
forall a. a -> [a] -> [a]
: PostBody -> (Text -> PostBody) -> Maybe Text -> PostBody
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> PostBody
forall a. IsString a => Text -> [(a, ByteString)]
secret (OAuth2 -> Maybe Text
oauthClientSecret OAuth2
oa)
  Manager
-> OAuth2
-> URI
-> PostBody
-> IO (OAuth2Result Errors OAuth2Token)
forall err a.
(FromJSON err, FromJSON a) =>
Manager -> OAuth2 -> URI -> PostBody -> IO (OAuth2Result err a)
doJSONPostRequest Manager
manager OAuth2
oa URI
uri (PostBody
extraBody PostBody -> PostBody -> PostBody
forall a. [a] -> [a] -> [a]
++ PostBody
body)

-- | Conduct post request and return response as JSON.
doJSONPostRequest :: (FromJSON err, FromJSON a)
                  => Manager                             -- ^ HTTP connection manager.
                  -> OAuth2                              -- ^ OAuth options
                  -> URI                                 -- ^ The URL
                  -> PostBody                            -- ^ request body
                  -> IO (OAuth2Result err a)             -- ^ Response as JSON
doJSONPostRequest :: Manager -> OAuth2 -> URI -> PostBody -> IO (OAuth2Result err a)
doJSONPostRequest Manager
manager OAuth2
oa URI
uri PostBody
body = (OAuth2Result err ByteString -> OAuth2Result err a)
-> IO (OAuth2Result err ByteString) -> IO (OAuth2Result err a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OAuth2Result err ByteString -> OAuth2Result err a
forall err a.
(FromJSON err, FromJSON a) =>
OAuth2Result err ByteString -> OAuth2Result err a
parseResponseFlexible (Manager
-> OAuth2 -> URI -> PostBody -> IO (OAuth2Result err ByteString)
forall err.
FromJSON err =>
Manager
-> OAuth2 -> URI -> PostBody -> IO (OAuth2Result err ByteString)
doSimplePostRequest Manager
manager OAuth2
oa URI
uri PostBody
body)

-- | Conduct post request.
doSimplePostRequest :: FromJSON err => Manager                 -- ^ HTTP connection manager.
                       -> OAuth2                               -- ^ OAuth options
                       -> URI                                  -- ^ URL
                       -> PostBody                             -- ^ Request body.
                       -> IO (OAuth2Result err BSL.ByteString) -- ^ Response as ByteString
doSimplePostRequest :: Manager
-> OAuth2 -> URI -> PostBody -> IO (OAuth2Result err ByteString)
doSimplePostRequest Manager
manager OAuth2
oa URI
url PostBody
body = (Response ByteString -> OAuth2Result err ByteString)
-> IO (Response ByteString) -> IO (OAuth2Result err ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response ByteString -> OAuth2Result err ByteString
forall err.
FromJSON err =>
Response ByteString -> OAuth2Result err ByteString
handleOAuth2TokenResponse IO (Response ByteString)
go
                                  where go :: IO (Response ByteString)
go = do
                                             Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
                                             let addBasicAuth :: Request -> Request
addBasicAuth = case OAuth2 -> Maybe Text
oauthClientSecret OAuth2
oa of
                                                   (Just Text
secret) -> ByteString -> ByteString -> Request -> Request
applyBasicAuth (Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauthClientId OAuth2
oa) (Text -> ByteString
T.encodeUtf8 Text
secret)
                                                   Maybe Text
Nothing -> Request -> Request
forall a. a -> a
id
                                                 req' :: Request
req' = (Request -> Request
addBasicAuth (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe AccessToken -> Request -> Request
updateRequestHeaders Maybe AccessToken
forall a. Maybe a
Nothing) Request
req
                                             Request -> Manager -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs (PostBody -> Request -> Request
urlEncodedBody PostBody
body Request
req') Manager
manager

-- | Parses a @Response@ to to @OAuth2Result@
handleOAuth2TokenResponse :: FromJSON err => Response BSL.ByteString -> OAuth2Result err BSL.ByteString
handleOAuth2TokenResponse :: Response ByteString -> OAuth2Result err ByteString
handleOAuth2TokenResponse Response ByteString
rsp =
    if Status -> Bool
HT.statusIsSuccessful (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
rsp)
        then ByteString -> OAuth2Result err ByteString
forall a b. b -> Either a b
Right (ByteString -> OAuth2Result err ByteString)
-> ByteString -> OAuth2Result err ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
rsp
        else OAuth2Error err -> OAuth2Result err ByteString
forall a b. a -> Either a b
Left (OAuth2Error err -> OAuth2Result err ByteString)
-> OAuth2Error err -> OAuth2Result err ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> OAuth2Error err
forall err. FromJSON err => ByteString -> OAuth2Error err
parseOAuth2Error (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
rsp)

-- | Try 'parseResponseJSON', if failed then parses the @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String.
parseResponseFlexible :: FromJSON err => FromJSON a
                         => OAuth2Result err BSL.ByteString
                         -> OAuth2Result err a
parseResponseFlexible :: OAuth2Result err ByteString -> OAuth2Result err a
parseResponseFlexible OAuth2Result err ByteString
r = case OAuth2Result err ByteString -> OAuth2Result err a
forall err a.
(FromJSON err, FromJSON a) =>
OAuth2Result err ByteString -> OAuth2Result err a
parseResponseJSON OAuth2Result err ByteString
r of
                           Left OAuth2Error err
_ -> OAuth2Result err ByteString -> OAuth2Result err a
forall err a.
(FromJSON err, FromJSON a) =>
OAuth2Result err ByteString -> OAuth2Result err a
parseResponseString OAuth2Result err ByteString
r
                           OAuth2Result err a
x      -> OAuth2Result err a
x

parseResponseJSON :: (FromJSON err, FromJSON a)
              => OAuth2Result err BSL.ByteString
              -> OAuth2Result err a
parseResponseJSON :: OAuth2Result err ByteString -> OAuth2Result err a
parseResponseJSON (Left OAuth2Error err
b) = OAuth2Error err -> OAuth2Result err a
forall a b. a -> Either a b
Left OAuth2Error err
b
parseResponseJSON (Right ByteString
b) = case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
b of
                            Left String
e  -> OAuth2Error err -> OAuth2Result err a
forall a b. a -> Either a b
Left (OAuth2Error err -> OAuth2Result err a)
-> OAuth2Error err -> OAuth2Result err a
forall a b. (a -> b) -> a -> b
$ ByteString -> String -> OAuth2Error err
forall err. ByteString -> String -> OAuth2Error err
mkDecodeOAuth2Error ByteString
b String
e
                            Right a
x -> a -> OAuth2Result err a
forall a b. b -> Either a b
Right a
x

-- | Parses a @OAuth2Result BSL.ByteString@ that contains not JSON but a Query String
parseResponseString :: (FromJSON err, FromJSON a)
              => OAuth2Result err BSL.ByteString
              -> OAuth2Result err a
parseResponseString :: OAuth2Result err ByteString -> OAuth2Result err a
parseResponseString (Left OAuth2Error err
b) = OAuth2Error err -> OAuth2Result err a
forall a b. a -> Either a b
Left OAuth2Error err
b
parseResponseString (Right ByteString
b) = case ByteString -> Query
parseQuery (ByteString -> Query) -> ByteString -> Query
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
b of
                              [] -> OAuth2Error err -> OAuth2Result err a
forall a b. a -> Either a b
Left OAuth2Error err
errorMessage
                              Query
a -> case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> Result a) -> Value -> Result a
forall a b. (a -> b) -> a -> b
$ Query -> Value
queryToValue Query
a of
                                    Error String
_   -> OAuth2Error err -> OAuth2Result err a
forall a b. a -> Either a b
Left OAuth2Error err
errorMessage
                                    Success a
x -> a -> OAuth2Result err a
forall a b. b -> Either a b
Right a
x
  where
    queryToValue :: Query -> Value
queryToValue = Object -> Value
Object (Object -> Value) -> (Query -> Object) -> Query -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, Value)] -> Object)
-> (Query -> [(Text, Value)]) -> Query -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Maybe ByteString) -> (Text, Value))
-> Query -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Maybe ByteString) -> (Text, Value)
paramToPair
    paramToPair :: (ByteString, Maybe ByteString) -> (Text, Value)
paramToPair (ByteString
k, Maybe ByteString
mv) = (ByteString -> Text
T.decodeUtf8 ByteString
k, Value -> (ByteString -> Value) -> Maybe ByteString -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
Null (Text -> Value
String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) Maybe ByteString
mv)
    errorMessage :: OAuth2Error err
errorMessage = ByteString -> OAuth2Error err
forall err. FromJSON err => ByteString -> OAuth2Error err
parseOAuth2Error ByteString
b

--------------------------------------------------
-- * AUTH requests
--------------------------------------------------

-- | Conduct an authorized GET request and return response as JSON.
authGetJSON :: (FromJSON b)
                 => Manager                 -- ^ HTTP connection manager.
                 -> AccessToken
                 -> URI
                 -> IO (Either BSL.ByteString b) -- ^ Response as JSON
authGetJSON :: Manager -> AccessToken -> URI -> IO (Either ByteString b)
authGetJSON Manager
manager AccessToken
t URI
uri = do
  Either ByteString ByteString
resp <- Manager -> AccessToken -> URI -> IO (Either ByteString ByteString)
authGetBS Manager
manager AccessToken
t URI
uri
  Either ByteString b -> IO (Either ByteString b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString ByteString
resp Either ByteString ByteString
-> (ByteString -> Either ByteString b) -> Either ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((String -> ByteString) -> Either String b -> Either ByteString b
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> ByteString
BSL.pack (Either String b -> Either ByteString b)
-> (ByteString -> Either String b)
-> ByteString
-> Either ByteString b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String b
forall a. FromJSON a => ByteString -> Either String a
eitherDecode))

-- | Conduct an authorized GET request.
authGetBS :: Manager                 -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString
authGetBS :: Manager -> AccessToken -> URI -> IO (Either ByteString ByteString)
authGetBS Manager
manager AccessToken
token URI
url = do
  Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
  Request
-> (Request -> Request)
-> Manager
-> IO (Either ByteString ByteString)
authRequest Request
req Request -> Request
upReq Manager
manager
  where upReq :: Request -> Request
upReq = Maybe AccessToken -> Request -> Request
updateRequestHeaders (AccessToken -> Maybe AccessToken
forall a. a -> Maybe a
Just AccessToken
token) (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> Request -> Request
setMethod StdMethod
HT.GET

-- | same to 'authGetBS' but set access token to query parameter rather than header
authGetBS2 :: Manager                -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString
authGetBS2 :: Manager -> AccessToken -> URI -> IO (Either ByteString ByteString)
authGetBS2 Manager
manager AccessToken
token URI
url = do
  Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest (URI
url URI -> AccessToken -> URI
forall a. URIRef a -> AccessToken -> URIRef a
`appendAccessToken` AccessToken
token)
  Request
-> (Request -> Request)
-> Manager
-> IO (Either ByteString ByteString)
authRequest Request
req Request -> Request
upReq Manager
manager
  where upReq :: Request -> Request
upReq = Maybe AccessToken -> Request -> Request
updateRequestHeaders Maybe AccessToken
forall a. Maybe a
Nothing (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> Request -> Request
setMethod StdMethod
HT.GET

-- | Conduct POST request and return response as JSON.
authPostJSON :: (FromJSON b)
                 => Manager                 -- ^ HTTP connection manager.
                 -> AccessToken
                 -> URI
                 -> PostBody
                 -> IO (Either BSL.ByteString b) -- ^ Response as JSON
authPostJSON :: Manager
-> AccessToken -> URI -> PostBody -> IO (Either ByteString b)
authPostJSON Manager
manager AccessToken
t URI
uri PostBody
pb = do
  Either ByteString ByteString
resp <- Manager
-> AccessToken
-> URI
-> PostBody
-> IO (Either ByteString ByteString)
authPostBS Manager
manager AccessToken
t URI
uri PostBody
pb
  Either ByteString b -> IO (Either ByteString b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString ByteString
resp Either ByteString ByteString
-> (ByteString -> Either ByteString b) -> Either ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((String -> ByteString) -> Either String b -> Either ByteString b
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> ByteString
BSL.pack (Either String b -> Either ByteString b)
-> (ByteString -> Either String b)
-> ByteString
-> Either ByteString b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String b
forall a. FromJSON a => ByteString -> Either String a
eitherDecode))

-- | Conduct POST request.
authPostBS :: Manager                -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> PostBody
             -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString
authPostBS :: Manager
-> AccessToken
-> URI
-> PostBody
-> IO (Either ByteString ByteString)
authPostBS Manager
manager AccessToken
token URI
url PostBody
pb = do
  Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
  Request
-> (Request -> Request)
-> Manager
-> IO (Either ByteString ByteString)
authRequest Request
req Request -> Request
upReq Manager
manager
  where upBody :: Request -> Request
upBody = PostBody -> Request -> Request
urlEncodedBody (PostBody
pb PostBody -> PostBody -> PostBody
forall a. [a] -> [a] -> [a]
++ AccessToken -> PostBody
accessTokenToParam AccessToken
token)
        upHeaders :: Request -> Request
upHeaders = Maybe AccessToken -> Request -> Request
updateRequestHeaders (AccessToken -> Maybe AccessToken
forall a. a -> Maybe a
Just AccessToken
token) (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> Request -> Request
setMethod StdMethod
HT.POST
        upReq :: Request -> Request
upReq = Request -> Request
upHeaders (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
upBody

-- | Conduct POST request with access token in the request body rather header
authPostBS2 :: Manager               -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> PostBody
             -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString
authPostBS2 :: Manager
-> AccessToken
-> URI
-> PostBody
-> IO (Either ByteString ByteString)
authPostBS2 Manager
manager AccessToken
token URI
url PostBody
pb = do
  Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
  Request
-> (Request -> Request)
-> Manager
-> IO (Either ByteString ByteString)
authRequest Request
req Request -> Request
upReq Manager
manager
  where upBody :: Request -> Request
upBody = PostBody -> Request -> Request
urlEncodedBody (PostBody
pb PostBody -> PostBody -> PostBody
forall a. [a] -> [a] -> [a]
++ AccessToken -> PostBody
accessTokenToParam AccessToken
token)
        upHeaders :: Request -> Request
upHeaders = Maybe AccessToken -> Request -> Request
updateRequestHeaders Maybe AccessToken
forall a. Maybe a
Nothing (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> Request -> Request
setMethod StdMethod
HT.POST
        upReq :: Request -> Request
upReq = Request -> Request
upHeaders (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
upBody

-- | Conduct POST request with access token in the header and null in body
authPostBS3 :: Manager               -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> IO (Either BSL.ByteString BSL.ByteString) -- ^ Response as ByteString
authPostBS3 :: Manager -> AccessToken -> URI -> IO (Either ByteString ByteString)
authPostBS3 Manager
manager AccessToken
token URI
url = do
  Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
  Request
-> (Request -> Request)
-> Manager
-> IO (Either ByteString ByteString)
authRequest Request
req Request -> Request
upReq Manager
manager
  where upBody :: Request -> Request
upBody Request
req = Request
req { requestBody :: RequestBody
requestBody = RequestBody
"null" }
        upHeaders :: Request -> Request
upHeaders = Maybe AccessToken -> Request -> Request
updateRequestHeaders (AccessToken -> Maybe AccessToken
forall a. a -> Maybe a
Just AccessToken
token) (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdMethod -> Request -> Request
setMethod StdMethod
HT.POST
        upReq :: Request -> Request
upReq = Request -> Request
upHeaders (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
upBody

-- |Send an HTTP request including the Authorization header with the specified
--  access token.
--
authRequest :: Request          -- ^ Request to perform
               -> (Request -> Request)          -- ^ Modify request before sending
               -> Manager                       -- ^ HTTP connection manager.
               -> IO (Either BSL.ByteString BSL.ByteString)
authRequest :: Request
-> (Request -> Request)
-> Manager
-> IO (Either ByteString ByteString)
authRequest Request
req Request -> Request
upReq Manager
manage = Response ByteString -> Either ByteString ByteString
handleResponse (Response ByteString -> Either ByteString ByteString)
-> IO (Response ByteString) -> IO (Either ByteString ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs (Request -> Request
upReq Request
req) Manager
manage

--------------------------------------------------
-- * Utilities
--------------------------------------------------

-- | Parses a @Response@ to to @OAuth2Result@
handleResponse :: Response BSL.ByteString -> Either BSL.ByteString BSL.ByteString
handleResponse :: Response ByteString -> Either ByteString ByteString
handleResponse Response ByteString
rsp =
    if Status -> Bool
HT.statusIsSuccessful (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
rsp)
        then ByteString -> Either ByteString ByteString
forall a b. b -> Either a b
Right (ByteString -> Either ByteString ByteString)
-> ByteString -> Either ByteString ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
rsp
        else ByteString -> Either ByteString ByteString
forall a b. a -> Either a b
Left (ByteString -> Either ByteString ByteString)
-> ByteString -> Either ByteString ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
rsp

-- | Set several header values:
--   + userAgennt    : `hoauth2`
--   + accept        : `application/json`
--   + authorization : 'Bearer' `xxxxx` if 'AccessToken' provided.
updateRequestHeaders :: Maybe AccessToken -> Request -> Request
updateRequestHeaders :: Maybe AccessToken -> Request -> Request
updateRequestHeaders Maybe AccessToken
t Request
req =
  let extras :: [(HeaderName, ByteString)]
extras = [ (HeaderName
HT.hUserAgent, ByteString
"hoauth2")
               , (HeaderName
HT.hAccept, ByteString
"application/json") ]
      bearer :: [(HeaderName, ByteString)]
bearer = [(HeaderName
HT.hAuthorization, ByteString
"Bearer " ByteString -> ByteString -> ByteString
`BS.append` Text -> ByteString
T.encodeUtf8 (AccessToken -> Text
atoken (Maybe AccessToken -> AccessToken
forall a. HasCallStack => Maybe a -> a
fromJust Maybe AccessToken
t))) | Maybe AccessToken -> Bool
forall a. Maybe a -> Bool
isJust Maybe AccessToken
t]
      headers :: [(HeaderName, ByteString)]
headers = [(HeaderName, ByteString)]
bearer [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(HeaderName, ByteString)]
extras [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. [a] -> [a] -> [a]
++ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
  in
  Request
req { requestHeaders :: [(HeaderName, ByteString)]
requestHeaders = [(HeaderName, ByteString)]
headers }

-- | Set the HTTP method to use.
setMethod :: HT.StdMethod -> Request -> Request
setMethod :: StdMethod -> Request -> Request
setMethod StdMethod
m Request
req = Request
req { method :: ByteString
method = StdMethod -> ByteString
HT.renderStdMethod StdMethod
m }