-- | Bindings for The OAuth 2.0 Authorization Framework: Bearer Token Usage
-- RFC6750 <https://www.rfc-editor.org/rfc/rfc6750>
module Network.OAuth2.HttpClient (
  -- * AUTH requests
  authGetJSON,
  authGetBS,
  authGetJSONWithAuthMethod,
  authGetBSWithAuthMethod,
  authPostJSON,
  authPostBS,
  authPostJSONWithAuthMethod,
  authPostBSWithAuthMethod,

  -- * Types
  APIAuthenticationMethod (..),
) where

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Except (ExceptT (..), throwE)
import Data.Aeson (FromJSON)
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Aeson
import Data.Aeson.KeyMap qualified as Aeson
import Data.ByteString.Char8 qualified as BS
import Data.ByteString.Lazy.Char8 qualified as BSL
import Data.Text.Encoding qualified as T
import Lens.Micro (over)
import Network.HTTP.Client.Conduit (applyBearerAuth)
import Network.HTTP.Client.Contrib (handleResponse)
import Network.HTTP.Conduit
import Network.HTTP.Types qualified as HT
import Network.OAuth2.Internal
import URI.ByteString (URI, URIRef, queryL, queryPairsL)

--------------------------------------------------

-- * AUTH requests

-- Making request with Access Token appended to Header, Request body or query string.
--
--------------------------------------------------

-- | Conduct an authorized GET request and return response as JSON.
--   Inject Access Token to Authorization Header.
authGetJSON ::
  (MonadIO m, FromJSON a) =>
  -- | HTTP connection manager.
  Manager ->
  AccessToken ->
  URI ->
  -- | Response as JSON
  ExceptT BSL.ByteString m a
authGetJSON :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager -> AccessToken -> URI -> ExceptT ByteString m a
authGetJSON = APIAuthenticationMethod
-> Manager -> AccessToken -> URI -> ExceptT ByteString m a
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
APIAuthenticationMethod
-> Manager -> AccessToken -> URI -> ExceptT ByteString m a
authGetJSONWithAuthMethod APIAuthenticationMethod
AuthInRequestHeader

-- | Conduct an authorized GET request and return response as JSON.
--   Allow to specify how to append AccessToken.
--
-- @since 2.6.0
authGetJSONWithAuthMethod ::
  (MonadIO m, FromJSON a) =>
  APIAuthenticationMethod ->
  -- | HTTP connection manager.
  Manager ->
  AccessToken ->
  URI ->
  -- | Response as JSON
  ExceptT BSL.ByteString m a
authGetJSONWithAuthMethod :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
APIAuthenticationMethod
-> Manager -> AccessToken -> URI -> ExceptT ByteString m a
authGetJSONWithAuthMethod APIAuthenticationMethod
authTypes Manager
manager AccessToken
t URI
uri = do
  ByteString
resp <- APIAuthenticationMethod
-> Manager -> AccessToken -> URI -> ExceptT ByteString m ByteString
forall (m :: * -> *).
MonadIO m =>
APIAuthenticationMethod
-> Manager -> AccessToken -> URI -> ExceptT ByteString m ByteString
authGetBSWithAuthMethod APIAuthenticationMethod
authTypes Manager
manager AccessToken
t URI
uri
  ([Char] -> ExceptT ByteString m a)
-> (a -> ExceptT ByteString m a)
-> Either [Char] a
-> ExceptT ByteString m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> ExceptT ByteString m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ByteString -> ExceptT ByteString m a)
-> ([Char] -> ByteString) -> [Char] -> ExceptT ByteString m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BSL.pack) a -> ExceptT ByteString m a
forall a. a -> ExceptT ByteString m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either [Char] a
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecode ByteString
resp)

-- | Conduct an authorized GET request.
--   Inject Access Token to Authorization Header.
authGetBS ::
  MonadIO m =>
  -- | HTTP connection manager.
  Manager ->
  AccessToken ->
  URI ->
  -- | Response as ByteString
  ExceptT BSL.ByteString m BSL.ByteString
authGetBS :: forall (m :: * -> *).
MonadIO m =>
Manager -> AccessToken -> URI -> ExceptT ByteString m ByteString
authGetBS = APIAuthenticationMethod
-> Manager -> AccessToken -> URI -> ExceptT ByteString m ByteString
forall (m :: * -> *).
MonadIO m =>
APIAuthenticationMethod
-> Manager -> AccessToken -> URI -> ExceptT ByteString m ByteString
authGetBSWithAuthMethod APIAuthenticationMethod
AuthInRequestHeader

