Custom JSON errors for Servant-server

Question

When using servant, I\'d like to return all errors as JSON. Currently, if a request fails to parse, I see an error message like this, returned as plain text

Answer 1

Currently right now I just handle this in middleware. I do something like the following:

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}

module Lib.ErrorResponse where

import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.ByteString.Lazy (toStrict)
import Blaze.ByteString.Builder (toLazyByteString)
import Blaze.ByteString.Builder.ByteString (fromByteString)
import Network.Wai
import Network.Wai.Internal
import Network.HTTP.Types
import Data.Text
import Data.Aeson
import qualified Data.Text.Lazy as TL

customError :: Application -> Application
customError = modifyResponse responseModifier

responseModifier :: Response -> Response
responseModifier r
  | responseStatus r == status400 && not (isCustomMessage r "Bad Request") =
    buildResponse status400 "Bad Request" (customErrorBody r "BadRequest") 400
  | responseStatus r == status403 =
    buildResponse status403 "Forbidden" "Forbidden" 400
  | responseStatus r == status404 =
    buildResponse status404 "Not Found" "Not Found" 404
  | responseStatus r == status405 =
    buildResponse status405 "Method Not Allowed" "Method Not Allowed" 405
  | otherwise = r

customErrorBody :: Response -> Text -> Text
customErrorBody (ResponseBuilder _ _ b) _ = TL.toStrict $ decodeUtf8 $ toLazyByteString b
customErrorBody (ResponseRaw _ res) e = customErrorBody res e
customErrorBody _ e = e

isCustomMessage :: Response -> Text -> Bool
isCustomMessage r m = "{\"error\":" `isInfixOf` customErrorBody r m

buildResponse :: Status -> Text -> Text -> Int -> Response
buildResponse st err msg cde = responseBuilder st
  [("Content-Type", "application/json")]
  (fromByteString . toStrict . encode $ object
    [ "error" .= err
    , "message" .= msg
    , "statusCode" .= cde
    ]
  )

And then I can use just like any other middleware:

run 8000 . customError $ serve api server