{-# 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
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
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
    { erName :: ErrorName
erName = Text -> ErrorName
Unknown Text
x
    , erDescription :: Maybe Text
erDescription = forall a. Maybe a
Nothing
    , erURI :: Maybe Text
erURI = 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 :: forall (m :: * -> *) a.
MonadHandler m =>
(ErrorResponse -> m a) -> m ()
onErrorResponse ErrorResponse -> m a
f = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ErrorResponse -> m a
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadHandler m => m (Maybe ErrorResponse)
checkErrorResponse

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

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