-- | Bindings Access Token and Refresh Token part of The OAuth 2.0 Authorization Framework
-- RFC6749 <https://www.rfc-editor.org/rfc/rfc6749>
module Network.OAuth2.TokenRequest where

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Except (ExceptT (..), throwE)
import Data.Aeson
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (Parser, explicitParseFieldMaybe)
import Data.Binary (Binary (..))
import Data.Binary.Instances.Aeson ()
import Data.ByteString.Lazy.Char8 qualified as BSL
import Data.Text (Text, unpack)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Network.HTTP.Conduit
import Network.HTTP.Types qualified as HT
import Network.HTTP.Types.URI (parseQuery)
import Network.OAuth2.Internal
import URI.ByteString
import Prelude hiding (error)

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

-- * Token Request Errors

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

data TokenResponseError = TokenResponseError
  { TokenResponseError -> TokenResponseErrorCode
tokenResponseError :: TokenResponseErrorCode
  , TokenResponseError -> Maybe Text
tokenResponseErrorDescription :: Maybe Text
  , TokenResponseError -> Maybe (URIRef Absolute)
tokenResponseErrorUri :: Maybe (URIRef Absolute)
  }
  deriving (Int -> TokenResponseError -> ShowS
[TokenResponseError] -> ShowS
TokenResponseError -> String
(Int -> TokenResponseError -> ShowS)
-> (TokenResponseError -> String)
-> ([TokenResponseError] -> ShowS)
-> Show TokenResponseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TokenResponseError -> ShowS
showsPrec :: Int -> TokenResponseError -> ShowS
$cshow :: TokenResponseError -> String
show :: TokenResponseError -> String
$cshowList :: [TokenResponseError] -> ShowS
showList :: [TokenResponseError] -> ShowS
Show, TokenResponseError -> TokenResponseError -> Bool
(TokenResponseError -> TokenResponseError -> Bool)
-> (TokenResponseError -> TokenResponseError -> Bool)
-> Eq TokenResponseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TokenResponseError -> TokenResponseError -> Bool
== :: TokenResponseError -> TokenResponseError -> Bool
$c/= :: TokenResponseError -> TokenResponseError -> Bool
/= :: TokenResponseError -> TokenResponseError -> Bool
Eq)

-- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2
data TokenResponseErrorCode
  = InvalidRequest
  | InvalidClient
  | InvalidGrant
  | UnauthorizedClient
  | UnsupportedGrantType
  | InvalidScope
  | UnknownErrorCode Text
  deriving (Int -> TokenResponseErrorCode -> ShowS
[TokenResponseErrorCode] -> ShowS
TokenResponseErrorCode -> String
(Int -> TokenResponseErrorCode -> ShowS)
-> (TokenResponseErrorCode -> String)
-> ([TokenResponseErrorCode] -> ShowS)
-> Show TokenResponseErrorCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TokenResponseErrorCode -> ShowS
showsPrec :: Int -> TokenResponseErrorCode -> ShowS
$cshow :: TokenResponseErrorCode -> String
show :: TokenResponseErrorCode -> String
$cshowList :: [TokenResponseErrorCode] -> ShowS
showList :: [TokenResponseErrorCode] -> ShowS
Show, TokenResponseErrorCode -> TokenResponseErrorCode -> Bool
(TokenResponseErrorCode -> TokenResponseErrorCode -> Bool)
-> (TokenResponseErrorCode -> TokenResponseErrorCode -> Bool)
-> Eq TokenResponseErrorCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TokenResponseErrorCode -> TokenResponseErrorCode -> Bool
== :: TokenResponseErrorCode -> TokenResponseErrorCode -> Bool
$c/= :: TokenResponseErrorCode -> TokenResponseErrorCode -> Bool
/= :: TokenResponseErrorCode -> TokenResponseErrorCode -> Bool
Eq)

instance FromJSON TokenResponseErrorCode where
  parseJSON :: Value -> Parser TokenResponseErrorCode
parseJSON = String
-> (Text -> Parser TokenResponseErrorCode)
-> Value
-> Parser TokenResponseErrorCode
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"parseJSON TokenResponseErrorCode" ((Text -> Parser TokenResponseErrorCode)
 -> Value -> Parser TokenResponseErrorCode)
