ProblemDetails.hs

-- | 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 app = \request respond -> app request respond `catch` (respond . catchProblemDetails)
  where
    catchProblemDetails :: ProblemDetailsException -> Response
    catchProblemDetails (ProblemDetailsException pd) = responseLBS
      (uncurry mkStatus $ getStatus pd)
      [("Content-Type", "application/problem+json")]
      (encode pd)

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