{-# 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 Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import qualified Data.Aeson.KeyMap as KeyMap
import           qualified Data.Aeson.Key as Key
import           Data.Aeson
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
                   -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token -- ^ Access Token
fetchAccessToken :: Manager
-> OAuth2
-> ExchangeToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessToken Manager
manager OAuth2
oa ExchangeToken
code = Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
forall err a.
(FromJSON err, FromJSON a) =>
Manager
-> OAuth2 -> URI -> PostBody -> ExceptT (OAuth2Error err) IO 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
                   -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token -- ^ Access Token
fetchAccessToken2 :: Manager
-> OAuth2
-> ExchangeToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessToken2 Manager
mgr OAuth2
oa ExchangeToken
code = do
  let (URI
url, PostBody
body1) = OAuth2 -> ExchangeToken -> (URI, PostBody)
accessTokenUrl OAuth2
oa ExchangeToken
code
  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
"client_secret", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauth2ClientSecret OAuth2
oa)
        ]
  Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
forall err a.
(FromJSON err, FromJSON a) =>
Manager
-> OAuth2 -> URI -> PostBody -> ExceptT (OAuth2Error err) IO 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
                     -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token
refreshAccessToken :: Manager
-> OAuth2
-> RefreshToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
refreshAccessToken Manager
manager OAuth2
oa RefreshToken
token = Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
forall err a.
(FromJSON err, FromJSON a) =>
Manager
-> OAuth2 -> URI -> PostBody -> ExceptT (OAuth2Error err) IO 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
                     -> ExceptT (OAuth2Error TR.Errors) IO OAuth2Token
refreshAccessToken2 :: Manager
-> OAuth2
-> RefreshToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
refreshAccessToken2 Manager
manager OAuth2
oa RefreshToken
token = do
  let (URI
uri, PostBody
body) = OAuth2 -> RefreshToken -> (URI, PostBody)
refreshAccessTokenUrl OAuth2
oa RefreshToken
token
  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
"client_secret", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauth2ClientSecret OAuth2
oa)
        ]
  Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
forall err a.
(FromJSON err, FromJSON a) =>
Manager
-> OAuth2 -> URI -> PostBody -> ExceptT (OAuth2Error err) IO 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
                  -> ExceptT (OAuth2Error err) IO a -- ^ Response as JSON
doJSONPostRequest :: Manager
-> OAuth2 -> URI -> PostBody -> ExceptT (OAuth2Error err) IO a
doJSONPostRequest Manager
manager OAuth2
oa URI
uri PostBody
body = do
  ByteString
resp <- Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error err) IO ByteString
forall err.
FromJSON err =>
Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error err) IO ByteString
doSimplePostRequest Manager
manager OAuth2
oa URI
uri PostBody
body
  case ByteString -> Either (OAuth2Error err) a
forall err a.
(FromJSON err, FromJSON a) =>
ByteString -> Either (OAuth2Error err) a
parseResponseFlexible ByteString
resp of
    Right a
obj -> a -> ExceptT (OAuth2Error err) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
obj
    Left OAuth2Error err
e -> OAuth2Error err -> ExceptT (OAuth2Error err) IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE OAuth2Error err
e

-- | Conduct post request.
doSimplePostRequest :: FromJSON err => Manager                 -- ^ HTTP connection manager.
                       -> OAuth2                               -- ^ OAuth options
                       -> URI                                  -- ^ URL
                       -> PostBody                             -- ^ Request body.
                       -> ExceptT  (OAuth2Error err) IO  BSL.ByteString -- ^ Response as ByteString
doSimplePostRequest :: Manager
-> OAuth2
-> URI
-> PostBody
-> ExceptT (OAuth2Error err) IO ByteString
doSimplePostRequest Manager
manager OAuth2
oa URI
url PostBody
body =
  IO (Either (OAuth2Error err) ByteString)
-> ExceptT (OAuth2Error err) IO ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either (OAuth2Error err) ByteString)
 -> ExceptT (OAuth2Error err) IO ByteString)
-> IO (Either (OAuth2Error err) ByteString)
-> ExceptT (OAuth2Error err) IO ByteString
forall a b. (a -> b) -> a -> b
$ (Response ByteString -> Either (OAuth2Error err) ByteString)
-> IO (Response ByteString)
-> IO (Either (OAuth2Error err) ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response ByteString -> Either (OAuth2Error err) ByteString
forall err.
FromJSON err =>
Response ByteString -> Either (OAuth2Error err) ByteString
handleOAuth2TokenResponse IO (Response ByteString)
go
  where
    addBasicAuth :: Request -> Request
addBasicAuth = 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 -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> Text
oauth2ClientSecret OAuth2
oa)
    go :: IO (Response ByteString)
go = do
          Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
          let 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 -> Either (OAuth2Error err) BSL.ByteString