-> (Text -> Parser TokenResponseErrorCode)
-> Value
-> Parser TokenResponseErrorCode
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    TokenResponseErrorCode -> Parser TokenResponseErrorCode
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TokenResponseErrorCode -> Parser TokenResponseErrorCode)
-> TokenResponseErrorCode -> Parser TokenResponseErrorCode
forall a b. (a -> b) -> a -> b
$ case Text
t of
      Text
"invalid_request" -> TokenResponseErrorCode
InvalidRequest
      Text
"invalid_client" -> TokenResponseErrorCode
InvalidClient
      Text
"invalid_grant" -> TokenResponseErrorCode
InvalidGrant
      Text
"unauthorized_client" -> TokenResponseErrorCode
UnauthorizedClient
      Text
"unsupported_grant_type" -> TokenResponseErrorCode
UnsupportedGrantType
      Text
"invalid_scope" -> TokenResponseErrorCode
InvalidScope
      Text
_ -> Text -> TokenResponseErrorCode
UnknownErrorCode Text
t

instance FromJSON TokenResponseError where
  parseJSON :: Value -> Parser TokenResponseError
parseJSON = String
-> (Object -> Parser TokenResponseError)
-> Value
-> Parser TokenResponseError
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"parseJSON TokenResponseError" ((Object -> Parser TokenResponseError)
 -> Value -> Parser TokenResponseError)
-> (Object -> Parser TokenResponseError)
-> Value
-> Parser TokenResponseError
forall a b. (a -> b) -> a -> b
$ \Object
t -> do
    TokenResponseErrorCode
tokenResponseError <- Object
t Object -> Key -> Parser TokenResponseErrorCode
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"error"
    Maybe Text
tokenResponseErrorDescription <- Object
t Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"error_description"
    Maybe (URIRef Absolute)
tokenResponseErrorUri <- Object
t Object -> Key -> Parser (Maybe (URIRef Absolute))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"error_uri"
    TokenResponseError -> Parser TokenResponseError
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TokenResponseError {Maybe Text
Maybe (URIRef Absolute)
TokenResponseErrorCode
tokenResponseError :: TokenResponseErrorCode
tokenResponseErrorDescription :: Maybe Text
tokenResponseErrorUri :: Maybe (URIRef Absolute)
tokenResponseError :: TokenResponseErrorCode
tokenResponseErrorDescription :: Maybe Text
tokenResponseErrorUri :: Maybe (URIRef Absolute)
..}

parseTokeResponseError :: BSL.ByteString -> TokenResponseError
parseTokeResponseError :: ByteString -> TokenResponseError
parseTokeResponseError ByteString
string =
  (String -> TokenResponseError)
-> (TokenResponseError -> TokenResponseError)
-> Either String TokenResponseError
-> TokenResponseError
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> String -> TokenResponseError
mkDecodeOAuth2Error ByteString
string) TokenResponseError -> TokenResponseError
forall a. a -> a
id (ByteString -> Either String TokenResponseError
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
string)
  where
    mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenResponseError
    mkDecodeOAuth2Error :: ByteString -> String -> TokenResponseError
mkDecodeOAuth2Error ByteString
response String
err =
      TokenResponseErrorCode
-> Maybe Text -> Maybe (URIRef Absolute) -> TokenResponseError
TokenResponseError
        (Text -> TokenResponseErrorCode
UnknownErrorCode Text
"")
        (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Decode TokenResponseError failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n Original Response:\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict ByteString
response))
        Maybe (URIRef Absolute)
forall a. Maybe a
Nothing

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

-- * Tokens

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

-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4
data TokenResponse = TokenResponse
  { TokenResponse -> AccessToken
accessToken :: AccessToken
  , TokenResponse -> Maybe RefreshToken
refreshToken :: Maybe RefreshToken
  -- ^ Exists when @offline_access@ scope is in the Authorization Request and the provider supports Refresh Access Token.
  , TokenResponse -> Maybe Int
expiresIn :: Maybe Int
  , TokenResponse -> Maybe Text
tokenType :: Maybe Text
  -- ^ See https://www.rfc-editor.org/rfc/rfc6749#section-5.1. It's required per spec. But OAuth2 provider implementation are vary. Maybe will remove 'Maybe' in future release.
  , TokenResponse -> Maybe IdToken
idToken :: Maybe IdToken
  -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol.
  , TokenResponse -> Maybe Text
scope :: Maybe Text
  , TokenResponse -> Object
rawResponse :: Object
  }
  deriving (TokenResponse -> TokenResponse -> Bool
(TokenResponse -> TokenResponse -> Bool)
-> (TokenResponse -> TokenResponse -> Bool) -> Eq TokenResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TokenResponse -> TokenResponse -> Bool
== :: TokenResponse -> TokenResponse -> Bool
$c/= :: TokenResponse -> TokenResponse -> Bool
/= :: TokenResponse -> TokenResponse -> Bool
Eq)

