{-# LANGUAGE OverloadedStrings #-}
-- | OAuth callback error response
--
-- <https://tools.ietf.org/html/rfc6749#section-4.1.2.1>
--
module Yesod.Auth.OAuth2.ErrorResponse
    ( ErrorResponse(..)
    , erUserMessage
    , ErrorName(..)
    , onErrorResponse
    , unknownError
    )
where

import Data.Foldable (traverse_)
import Data.Text (Text)
import Data.Traversable (for)
import Yesod.Core (MonadHandler, lookupGetParam)

data ErrorName
    = InvalidRequest
    | UnauthorizedClient
    | AccessDenied
    | UnsupportedResponseType
    | InvalidScope
    | ServerError
    | TemporarilyUnavailable
    | Unknown Text
    deriving Int -> ErrorName -> ShowS
[ErrorName] -> ShowS
ErrorName -> String
(Int -> ErrorName -> ShowS)
-> (ErrorName -> String)
-> ([ErrorName] -> ShowS)
-> Show ErrorName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorName] -> ShowS
$cshowList :: [ErrorName] -> ShowS
show :: ErrorName -> String
$cshow :: ErrorName -> String
showsPrec :: Int -> ErrorName -> ShowS
$cshowsPrec :: Int -> ErrorName -> ShowS
Show

data ErrorResponse = ErrorResponse
    { ErrorResponse -> ErrorName
erName :: ErrorName
    , ErrorResponse -> Maybe Text
erDescription :: Maybe Text
    , ErrorResponse -> Maybe Text
erURI :: Maybe Text
    }
    deriving Int -> ErrorResponse -> ShowS
[ErrorResponse] -> ShowS
ErrorResponse -> String
(Int -> ErrorResponse -> ShowS)
-> (ErrorResponse -> String)
-> ([ErrorResponse] -> ShowS)
-> Show ErrorResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorResponse] -> ShowS
$cshowList :: [ErrorResponse] -> ShowS
show :: ErrorResponse -> String
$cshow :: ErrorResponse -> String
showsPrec :: Int -> ErrorResponse -> ShowS
$cshowsPrec :: Int -> ErrorResponse -> ShowS
Show

-- | Textual value suitable for display to a User
erUserMessage :: ErrorResponse -> Text
erUserMessage :: ErrorResponse -> Text
erUserMessage ErrorResponse
err = case ErrorResponse -> ErrorName
erName ErrorResponse
err of
    ErrorName
InvalidRequest -> Text
"Invalid request"
    ErrorName
UnauthorizedClient -> Text
"Unauthorized client"
    ErrorName
AccessDenied -> Text
"Access denied"
    ErrorName
UnsupportedResponseType -> Text
"Unsupported response type"
    ErrorName
InvalidScope -> Text
"Invalid scope"
    ErrorName
ServerError -> Text
"Server error"
    ErrorName
TemporarilyUnavailable -> Text
"Temporarily unavailable"
    Unknown Text
_ -> Text
"Unknown error"

unknownError :: Text -> ErrorResponse
unknownError :: Text -> ErrorResponse
unknownError Text
x = ErrorResponse :: ErrorName -> Maybe Text -> Maybe Text -> ErrorResponse
ErrorResponse
    { erName :: ErrorName
erName = Text -> ErrorName
Unknown Text
x
    , erDescription :: Maybe Text
erDescription = Maybe Text
forall a. Maybe a
Nothing
    , erURI :: Maybe Text
erURI = Maybe Text
forall a. Maybe a
Nothing
    }

-- | Check query parameters for an error, if found run the given action
--
-- The action is expected to use a short-circuit response function like
-- @'permissionDenied'@, hence this returning @()@.
--
onErrorResponse :: MonadHandler m => (ErrorResponse -> m a) -> m ()
onErrorResponse :: (ErrorResponse -> m a) -> m ()
onErrorResponse ErrorResponse -> m a
f = (ErrorResponse -> m a) -> Maybe ErrorResponse -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ErrorResponse -> m a
f (Maybe ErrorResponse -> m ()) -> m (Maybe ErrorResponse) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Maybe ErrorResponse)
forall (m :: * -> *). MonadHandler m => m (Maybe ErrorResponse)
checkErrorResponse

checkErrorResponse :: MonadHandler m => m (Maybe ErrorResponse)
checkErrorResponse :: m (Maybe ErrorResponse)
checkErrorResponse = do
    Maybe Text
merror <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"error"

    Maybe Text -> (Text -> m ErrorResponse) -> m (Maybe ErrorResponse)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe Text
merror ((Text -> m ErrorResponse) -> m (Maybe ErrorResponse))
-> (Text -> m ErrorResponse) -> m (Maybe ErrorResponse)
forall a b. (a -> b) -> a -> b
$ \Text
err ->
        ErrorName -> Maybe Text -> Maybe Text -> ErrorResponse
ErrorResponse (Text -> ErrorName
readErrorName Text
err)
            (Maybe Text -> Maybe Text -> ErrorResponse)
-> m (Maybe Text) -> m (Maybe Text -> ErrorResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"error_description"
            m (Maybe Text -> ErrorResponse)
-> m (Maybe Text) -> m ErrorResponse
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"error_uri"

readErrorName :: Text -> ErrorName
readErrorName :: Text -> ErrorName
readErrorName Text
"invalid_request" = ErrorName
InvalidRequest
readErrorName Text
"unauthorized_client" = ErrorName
UnauthorizedClient
readErrorName Text
"access_denied" = ErrorName
AccessDenied
readErrorName Text
"unsupported_response_type" = ErrorName
UnsupportedResponseType
readErrorName Text
"invalid_scope" = ErrorName
InvalidScope
readErrorName Text
"server_error" = ErrorName
ServerError
readErrorName Text
"temporarily_unavailable" = ErrorName
TemporarilyUnavailable
readErrorName Text
x = Text -> ErrorName
Unknown Text
x