ErrorResponse.hs

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