instance Show TokenResponse where
  show :: TokenResponse -> String
show TokenResponse {Maybe Int
Maybe Text
Maybe IdToken
Maybe RefreshToken
Object
AccessToken
accessToken :: TokenResponse -> AccessToken
refreshToken :: TokenResponse -> Maybe RefreshToken
expiresIn :: TokenResponse -> Maybe Int
tokenType :: TokenResponse -> Maybe Text
idToken :: TokenResponse -> Maybe IdToken
scope :: TokenResponse -> Maybe Text
rawResponse :: TokenResponse -> Object
accessToken :: AccessToken
refreshToken :: Maybe RefreshToken
expiresIn :: Maybe Int
tokenType :: Maybe Text
idToken :: Maybe IdToken
scope :: Maybe Text
rawResponse :: Object
..} =
    String
"TokenResponse {"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"access_token = ***"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", id_token = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe IdToken -> String
forall {a} {a}. IsString a => Maybe a -> a
showM Maybe IdToken
idToken
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", refresh_token = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe RefreshToken -> String
forall {a} {a}. IsString a => Maybe a -> a
showM Maybe RefreshToken
refreshToken
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", expires_in = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
expiresIn
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", token_type = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> String
forall a. Show a => a -> String
show Maybe Text
tokenType
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", scope = "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> String
forall a. Show a => a -> String
show Maybe Text
scope
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", raw_response = ***"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"}"
    where
      showM :: Maybe a -> a
showM (Just a
_) = a
"***"
      showM Maybe a
Nothing = a
"Nothing"

instance Binary TokenResponse where
  put :: TokenResponse -> Put
put TokenResponse {Maybe Int
Maybe Text
Maybe IdToken
Maybe RefreshToken
Object
AccessToken
accessToken :: TokenResponse -> AccessToken
refreshToken :: TokenResponse -> Maybe RefreshToken
expiresIn :: TokenResponse -> Maybe Int
tokenType :: TokenResponse -> Maybe Text
idToken :: TokenResponse -> Maybe IdToken
scope :: TokenResponse -> Maybe Text
rawResponse :: TokenResponse -> Object
accessToken :: AccessToken
refreshToken :: Maybe RefreshToken
expiresIn :: Maybe Int
tokenType :: Maybe Text
idToken :: Maybe IdToken
scope :: Maybe Text
rawResponse :: Object
..} = Object -> Put
forall t. Binary t => t -> Put
put Object
rawResponse
  get :: Get TokenResponse
get = do
    Object
rawt <- Get Object
forall t. Binary t => Get t
get
    case Value -> Result TokenResponse
forall a. FromJSON a => Value -> Result a
fromJSON (Object -> Value
Aeson.Object Object
rawt) of
      Success TokenResponse
a -> TokenResponse -> Get TokenResponse
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TokenResponse
a
      Error String
err -> String -> Get TokenResponse
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err

-- | Parse JSON data into 'OAuth2Token'
instance FromJSON TokenResponse where
  parseJSON :: Value -> Parser TokenResponse
  parseJSON :: Value -> Parser TokenResponse
parseJSON = String
-> (Object -> Parser TokenResponse)
-> Value
-> Parser TokenResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"TokenResponse" ((Object -> Parser TokenResponse) -> Value -> Parser TokenResponse)
-> (Object -> Parser TokenResponse)
-> Value
-> Parser TokenResponse
forall a b. (a -> b) -> a -> b
$ \Object
v ->
    AccessToken
-> Maybe RefreshToken
-> Maybe Int
-> Maybe Text
-> Maybe IdToken
-> Maybe Text
-> Object
-> TokenResponse
TokenResponse
      (AccessToken
 -> Maybe RefreshToken
 -> Maybe Int
 -> Maybe Text
 -> Maybe IdToken
 -> Maybe Text
 -> Object
 -> TokenResponse)
