-- | Middleware for WAI that implements the problem details RFC specified in
-- https://www.rfc-editor.org/rfc/rfc7807.
--
-- Example:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > module Main where
-- >
-- > import Network.Wai.Handler.Warp (run)
-- > import Data.Default
-- > import Network.Wai.Middleware.ProblemDetails
-- >
-- > main :: IO ()
-- > main = run 8080 $ problemDetails $ app
-- >   where
-- >     app request respond = throwProblemDetails def
--
-- See the project's README and tests for more examples.
--
module Network.Wai.Middleware.ProblemDetails
(
    module Network.Wai.Middleware.ProblemDetails.Internal.Types
  , module Network.Wai.Middleware.ProblemDetails.Internal.Exception
  , module Network.Wai.Middleware.ProblemDetails.Internal.Defaults
  , problemDetails
)
where

import           Network.Wai.Middleware.ProblemDetails.Internal.Defaults
import           Network.Wai.Middleware.ProblemDetails.Internal.Exception
import           Network.Wai.Middleware.ProblemDetails.Internal.Types

import           Control.Exception                                        (catch)
import           Data.Aeson                                               (encode)
import           Data.ByteString
import           Data.Text.Encoding                                       (encodeUtf8)
import           Network.HTTP.Types                                       (mkStatus)
import           Network.Wai                                              (Middleware,
                                                                           Response,
                                                                           responseLBS)


-- | Middleware that sends a problem+json response when an exception of type
-- 'ProblemDetailsException' is thrown from a WAI application.
problemDetails :: Middleware
problemDetails :: Middleware
problemDetails Application
app = \Request
request Response -> IO ResponseReceived
respond -> Application
app Request
request Response -> IO ResponseReceived
respond forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Response -> IO ResponseReceived
respond forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProblemDetailsException -> Response
catchProblemDetails)
  where
    catchProblemDetails :: ProblemDetailsException -> Response
    catchProblemDetails :: ProblemDetailsException -> Response
catchProblemDetails (ProblemDetailsException ProblemDetails
pd) = Status -> ResponseHeaders -> ByteString -> Response
responseLBS
      (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> ByteString -> Status
mkStatus forall a b. (a -> b) -> a -> b
$ ProblemDetails -> (Int, ByteString)
getStatus ProblemDetails
pd)
      [(HeaderName
"Content-Type", ByteString
"application/problem+json")]
      (forall a. ToJSON a => a -> ByteString
encode ProblemDetails
pd)

    getStatus :: ProblemDetails -> (Int, ByteString)
    getStatus :: ProblemDetails -> (Int, ByteString)
getStatus ProblemDetails
pd = case (ProblemDetails -> Maybe Int
status ProblemDetails
pd, ProblemDetails -> Maybe Text
title ProblemDetails
pd) of
      (Just Int
status', Just Text
title') -> (Int
status', Text -> ByteString
encodeUtf8 Text
title')
      (Maybe Int, Maybe Text)
_                           -> (Int
200, ByteString
"Ok")