{-# LANGUAGE DataKinds     #-}
{-# LANGUAGE PolyKinds     #-}
{-# LANGUAGE RankNTypes    #-}
{-# LANGUAGE TypeOperators #-}

module Servant.Server.Internal.ErrorFormatter
  ( ErrorFormatters(..)
  , ErrorFormatter
  , NotFoundErrorFormatter

  , DefaultErrorFormatters
  , defaultErrorFormatters

  , MkContextWithErrorFormatter
  , mkContextWithErrorFormatter
  ) where

import           Data.String.Conversions
                 (cs)
import           Data.Typeable
import           Network.Wai.Internal
                 (Request)

import           Servant.API
                 (Capture, ReqBody)
import           Servant.Server.Internal.Context
import           Servant.Server.Internal.ServerError

-- | 'Context' that contains default error formatters.
type DefaultErrorFormatters = '[ErrorFormatters]

-- | A collection of error formatters for different situations.
--
-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax.
data ErrorFormatters = ErrorFormatters
  { -- | Format error from parsing the request body.
    ErrorFormatters -> ErrorFormatter
bodyParserErrorFormatter :: ErrorFormatter
    -- | Format error from parsing url parts or query parameters.
  , ErrorFormatters -> ErrorFormatter
urlParseErrorFormatter :: ErrorFormatter
    -- | Format error from parsing request headers.
  , ErrorFormatters -> ErrorFormatter
headerParseErrorFormatter :: ErrorFormatter
    -- | Format error for not found URLs.
  , ErrorFormatters -> NotFoundErrorFormatter
notFoundErrorFormatter :: NotFoundErrorFormatter
  }

-- | Default formatters will just return HTTP 400 status code with error
-- message as response body.
defaultErrorFormatters :: ErrorFormatters
defaultErrorFormatters :: ErrorFormatters
defaultErrorFormatters = ErrorFormatters :: ErrorFormatter
-> ErrorFormatter
-> ErrorFormatter
-> NotFoundErrorFormatter
-> ErrorFormatters
ErrorFormatters
  { bodyParserErrorFormatter :: ErrorFormatter
bodyParserErrorFormatter = ErrorFormatter
err400Formatter
  , urlParseErrorFormatter :: ErrorFormatter
urlParseErrorFormatter = ErrorFormatter
err400Formatter
  , headerParseErrorFormatter :: ErrorFormatter
headerParseErrorFormatter = ErrorFormatter
err400Formatter
  , notFoundErrorFormatter :: NotFoundErrorFormatter
notFoundErrorFormatter = ServerError -> NotFoundErrorFormatter
forall a b. a -> b -> a
const ServerError
err404
  }

-- | A custom formatter for errors produced by parsing combinators like
-- 'ReqBody' or 'Capture'.
--
-- A 'TypeRep' argument described the concrete combinator that raised
-- the error, allowing formatter to customize the message for different
-- combinators.
--
-- A full 'Request' is also passed so that the formatter can react to @Accept@ header,
-- for example.
type ErrorFormatter = TypeRep -> Request -> String -> ServerError

-- | This formatter does not get neither 'TypeRep' nor error message.
type NotFoundErrorFormatter = Request -> ServerError

type MkContextWithErrorFormatter (ctx :: [*]) = ctx .++ DefaultErrorFormatters

mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter :: Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context ctx
ctx = Context ctx
ctx Context ctx
-> Context '[ErrorFormatters]
-> Context (MkContextWithErrorFormatter ctx)
forall (l1 :: [*]) (l2 :: [*]).
Context l1 -> Context l2 -> Context (l1 .++ l2)
.++ (ErrorFormatters
defaultErrorFormatters ErrorFormatters -> Context '[] -> Context '[ErrorFormatters]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. Context '[]
EmptyContext)

-- Internal

err400Formatter :: ErrorFormatter
err400Formatter :: ErrorFormatter
err400Formatter TypeRep
_ Request
_ String
e = ServerError
err400 { errBody :: ByteString
errBody = String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
e }

-- These definitions suppress "unused import" warning.
-- The imorts are needed for Haddock to correctly link to them.
_RB :: Proxy ReqBody
_RB :: Proxy ReqBody
_RB = Proxy ReqBody
forall k (t :: k). Proxy t
Proxy
_C :: Proxy Capture
_C :: Proxy Capture
_C = Proxy Capture
forall k (t :: k). Proxy t
Proxy
_CT :: Proxy Context
_CT :: Proxy Context
_CT = Proxy Context
forall k (t :: k). Proxy t
Proxy