-> Parser AccessToken
-> Parser
     (Maybe RefreshToken
      -> Maybe Int
      -> Maybe Text
      -> Maybe IdToken
      -> Maybe Text
      -> Object
      -> TokenResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser AccessToken
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"access_token"
      Parser
  (Maybe RefreshToken
   -> Maybe Int
   -> Maybe Text
   -> Maybe IdToken
   -> Maybe Text
   -> Object
   -> TokenResponse)
-> Parser (Maybe RefreshToken)
-> Parser
     (Maybe Int
      -> Maybe Text
      -> Maybe IdToken
      -> Maybe Text
      -> Object
      -> TokenResponse)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe RefreshToken)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"refresh_token"
      Parser
  (Maybe Int
   -> Maybe Text
   -> Maybe IdToken
   -> Maybe Text
   -> Object
   -> TokenResponse)
-> Parser (Maybe Int)
-> Parser
     (Maybe Text
      -> Maybe IdToken -> Maybe Text -> Object -> TokenResponse)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> Parser Int) -> Object -> Key -> Parser (Maybe Int)
forall a. (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
explicitParseFieldMaybe Value -> Parser Int
parseIntFlexible Object
v Key
"expires_in"
      Parser
  (Maybe Text
   -> Maybe IdToken -> Maybe Text -> Object -> TokenResponse)
-> Parser (Maybe Text)
-> Parser (Maybe IdToken -> Maybe Text -> Object -> TokenResponse)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"token_type"
      Parser (Maybe IdToken -> Maybe Text -> Object -> TokenResponse)
-> Parser (Maybe IdToken)
-> Parser (Maybe Text -> Object -> TokenResponse)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe IdToken)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"id_token"
      Parser (Maybe Text -> Object -> TokenResponse)
-> Parser (Maybe Text) -> Parser (Object -> TokenResponse)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"scope"
      Parser (Object -> TokenResponse)
-> Parser Object -> Parser TokenResponse
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser Object
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
v
    where
      parseIntFlexible :: Value -> Parser Int
      parseIntFlexible :: Value -> Parser Int
parseIntFlexible (String Text
s) = Int -> Parser Int
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Parser Int) -> (String -> Int) -> String -> Parser Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read (String -> Parser Int) -> String -> Parser Int
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
s
      parseIntFlexible Value
v = Value -> Parser Int
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

instance ToJSON TokenResponse where
  toJSON :: TokenResponse -> Value
  toJSON :: TokenResponse -> Value
toJSON = Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Value -> Value)
-> (TokenResponse -> Value) -> TokenResponse -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
Object (Object -> Value)
-> (TokenResponse -> Object) -> TokenResponse -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenResponse -> Object
rawResponse
  toEncoding :: TokenResponse -> Encoding
  toEncoding :: TokenResponse -> Encoding
toEncoding = Value -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Value -> Encoding)
-> (TokenResponse -> Value) -> TokenResponse -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Value
Object (Object -> Value)
-> (TokenResponse -> Object) -> TokenResponse -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenResponse -> Object
rawResponse

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

-- * URL

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

-- | Prepare the URL and the request body query for fetching an access token.
accessTokenUrl ::
  OAuth2 ->
  -- | access code gained via authorization URL
  ExchangeToken ->
  -- | access token request URL plus the request body.
  (URI, PostBody)
accessTokenUrl :: OAuth2 -> ExchangeToken -> (URIRef Absolute, PostBody)
accessTokenUrl OAuth2
oa ExchangeToken
code =
  let uri :: URIRef Absolute
uri = OAuth2 -> URIRef Absolute
oauth2TokenEndpoint OAuth2
oa
      body :: PostBody
body =
        [ (ByteString
"code", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ ExchangeToken -> Text
extoken ExchangeToken
code)
        , (ByteString
"redirect_uri", URIRef Absolute -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' (URIRef Absolute -> ByteString) -> URIRef Absolute -> ByteString
forall a b. (a -> b) -> a -> b
$ OAuth2 -> URIRef Absolute
oauth2RedirectUri OAuth2
oa)
        , (ByteString
"grant_type", ByteString
"authorization_code")
        ]
   in (URIRef Absolute
uri, PostBody
body)

-- | Obtain a new access token by sending a Refresh Token to the Authorization server.
refreshAccessTokenUrl ::
  OAuth2 ->
  -- | Refresh Token gained via authorization URL
  RefreshToken ->
  -- | Refresh Token request URL plus the request body.
  (URI, PostBody)
