{-# 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