-- | Conduct an authorized GET request and return response as ByteString.
--   Allow to specify how to append AccessToken.
--
-- @since 2.6.0
authGetBSWithAuthMethod ::
  MonadIO m =>
  -- | Specify the way that how to append the 'AccessToken' in the request
  APIAuthenticationMethod ->
  -- | HTTP connection manager.
  Manager ->
  AccessToken ->
  URI ->
  -- | Response as ByteString
  ExceptT BSL.ByteString m BSL.ByteString
authGetBSWithAuthMethod :: forall (m :: * -> *).
MonadIO m =>
APIAuthenticationMethod
-> Manager -> AccessToken -> URI -> ExceptT ByteString m ByteString
authGetBSWithAuthMethod APIAuthenticationMethod
authTypes Manager
manager AccessToken
token URI
url = do
  let appendToUrl :: Bool
appendToUrl = APIAuthenticationMethod
AuthInRequestQuery APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== APIAuthenticationMethod
authTypes
  let appendToHeader :: Bool
appendToHeader = APIAuthenticationMethod
AuthInRequestHeader APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== APIAuthenticationMethod
authTypes
  let uri :: URI
uri = if Bool
appendToUrl then URI
url URI -> AccessToken -> URI
forall a. URIRef a -> AccessToken -> URIRef a
`appendAccessToken` AccessToken
token else URI
url
  let upReq :: Request -> Request
upReq = Maybe AccessToken -> Request -> Request
updateRequestHeaders (if Bool
appendToHeader then AccessToken -> Maybe AccessToken
forall a. a -> Maybe a
Just AccessToken
token else 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
  Request
req <- IO Request -> ExceptT ByteString m Request
forall a. IO a -> ExceptT ByteString m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> ExceptT ByteString m Request)
-> IO Request -> ExceptT ByteString m Request
forall a b. (a -> b) -> a -> b
$ URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
uri
  Request
-> (Request -> Request)
-> Manager
-> ExceptT ByteString m ByteString
forall (m :: * -> *).
MonadIO m =>
Request
-> (Request -> Request)
-> Manager
-> ExceptT ByteString m ByteString
authRequest Request
req Request -> Request
upReq Manager
manager

-- | Conduct POST request and return response as JSON.
--   Inject Access Token to Authorization Header.
authPostJSON ::
  (MonadIO m, FromJSON a) =>
  -- | HTTP connection manager.
  Manager ->
  AccessToken ->
  URI ->
  PostBody ->
  -- | Response as JSON
  ExceptT BSL.ByteString m a
authPostJSON :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager -> AccessToken -> URI -> PostBody -> ExceptT ByteString m a
authPostJSON = APIAuthenticationMethod
-> Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString m a
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
APIAuthenticationMethod
-> Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString m a
authPostJSONWithAuthMethod APIAuthenticationMethod
AuthInRequestHeader

-- | Conduct POST request and return response as JSON.
--   Allow to specify how to append AccessToken.
--
-- @since 2.6.0
authPostJSONWithAuthMethod ::
  (MonadIO m, FromJSON a) =>
  APIAuthenticationMethod ->
  -- | HTTP connection manager.
  Manager ->
  AccessToken ->
  URI ->
  PostBody ->
  -- | Response as ByteString
  ExceptT BSL.ByteString m a
authPostJSONWithAuthMethod :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
APIAuthenticationMethod
-> Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString m a
authPostJSONWithAuthMethod APIAuthenticationMethod
authTypes Manager
manager AccessToken
token URI
url PostBody
body = do
  ByteString
resp <- APIAuthenticationMethod
-> Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString m ByteString
forall (m :: * -> *).
MonadIO m =>
APIAuthenticationMethod
-> Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString m ByteString
authPostBSWithAuthMethod APIAuthenticationMethod
authTypes Manager
manager AccessToken
token URI
url PostBody
body
  ([Char] -> ExceptT ByteString m a)
-> (a -> ExceptT ByteString m a)
-> Either [Char] a
-> ExceptT ByteString m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> ExceptT ByteString m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ByteString -> ExceptT ByteString m a)
-> ([Char] -> ByteString) -> [Char] -> ExceptT ByteString m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BSL.pack) a -> ExceptT ByteString m a
forall a. a -> ExceptT ByteString m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either [Char] a
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecode ByteString
resp)

-- | Conduct POST request.
--   Inject Access Token to http header (Authorization)
authPostBS ::
  MonadIO m =>
  -- | HTTP connection manager.
  Manager ->
  AccessToken ->
  URI ->
  PostBody ->
  -- | Response as ByteString
  ExceptT BSL.ByteString m BSL.ByteString