refreshAccessTokenUrl :: OAuth2 -> RefreshToken -> (URIRef Absolute, PostBody)
refreshAccessTokenUrl OAuth2
oa RefreshToken
token = (URIRef Absolute
uri, PostBody
body)
  where
    uri :: URIRef Absolute
uri = OAuth2 -> URIRef Absolute
oauth2TokenEndpoint OAuth2
oa
    body :: PostBody
body =
      [ (ByteString
"grant_type", ByteString
"refresh_token")
      , (ByteString
"refresh_token", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ RefreshToken -> Text
rtoken RefreshToken
token)
      ]

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

-- * Token management

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

-- | Exchange @code@ for an Access Token with authenticate in request header.
fetchAccessToken ::
  MonadIO m =>
  -- | HTTP connection manager
  Manager ->
  -- | OAuth Data
  OAuth2 ->
  -- | OAuth2 Code
  ExchangeToken ->
  -- | Access Token
  ExceptT TokenResponseError m TokenResponse
fetchAccessToken :: forall (m :: * -> *).
MonadIO m =>
Manager
-> OAuth2
-> ExchangeToken
-> ExceptT TokenResponseError m TokenResponse
fetchAccessToken = ClientAuthenticationMethod
-> Manager
-> OAuth2
-> ExchangeToken
-> ExceptT TokenResponseError m TokenResponse
forall (m :: * -> *).
MonadIO m =>
ClientAuthenticationMethod
-> Manager
-> OAuth2
-> ExchangeToken
-> ExceptT TokenResponseError m TokenResponse
fetchAccessTokenWithAuthMethod ClientAuthenticationMethod
ClientSecretBasic

