{-# 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 qualified Data.Aeson.KeyMap as KeyMap
import           qualified Data.Aeson.Key as Key
import           Data.Aeson
import           Data.Bifunctor                    (first)
import qualified Data.ByteString.Char8             as BS
import qualified Data.ByteString.Lazy.Char8        as BSL
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
oauth2ClientId 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
oauth2ClientSecret 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
oauth2ClientId 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
oauth2ClientSecret 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
oauth2ClientSecret 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
oauth2ClientId 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
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([(Key, Value)] -> Object)
-> (Query -> [(Key, Value)]) -> Query -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Maybe ByteString) -> (Key, Value))
-> Query -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Maybe ByteString) -> (Key, Value)
paramToPair
    paramToPair :: (ByteString, Maybe ByteString) -> (Key, Value)
paramToPair (ByteString
k, Maybe ByteString
mv) = (Text -> Key
Key.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$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 }