mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-01-12 04:08:30 +01:00
83 lines
2.4 KiB
Haskell
83 lines
2.4 KiB
Haskell
{-# 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 Show
|
|
|
|
data ErrorResponse = ErrorResponse
|
|
{ erName :: ErrorName
|
|
, erDescription :: Maybe Text
|
|
, erURI :: Maybe Text
|
|
}
|
|
deriving Show
|
|
|
|
-- | Textual value suitable for display to a User
|
|
erUserMessage :: ErrorResponse -> Text
|
|
erUserMessage err = case erName err of
|
|
InvalidRequest -> "Invalid request"
|
|
UnauthorizedClient -> "Unauthorized client"
|
|
AccessDenied -> "Access denied"
|
|
UnsupportedResponseType -> "Unsupported response type"
|
|
InvalidScope -> "Invalid scope"
|
|
ServerError -> "Server error"
|
|
TemporarilyUnavailable -> "Temporarily unavailable"
|
|
Unknown _ -> "Unknown error"
|
|
|
|
unknownError :: Text -> ErrorResponse
|
|
unknownError x = ErrorResponse
|
|
{ erName = Unknown x
|
|
, erDescription = Nothing
|
|
, erURI = 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 f = traverse_ f =<< checkErrorResponse
|
|
|
|
checkErrorResponse :: MonadHandler m => m (Maybe ErrorResponse)
|
|
checkErrorResponse = do
|
|
merror <- lookupGetParam "error"
|
|
|
|
for merror $ \err -> ErrorResponse
|
|
<$> pure (readErrorName err)
|
|
<*> lookupGetParam "error_description"
|
|
<*> lookupGetParam "error_uri"
|
|
|
|
readErrorName :: Text -> ErrorName
|
|
readErrorName "invalid_request" = InvalidRequest
|
|
readErrorName "unauthorized_client" = UnauthorizedClient
|
|
readErrorName "access_denied" = AccessDenied
|
|
readErrorName "unsupported_response_type" = UnsupportedResponseType
|
|
readErrorName "invalid_scope" = InvalidScope
|
|
readErrorName "server_error" = ServerError
|
|
readErrorName "temporarily_unavailable" = TemporarilyUnavailable
|
|
readErrorName x = Unknown x
|