authPostBS :: forall (m :: * -> *).
MonadIO m =>
Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString m ByteString
authPostBS = APIAuthenticationMethod
-> Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString m ByteString
forall (m :: * -> *).
MonadIO m =>
APIAuthenticationMethod
-> Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString m ByteString
authPostBSWithAuthMethod APIAuthenticationMethod
AuthInRequestHeader

-- | Conduct POST request and return response as ByteString.
--   Allow to specify how to append AccessToken.
--
-- @since 2.6.0
authPostBSWithAuthMethod ::
  MonadIO m =>
  APIAuthenticationMethod ->
  -- | HTTP connection manager.
  Manager ->
  AccessToken ->
  URI ->
  PostBody ->
  -- | Response as ByteString
  ExceptT BSL.ByteString m BSL.ByteString
authPostBSWithAuthMethod :: forall (m :: * -> *).
MonadIO m =>
APIAuthenticationMethod
-> Manager
-> AccessToken
-> URI
-> PostBody
-> ExceptT ByteString m ByteString
authPostBSWithAuthMethod APIAuthenticationMethod
authTypes Manager
manager AccessToken
token URI
url PostBody
body = do
  let appendToBody :: Bool
appendToBody = APIAuthenticationMethod
AuthInRequestBody APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== APIAuthenticationMethod
authTypes
  let appendToHeader :: Bool
appendToHeader = APIAuthenticationMethod
AuthInRequestHeader APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== APIAuthenticationMethod
authTypes
  let reqBody :: PostBody
reqBody = if Bool
appendToBody then PostBody
body PostBody -> PostBody -> PostBody
forall a. [a] -> [a] -> [a]
++ AccessToken -> PostBody
accessTokenToParam AccessToken
token else PostBody
body
  let upBody :: Request -> Request
upBody = if PostBody -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null PostBody
reqBody then Request -> Request
forall a. a -> a
id else PostBody -> Request -> Request
jsonBody PostBody
reqBody
  let upHeaders :: Request -> Request
upHeaders = Maybe AccessToken -> Request -> Request
updateRequestHeaders (if Bool
appendToHeader then AccessToken -> Maybe AccessToken
forall a. a -> Maybe a
Just AccessToken
token else 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
  let 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

  Request
req <- IO Request -> ExceptT ByteString m Request
forall a. IO a -> ExceptT ByteString m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> ExceptT ByteString m Request)
-> IO Request -> ExceptT ByteString m Request
forall a b. (a -> b) -> a -> b
$ URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
url
  Request
-> (Request -> Request)
-> Manager
-> ExceptT ByteString m ByteString
forall (m :: * -> *).
MonadIO m =>
Request
-> (Request -> Request)
-> Manager
-> ExceptT ByteString m ByteString
authRequest Request
req Request -> Request
upReq Manager
manager

jsonBody :: PostBody -> Request -> Request
jsonBody :: PostBody -> Request -> Request
jsonBody PostBody
body Request
req =
  Request
req
    { requestBody =
        RequestBodyLBS $
          Aeson.encode $
            Aeson.fromList $
              fmap (\(ByteString
a, ByteString
b) -> (Text -> Key
Aeson.fromText (ByteString -> Text
T.decodeUtf8 ByteString
a), ByteString -> Text
T.decodeUtf8 ByteString
b)) body
    , requestHeaders =
        (HT.hContentType, "application/json")
          : filter (\(HeaderName
x, ByteString
_) -> HeaderName
x HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
HT.hContentType) (requestHeaders req)
    }

--------------------------------------------------

-- * Types

--------------------------------------------------