handleOAuth2TokenResponse :: Response ByteString -> Either (OAuth2Error 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 -> Either (OAuth2Error err) ByteString
forall a b. b -> Either a b
Right (ByteString -> Either (OAuth2Error err) ByteString)
-> ByteString -> Either (OAuth2Error err) ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
rsp
        else OAuth2Error err -> Either (OAuth2Error err) ByteString
forall a b. a -> Either a b
Left (OAuth2Error err -> Either (OAuth2Error err) ByteString)
-> OAuth2Error err -> Either (OAuth2Error 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)
                         => BSL.ByteString
                         -> Either (OAuth2Error err) a
parseResponseFlexible :: ByteString -> Either (OAuth2Error err) a
parseResponseFlexible ByteString
r = case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
r of
                           Left String
_   -> ByteString -> Either (OAuth2Error err) a
forall err a.
(FromJSON err, FromJSON a) =>
ByteString -> Either (OAuth2Error err) a
parseResponseString ByteString
r
                           Right a
x  -> a -> Either (OAuth2Error 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)
              => BSL.ByteString
              -> Either (OAuth2Error err) a
parseResponseString :: ByteString -> Either (OAuth2Error err) a
parseResponseString 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 -> Either (OAuth2Error 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 -> Either (OAuth2Error err) a
forall a b. a -> Either a b
Left OAuth2Error err
errorMessage
                                    Success a
x -> a -> Either (OAuth2Error 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
-- Making request with Access Token injected into header or request body.
--
--------------------------------------------------

-- | Conduct an authorized GET request and return response as JSON.
--   Inject Access Token to Authorization Header.
--
authGetJSON :: (FromJSON b)
                 => Manager                 -- ^ HTTP connection manager.
                 -> AccessToken
                 -> URI
                 -> ExceptT BSL.ByteString IO b -- ^ Response as JSON
authGetJSON :: Manager -> AccessToken -> URI -> ExceptT ByteString IO b
authGetJSON Manager
manager AccessToken
t URI
uri = do
  ByteString
resp <- Manager -> AccessToken -> URI -> ExceptT ByteString IO ByteString
authGetBS Manager
manager AccessToken
t URI
uri
  case ByteString -> Either String b
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
resp of
    Right b
obj -> b -> ExceptT ByteString IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
obj
    Left String
e -> ByteString -> ExceptT ByteString IO b
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ByteString -> ExceptT ByteString IO b)
-> ByteString -> ExceptT ByteString IO b
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSL.pack String
e

-- | Conduct an authorized GET request.
--   Inject Access Token to Authorization Header.
--
authGetBS :: Manager                 -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString
authGetBS :: Manager -> AccessToken -> URI -> ExceptT ByteString IO ByteString
authGetBS Manager
manager AccessToken
token URI
url = do
  Request
req <- URI -> ExceptT ByteString IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
  Request
-> (Request -> Request)
-> Manager
-> ExceptT ByteString IO 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
             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString
authGetBS2 :: Manager -> AccessToken -> URI -> ExceptT ByteString IO ByteString
authGetBS2 Manager
manager AccessToken
token URI
url = do
  Request
req <- IO Request -> ExceptT ByteString IO Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> ExceptT ByteString IO Request)
-> IO Request -> ExceptT ByteString IO Request
forall a b. (a -> b) -> a -> b
$ 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
-> ExceptT ByteString IO 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.
--   Inject Access Token to Authorization Header and request body.
--
authPostJSON :: (FromJSON b)
                 => Manager                 -- ^ HTTP connection manager.
                 -> AccessToken
                 -> URI
                 -> PostBody
                 -> ExceptT BSL.ByteString IO b -- ^ Response as JSON
authPostJSON :: Manager
-> AccessToken -> URI -> PostBody -> ExceptT ByteString IO b
authPostJSON Manager
manager AccessToken
t URI
uri PostBody
pb = do
  ByteString
resp <- Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString IO ByteString
authPostBS Manager
manager AccessToken
t URI
uri PostBody
pb
  case ByteString -> Either String b
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
resp of
    Right b
obj -> b -> ExceptT ByteString IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
obj
    Left String
e -> ByteString -> ExceptT ByteString IO b
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ByteString -> ExceptT ByteString IO b)
-> ByteString -> ExceptT ByteString IO b
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSL.pack String
e

-- | Conduct POST request.
--   Inject Access Token to http header (Authorization) and request body.
--
authPostBS :: Manager                -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> PostBody
             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString
authPostBS :: Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString IO ByteString
authPostBS Manager
manager AccessToken
token URI
url PostBody
pb = do
  Request
req <- URI -> ExceptT ByteString IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
  Request
-> (Request -> Request)
-> Manager
-> ExceptT ByteString IO 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 only in the request body but header.
--
authPostBS2 :: Manager               -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> PostBody
             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString
authPostBS2 :: Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString IO ByteString
authPostBS2 Manager
manager AccessToken
token URI
url PostBody
pb = do
  Request
req <- URI -> ExceptT ByteString IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
  Request
-> (Request -> Request)
-> Manager
-> ExceptT ByteString IO 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 only in the header and not in body
authPostBS3 :: Manager               -- ^ HTTP connection manager.
             -> AccessToken
             -> URI
             -> ExceptT BSL.ByteString IO BSL.ByteString -- ^ Response as ByteString
authPostBS3 :: Manager -> AccessToken -> URI -> ExceptT ByteString IO ByteString
authPostBS3 Manager
manager AccessToken
token URI
url = do
  Request
req <- URI -> ExceptT ByteString IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
  Request
-> (Request -> Request)
-> Manager
-> ExceptT ByteString IO 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.
               -> ExceptT BSL.ByteString IO BSL.ByteString
authRequest :: Request
-> (Request -> Request)
-> Manager
-> ExceptT ByteString IO ByteString
authRequest Request
req Request -> Request
upReq Manager
manage = IO (Either ByteString ByteString)
-> ExceptT ByteString IO ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ByteString ByteString)
 -> ExceptT ByteString IO ByteString)
-> IO (Either ByteString ByteString)
-> ExceptT ByteString IO ByteString
forall a b. (a -> b) -> a -> b
$ 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 }