content: {-# 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 (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
  