-- | https://www.rfc-editor.org/rfc/rfc6750#section-2
data APIAuthenticationMethod
  = -- | Provides in Authorization header
    AuthInRequestHeader
  | -- | Provides in request body
    AuthInRequestBody
  | -- | Provides in request query parameter
    AuthInRequestQuery
  deriving (APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
(APIAuthenticationMethod -> APIAuthenticationMethod -> Bool)
-> (APIAuthenticationMethod -> APIAuthenticationMethod -> Bool)
-> Eq APIAuthenticationMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
== :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
$c/= :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
/= :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
Eq, Eq APIAuthenticationMethod
Eq APIAuthenticationMethod =>
(APIAuthenticationMethod -> APIAuthenticationMethod -> Ordering)
-> (APIAuthenticationMethod -> APIAuthenticationMethod -> Bool)
-> (APIAuthenticationMethod -> APIAuthenticationMethod -> Bool)
-> (APIAuthenticationMethod -> APIAuthenticationMethod -> Bool)
-> (APIAuthenticationMethod -> APIAuthenticationMethod -> Bool)
-> (APIAuthenticationMethod
    -> APIAuthenticationMethod -> APIAuthenticationMethod)
-> (APIAuthenticationMethod
    -> APIAuthenticationMethod -> APIAuthenticationMethod)
-> Ord APIAuthenticationMethod
APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
APIAuthenticationMethod -> APIAuthenticationMethod -> Ordering
APIAuthenticationMethod
-> APIAuthenticationMethod -> APIAuthenticationMethod
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: APIAuthenticationMethod -> APIAuthenticationMethod -> Ordering
compare :: APIAuthenticationMethod -> APIAuthenticationMethod -> Ordering
$c< :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
< :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
$c<= :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
<= :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
$c> :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
> :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
$c>= :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
>= :: APIAuthenticationMethod -> APIAuthenticationMethod -> Bool
$cmax :: APIAuthenticationMethod
-> APIAuthenticationMethod -> APIAuthenticationMethod
max :: APIAuthenticationMethod
-> APIAuthenticationMethod -> APIAuthenticationMethod
$cmin :: APIAuthenticationMethod
-> APIAuthenticationMethod -> APIAuthenticationMethod
min :: APIAuthenticationMethod
-> APIAuthenticationMethod -> APIAuthenticationMethod
Ord)

--------------------------------------------------

-- * Utilities

--------------------------------------------------

-- | Send an HTTP request.
authRequest ::
  MonadIO m =>
  -- | Request to perform
  Request ->
  -- | Modify request before sending
  (Request -> Request) ->
  -- | HTTP connection manager.
  Manager ->
  ExceptT BSL.ByteString m BSL.ByteString
authRequest :: forall (m :: * -> *).
MonadIO m =>
Request
-> (Request -> Request)
-> Manager
-> ExceptT ByteString m ByteString
authRequest Request
req Request -> Request
upReq Manager
manage = m (Either ByteString ByteString) -> ExceptT ByteString m ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ByteString ByteString)
 -> ExceptT ByteString m ByteString)
-> m (Either ByteString ByteString)
-> ExceptT ByteString m ByteString
forall a b. (a -> b) -> a -> b
$ do
  Response ByteString
resp <- Request -> Manager -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs (Request -> Request
upReq Request
req) Manager
manage
  Either ByteString ByteString -> m (Either ByteString ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response ByteString -> Either ByteString ByteString
handleResponse Response ByteString
resp)

updateRequestHeaders :: Maybe AccessToken -> Request -> Request
updateRequestHeaders :: Maybe AccessToken -> Request -> Request
updateRequestHeaders Maybe AccessToken
mt =
  (Request -> Request)
-> (AccessToken -> Request -> Request)
-> Maybe AccessToken
-> Request
-> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request -> Request
forall a. a -> a
id (ByteString -> Request -> Request
applyBearerAuth (ByteString -> Request -> Request)
-> (AccessToken -> ByteString) -> AccessToken -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString)
-> (AccessToken -> Text) -> AccessToken -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessToken -> Text
atoken) Maybe AccessToken
mt
    (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
addDefaultRequestHeaders

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

-- | For @GET@ method API.
appendAccessToken ::
  -- | Base URI
  URIRef a ->
  -- | Authorized Access Token
  AccessToken ->
  -- | Combined Result
  URIRef a
appendAccessToken :: forall a. URIRef a -> AccessToken -> URIRef a
appendAccessToken URIRef a
uri AccessToken
t = ASetter (URIRef a) (URIRef a) PostBody PostBody
-> (PostBody -> PostBody) -> URIRef a -> URIRef a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Query -> Identity Query) -> URIRef a -> Identity (URIRef a)
forall a (f :: * -> *).
Functor f =>
(Query -> f Query) -> URIRef a -> f (URIRef a)
queryL ((Query -> Identity Query) -> URIRef a -> Identity (URIRef a))
-> ((PostBody -> Identity PostBody) -> Query -> Identity Query)
-> ASetter (URIRef a) (URIRef a) PostBody PostBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PostBody -> Identity PostBody) -> Query -> Identity Query
Lens' Query PostBody
queryPairsL) (\PostBody
query -> PostBody
query PostBody -> PostBody -> PostBody
forall a. [a] -> [a] -> [a]
++ AccessToken -> PostBody
accessTokenToParam AccessToken
t) URIRef a
uri

-- | Create `QueryParams` with given access token value.
accessTokenToParam :: AccessToken -> [(BS.ByteString, BS.ByteString)]
accessTokenToParam :: AccessToken -> PostBody
accessTokenToParam AccessToken
t = [(ByteString
"access_token", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AccessToken -> Text
atoken AccessToken
t)]