-- | Exchange @code@ for an Access Token
--
-- OAuth2 spec allows credential (@client_id@, @client_secret@) to be sent
-- either in the header (a.k.a `ClientSecretBasic`).
-- or as form/url params (a.k.a `ClientSecretPost`).
--
-- The OAuth provider can choose to implement only one, or both.
-- Look for API document from the OAuth provider you're dealing with.
-- If you`re uncertain, try `fetchAccessToken` which sends credential
-- in authorization http header, which is common case.
--
-- @since 2.6.0
fetchAccessTokenWithAuthMethod ::
  MonadIO m =>
  ClientAuthenticationMethod ->
  -- | HTTP connection manager
  Manager ->
  -- | OAuth Data
  OAuth2 ->
  -- | Authorization Code
  ExchangeToken ->
  -- | Access Token
  ExceptT TokenResponseError m TokenResponse
fetchAccessTokenWithAuthMethod :: forall (m :: * -> *).
MonadIO m =>
ClientAuthenticationMethod
-> Manager
-> OAuth2
-> ExchangeToken
-> ExceptT TokenResponseError m TokenResponse
fetchAccessTokenWithAuthMethod ClientAuthenticationMethod
authMethod Manager
manager OAuth2
oa ExchangeToken
code = do
  let (URIRef Absolute
uri, PostBody
body) = OAuth2 -> ExchangeToken -> (URIRef Absolute, PostBody)
accessTokenUrl OAuth2
oa ExchangeToken
code
  let extraBody :: PostBody
extraBody = if ClientAuthenticationMethod
authMethod ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== ClientAuthenticationMethod
ClientSecretPost then OAuth2 -> PostBody
clientSecretPost OAuth2
oa else []
  Manager
-> OAuth2
-> URIRef Absolute
-> PostBody
-> ExceptT TokenResponseError m TokenResponse
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager
-> OAuth2
-> URIRef Absolute
-> PostBody
-> ExceptT TokenResponseError m a
doJSONPostRequest Manager
manager OAuth2
oa URIRef Absolute
uri (PostBody
body PostBody -> PostBody -> PostBody
forall a. [a] -> [a] -> [a]
++ PostBody
extraBody)

-- | Fetch a new AccessToken using the Refresh Token with authentication in request header.
refreshAccessToken ::
  MonadIO m =>
  -- | HTTP connection manager.
  Manager ->
  -- | OAuth context
  OAuth2 ->
  -- | Refresh Token gained after authorization
  RefreshToken ->
  ExceptT TokenResponseError m TokenResponse
refreshAccessToken :: forall (m :: * -> *).
MonadIO m =>
Manager
-> OAuth2
-> RefreshToken
-> ExceptT TokenResponseError m TokenResponse
refreshAccessToken = ClientAuthenticationMethod
-> Manager
-> OAuth2
-> RefreshToken
-> ExceptT TokenResponseError m TokenResponse
forall (m :: * -> *).
MonadIO m =>
ClientAuthenticationMethod
-> Manager
-> OAuth2
-> RefreshToken
-> ExceptT TokenResponseError m TokenResponse
refreshAccessTokenWithAuthMethod ClientAuthenticationMethod
ClientSecretBasic

-- | Fetch a new AccessToken using the Refresh Token.
--
-- OAuth2 spec allows credential ("client_id", "client_secret") to be sent
-- either in the header (a.k.a 'ClientSecretBasic').
-- or as form/url params (a.k.a 'ClientSecretPost').
--
-- The OAuth provider can choose to implement only one, or both.
-- Look for API document from the OAuth provider you're dealing with.
-- If you're uncertain, try 'refreshAccessToken' which sends credential
-- in authorization http header, which is common case.
--
-- @since 2.6.0
refreshAccessTokenWithAuthMethod ::
  MonadIO m =>
  ClientAuthenticationMethod ->
  -- | HTTP connection manager.
  Manager ->
  -- | OAuth context
  OAuth2 ->
  -- | Refresh Token gained after authorization
  RefreshToken ->
  ExceptT TokenResponseError m TokenResponse
refreshAccessTokenWithAuthMethod :: forall (m :: * -> *).
MonadIO m =>
ClientAuthenticationMethod
-> Manager
-> OAuth2
-> RefreshToken
-> ExceptT TokenResponseError m TokenResponse
refreshAccessTokenWithAuthMethod ClientAuthenticationMethod
authMethod Manager
manager OAuth2
oa RefreshToken
token = do
  let (URIRef Absolute
uri, PostBody
body) = OAuth2 -> RefreshToken -> (URIRef Absolute, PostBody)
refreshAccessTokenUrl OAuth2
oa RefreshToken
token
  let extraBody :: PostBody
extraBody = if ClientAuthenticationMethod
authMethod ClientAuthenticationMethod -> ClientAuthenticationMethod -> Bool
forall a. Eq a => a -> a -> Bool
== ClientAuthenticationMethod
ClientSecretPost then OAuth2 -> PostBody
clientSecretPost OAuth2
oa else []
  Manager
-> OAuth2
-> URIRef Absolute
-> PostBody
-> ExceptT TokenResponseError m TokenResponse
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager
-> OAuth2
-> URIRef Absolute
-> PostBody
-> ExceptT TokenResponseError m a
doJSONPostRequest Manager
manager OAuth2
oa URIRef Absolute
uri (PostBody
body PostBody -> PostBody -> PostBody
forall a. [a] -> [a] -> [a]
++ PostBody
extraBody)

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

-- * Utilies

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

-- | Conduct post request and return response as JSON.
doJSONPostRequest ::
  (MonadIO m, FromJSON a) =>
  -- | HTTP connection manager.
  Manager ->
  -- | OAuth options
  OAuth2 ->
  -- | The URL
  URI ->
  -- | request body
  PostBody ->
  -- | Response as JSON
  ExceptT TokenResponseError m a
doJSONPostRequest :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager
-> OAuth2
-> URIRef Absolute
-> PostBody
-> ExceptT TokenResponseError m a
doJSONPostRequest Manager
manager OAuth2
oa URIRef Absolute
uri PostBody
body = do
  ByteString
resp <- Manager
-> OAuth2
-> URIRef Absolute
-> PostBody
-> ExceptT TokenResponseError m ByteString
forall (m :: * -> *).
MonadIO m =>
Manager
-> OAuth2
-> URIRef Absolute
-> PostBody
-> ExceptT TokenResponseError m ByteString
doSimplePostRequest Manager
manager OAuth2
oa URIRef Absolute
uri PostBody
body
  case ByteString -> Either TokenResponseError a
forall a. FromJSON a => ByteString -> Either TokenResponseError a
parseResponseFlexible ByteString
resp of
    Right a
obj -> a -> ExceptT TokenResponseError m a
forall a. a -> ExceptT TokenResponseError m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
obj
    Left TokenResponseError
e -> TokenResponseError -> ExceptT TokenResponseError m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TokenResponseError
e

-- | Conduct post request.
doSimplePostRequest ::
  MonadIO m =>
  -- | HTTP connection manager.
  Manager ->
  -- | OAuth options
  OAuth2 ->
  -- | URL
  URI ->
  -- | Request body.
  PostBody ->
  -- | Response as ByteString
  ExceptT TokenResponseError m BSL.ByteString
doSimplePostRequest :: forall (m :: * -> *).
MonadIO m =>
Manager
-> OAuth2
-> URIRef Absolute
-> PostBody
-> ExceptT TokenResponseError m ByteString
doSimplePostRequest Manager
manager OAuth2
oa URIRef Absolute
url PostBody
body =
  m (Either TokenResponseError ByteString)
-> ExceptT TokenResponseError m ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either TokenResponseError ByteString)
 -> ExceptT TokenResponseError m ByteString)
-> (IO (Either TokenResponseError ByteString)
    -> m (Either TokenResponseError ByteString))
-> IO (Either TokenResponseError ByteString)
-> ExceptT TokenResponseError m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either TokenResponseError ByteString)
-> m (Either TokenResponseError ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either TokenResponseError ByteString)
 -> ExceptT TokenResponseError m ByteString)
-> IO (Either TokenResponseError ByteString)
-> ExceptT TokenResponseError m ByteString
forall a b. (a -> b) -> a -> b
$ (Response ByteString -> Either TokenResponseError ByteString)
-> IO (Response ByteString)
-> IO (Either TokenResponseError ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response ByteString -> Either TokenResponseError ByteString
handleOAuth2TokenResponse IO (Response ByteString)
go
  where
    go :: IO (Response ByteString)
go = do
      Request
req <- URIRef Absolute -> IO Request
forall (m :: * -> *). MonadThrow m => URIRef Absolute -> m Request
uriToRequest URIRef Absolute
url
      let req' :: Request
req' = (OAuth2 -> Request -> Request
addBasicAuth OAuth2
oa (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
addDefaultRequestHeaders) 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

-- | Gets response body from a @Response@ if 200 otherwise assume 'Network.OAuth2.TokenRequest.TokenResponseError'
handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenResponseError BSL.ByteString
handleOAuth2TokenResponse :: Response ByteString -> Either TokenResponseError 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 TokenResponseError ByteString
forall a b. b -> Either a b
Right (ByteString -> Either TokenResponseError ByteString)
-> ByteString -> Either TokenResponseError ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
rsp
    else TokenResponseError -> Either TokenResponseError ByteString
forall a b. a -> Either a b
Left (TokenResponseError -> Either TokenResponseError ByteString)
-> TokenResponseError -> Either TokenResponseError ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> TokenResponseError
parseTokeResponseError (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
rsp)

-- | Try to parses response as JSON, if failed, try to parse as like query string.
parseResponseFlexible ::
  FromJSON a =>
  BSL.ByteString ->
  Either TokenResponseError a
parseResponseFlexible :: forall a. FromJSON a => ByteString -> Either TokenResponseError 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 TokenResponseError a
forall a. FromJSON a => ByteString -> Either TokenResponseError a
parseResponseString ByteString
r
  Right a
x -> a -> Either TokenResponseError a
forall a b. b -> Either a b
Right a
x

-- | Parses the response that contains not JSON but a Query String
parseResponseString ::
  FromJSON a =>
  BSL.ByteString ->
  Either TokenResponseError a
parseResponseString :: forall a. FromJSON a => ByteString -> Either TokenResponseError 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
  [] -> TokenResponseError -> Either TokenResponseError a
forall a b. a -> Either a b
Left TokenResponseError
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
_ -> TokenResponseError -> Either TokenResponseError a
forall a b. a -> Either a b
Left TokenResponseError
errorMessage
    Success a
x -> a -> Either TokenResponseError 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 :: TokenResponseError
errorMessage = ByteString -> TokenResponseError
parseTokeResponseError ByteString
b

-- | Add Basic Authentication header using client_id and client_secret.
addBasicAuth :: OAuth2 -> Request -> Request
addBasicAuth :: OAuth2 -> Request -> Request
addBasicAuth OAuth2
oa =
  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)

-- | Add Credential (client_id, client_secret) to the request post body.
clientSecretPost :: OAuth2 -> PostBody
clientSecretPost :: OAuth2 -> PostBody
clientSecretPost OAuth2
oa =
  [ (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)
  ]