TokenRequest.hs

-- | 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
  , tokenResponseErrorDescription :: Maybe Text
  , tokenResponseErrorUri :: Maybe (URIRef Absolute)
  }
  deriving (Show, Eq)

-- | Token Error Responses https://tools.ietf.org/html/rfc6749#section-5.2
data TokenResponseErrorCode
  = InvalidRequest
  | InvalidClient
  | InvalidGrant
  | UnauthorizedClient
  | UnsupportedGrantType
  | InvalidScope
  | UnknownErrorCode Text
  deriving (Show, Eq)

instance FromJSON TokenResponseErrorCode where
  parseJSON = withText "parseJSON TokenResponseErrorCode" $ \t ->
    pure $ case t of
      "invalid_request" -> InvalidRequest
      "invalid_client" -> InvalidClient
      "invalid_grant" -> InvalidGrant
      "unauthorized_client" -> UnauthorizedClient
      "unsupported_grant_type" -> UnsupportedGrantType
      "invalid_scope" -> InvalidScope
      _ -> UnknownErrorCode t

instance FromJSON TokenResponseError where
  parseJSON = withObject "parseJSON TokenResponseError" $ \t -> do
    tokenResponseError <- t .: "error"
    tokenResponseErrorDescription <- t .:? "error_description"
    tokenResponseErrorUri <- t .:? "error_uri"
    pure TokenResponseError {..}

parseTokeResponseError :: BSL.ByteString -> TokenResponseError
parseTokeResponseError string =
  either (mkDecodeOAuth2Error string) id (eitherDecode string)
  where
    mkDecodeOAuth2Error :: BSL.ByteString -> String -> TokenResponseError
    mkDecodeOAuth2Error response err =
      TokenResponseError
        (UnknownErrorCode "")
        (Just $ T.pack $ "Decode TokenResponseError failed: " <> err <> "\n Original Response:\n" <> show (T.decodeUtf8 $ BSL.toStrict response))
        Nothing

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

-- * Tokens

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

-- | https://www.rfc-editor.org/rfc/rfc6749#section-4.1.4
data TokenResponse = TokenResponse
  { accessToken :: AccessToken
  , refreshToken :: Maybe RefreshToken
  -- ^ Exists when @offline_access@ scope is in the Authorization Request and the provider supports Refresh Access Token.
  , expiresIn :: Maybe Int
  , 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.
  , idToken :: Maybe IdToken
  -- ^ Exists when @openid@ scope is in the Authorization Request and the provider supports OpenID protocol.
  , scope :: Maybe Text
  , rawResponse :: Object
  }
  deriving (Eq)

instance Show TokenResponse where
  show TokenResponse {..} =
    "TokenResponse {"
      <> "access_token = ***"
      <> ", id_token = "
      <> showM idToken
      <> ", refresh_token = "
      <> showM refreshToken
      <> ", expires_in = "
      <> show expiresIn
      <> ", token_type = "
      <> show tokenType
      <> ", scope = "
      <> show scope
      <> ", raw_response = ***"
      <> "}"
    where
      showM (Just _) = "***"
      showM Nothing = "Nothing"

instance Binary TokenResponse where
  put TokenResponse {..} = put rawResponse
  get = do
    rawt <- get
    case fromJSON (Aeson.Object rawt) of
      Success a -> pure a
      Error err -> fail err

-- | Parse JSON data into 'OAuth2Token'
instance FromJSON TokenResponse where
  parseJSON :: Value -> Parser TokenResponse
  parseJSON = withObject "TokenResponse" $ \v ->
    TokenResponse
      <$> v .: "access_token"
      <*> v .:? "refresh_token"
      <*> explicitParseFieldMaybe parseIntFlexible v "expires_in"
      <*> v .:? "token_type"
      <*> v .:? "id_token"
      <*> v .:? "scope"
      <*> pure v
    where
      parseIntFlexible :: Value -> Parser Int
      parseIntFlexible (String s) = pure . read $ unpack s
      parseIntFlexible v = parseJSON v

instance ToJSON TokenResponse where
  toJSON :: TokenResponse -> Value
  toJSON = toJSON . Object . rawResponse
  toEncoding :: TokenResponse -> Encoding
  toEncoding = toEncoding . 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 oa code =
  let uri = oauth2TokenEndpoint oa
      body =
        [ ("code", T.encodeUtf8 $ extoken code)
        , ("redirect_uri", serializeURIRef' $ oauth2RedirectUri oa)
        , ("grant_type", "authorization_code")
        ]
   in (uri, 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 oa token = (uri, body)
  where
    uri = oauth2TokenEndpoint oa
    body =
      [ ("grant_type", "refresh_token")
      , ("refresh_token", T.encodeUtf8 $ rtoken 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 = fetchAccessTokenWithAuthMethod 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 authMethod manager oa code = do
  let (uri, body) = accessTokenUrl oa code
  let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []
  doJSONPostRequest manager oa uri (body ++ 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 = refreshAccessTokenWithAuthMethod 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 authMethod manager oa token = do
  let (uri, body) = refreshAccessTokenUrl oa token
  let extraBody = if authMethod == ClientSecretPost then clientSecretPost oa else []
  doJSONPostRequest manager oa uri (body ++ 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 manager oa uri body = do
  resp <- doSimplePostRequest manager oa uri body
  case parseResponseFlexible resp of
    Right obj -> return obj
    Left e -> throwE 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 manager oa url body =
  ExceptT . liftIO $ fmap handleOAuth2TokenResponse go
  where
    go = do
      req <- uriToRequest url
      let req' = (addBasicAuth oa . addDefaultRequestHeaders) req
      httpLbs (urlEncodedBody body req') manager

-- | Gets response body from a @Response@ if 200 otherwise assume 'Network.OAuth2.TokenRequest.TokenResponseError'
handleOAuth2TokenResponse :: Response BSL.ByteString -> Either TokenResponseError BSL.ByteString
handleOAuth2TokenResponse rsp =
  if HT.statusIsSuccessful (responseStatus rsp)
    then Right $ responseBody rsp
    else Left $ parseTokeResponseError (responseBody 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 r = case eitherDecode r of
  Left _ -> parseResponseString r
  Right x -> Right x

-- | Parses the response that contains not JSON but a Query String
parseResponseString ::
  FromJSON a =>
  BSL.ByteString ->
  Either TokenResponseError a
parseResponseString b = case parseQuery $ BSL.toStrict b of
  [] -> Left errorMessage
  a -> case fromJSON $ queryToValue a of
    Error _ -> Left errorMessage
    Success x -> Right x
  where
    queryToValue = Object . KeyMap.fromList . map paramToPair
    paramToPair (k, mv) = (Key.fromText $ T.decodeUtf8 k, maybe Null (String . T.decodeUtf8) mv)
    errorMessage = parseTokeResponseError b

-- | Add Basic Authentication header using client_id and client_secret.
addBasicAuth :: OAuth2 -> Request -> Request
addBasicAuth oa =
  applyBasicAuth
    (T.encodeUtf8 $ oauth2ClientId oa)
    (T.encodeUtf8 $ oauth2ClientSecret oa)

-- | Add Credential (client_id, client_secret) to the request post body.
clientSecretPost :: OAuth2 -> PostBody
clientSecretPost oa =
  [ ("client_id", T.encodeUtf8 $ oauth2ClientId oa)
  , ("client_secret", T.encodeUtf8 $ oauth2ClientSecret oa)
  ]