-- |
-- Module:      Servant.Server.RFC7807
-- Description: Servant support for RFC7807 style error response messages
-- Copyright:   (c) 2020 Peter Trško
-- License:     BSD3
--
-- Maintainer:  peter.trsko@gmail.com
-- Stability:   experimental
-- Portability: GHC specific language extensions.
--
-- Servant support for [RFC7807 — Problem Details for HTTP APIs
-- ](https://tools.ietf.org/html/rfc7807) style response messages.
module Servant.Server.RFC7807
    (
    -- $intro
      rfc7807ServerError

    -- * Mime Type @application\/problem+json@
    , ProblemJSON

    -- * Re-exported
    --
    -- | When using 'Rfc7807Error' in more complex way, please, depend on
    -- "Network.HTTP.RFC7807" module directly. More information and more
    -- detailed usage examples can be found in "Network.HTTP.RFC7807" module
    -- documentation.
    , Rfc7807Error(..)
    )
  where

import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Maybe (Maybe(Just))
import Data.Proxy (Proxy)
import Data.Semigroup ((<>))

import qualified Data.Aeson as Aeson (FromJSON, ToJSON, encode)
import Network.HTTP.Media ((//), (/:), renderHeader)
import Network.HTTP.Types (hContentType)
import Servant.API.ContentTypes
  ( Accept(contentTypes)
  , MimeRender(mimeRender)
  , MimeUnrender(mimeUnrender)
  , contentType
  , eitherDecodeLenient
  )
import Servant.Server

import Network.HTTP.RFC7807 (Rfc7807Error(..), rfc7807Error)

-- | Media type defined by
-- <https://tools.ietf.org/html/rfc7807#section-6.1 RFC7807>:
-- @application/problem+json@
--
-- The way how this mime type is handled is the same as
-- 'Servant.API.ContentTypes.JSON'.
data ProblemJSON

-- TODO: This mime type is specifically designed for RFC7807 representation.
-- Should we enforce that in the encoding and decoding?

-- | @application/problem+json; charset=utf-8@
instance Accept ProblemJSON where
    contentTypes :: Proxy ProblemJSON -> NonEmpty MediaType
contentTypes Proxy ProblemJSON
_ = MediaType
ct MediaType -> (ByteString, ByteString) -> MediaType
/: (ByteString
"charset", ByteString
"utf-8") MediaType -> [MediaType] -> NonEmpty MediaType
forall a. a -> [a] -> NonEmpty a
:| [MediaType
ct]
      where
        ct :: MediaType
ct = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"problem+json"

-- | 'Aeson.encode'
instance Aeson.ToJSON a => MimeRender ProblemJSON a where
    mimeRender :: Proxy ProblemJSON -> a -> ByteString
mimeRender Proxy ProblemJSON
_ = a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode

-- | 'eitherDecodeLenient'
instance Aeson.FromJSON a => MimeUnrender ProblemJSON a where
    mimeUnrender :: Proxy ProblemJSON -> ByteString -> Either String a
mimeUnrender Proxy ProblemJSON
_ = ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeLenient

-- | Construct Servant 'ServerError' with RFC7807 style response body.
--
-- By using Servant abstractions (like 'MimeRender' and 'Accept') we are able
-- to easily integrate with existing code bases.
--
-- === Usage Example
--
-- @
-- data ErrorType
--     = ValidationError
--     -- ...
--
-- instance 'Aeson.ToJSON' ErrorType where
--     'Aeson.toJSON' = \\case
--         ValidationError ->
--              'Aeson.String' \"/errors#validation-error\"
--
-- {- ... -} = do
--     {- ... -}
--     unless validationSuccessful do
--         throwError $ 'rfc7807ServerError' (Proxy \@'ProblemJSON') 'err400' ValidationError \\e ->
--             e  { 'title' = \"Request failed to pass data validation\"
--                -- ...
--                }
-- @
rfc7807ServerError
    :: (MimeRender ctype body)
    => Proxy ctype
    -- ^ Media type to use when encoding the error response body. This allows
    -- us to select appropriate mime type, e.g. 'Servant.API.ContentTypes.JSON'
    -- or 'ProblemJSON'.
    -> ServerError
    -- ^ One of Servant error values e.g. 'err400'.
    -> errorType
    -- ^ Value of the 'type_' field (@\"type\"@ in JSON), the only mandatory
    -- parameter for RFC7807 content.
    -> (Rfc7807Error errorType errorInfo context -> body)
    -- ^ Modify the 'Rfc7807Error' type to your hearts desire.
    --
    -- Reason for the return type to be polymorphic (i.e. @body@) is that we
    -- may want to use a newtype to use a different encoding. This still allows
    -- us to use the @'Rfc7807Error' errorType errorInfo context@ type as a
    -- return type if @errorType@, @errorInfo@, and @context@ can be encoded
    -- into JSON.
    -> ServerError
rfc7807ServerError :: Proxy ctype
-> ServerError
-> errorType
-> (Rfc7807Error errorType errorInfo context -> body)
-> ServerError
rfc7807ServerError Proxy ctype
ctype serverError :: ServerError
serverError@ServerError{Int
errHTTPCode :: ServerError -> Int
errHTTPCode :: Int
errHTTPCode, [Header]
errHeaders :: ServerError -> [Header]
errHeaders :: [Header]
errHeaders} errorType
t Rfc7807Error errorType errorInfo context -> body
f =
    ServerError
serverError
        { errBody :: ByteString
errBody =
            Proxy ctype -> body -> ByteString
forall k (ctype :: k) a.
MimeRender ctype a =>
Proxy ctype -> a -> ByteString
mimeRender Proxy ctype
ctype (Rfc7807Error errorType errorInfo context -> body
f (errorType -> Rfc7807Error errorType errorInfo context
forall errorType errorInfo context.
errorType -> Rfc7807Error errorType errorInfo context
rfc7807Error errorType
t){$sel:status:Rfc7807Error :: Maybe Int
status = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
errHTTPCode})

        , errHeaders :: [Header]
errHeaders = [Header]
errHeaders
            [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<>  [ (HeaderName
hContentType, MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader (Proxy ctype -> MediaType
forall k (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType Proxy ctype
ctype))
                ]
        }

-- $intro
--
-- The main functionality of this module is 'rfc7807ServerError', which allows
-- us to create Servant's 'ServerError' values with RFC7807 style body.
-- Implementation is more abstract than strictly necessary to account for the
-- fact that @application/problem+json@ may not always be the best mime type to
-- use. This is especially true if we are migrating existing error responses.
-- Another benefit of the abstract way it's defined is that we can potentially
-- use different encoding or serialisation libraries.