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

Answer 2

First, some language extensions

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}

Now then

Unfortunately this is more difficult than it should be. Servant, while well-designed and the composition of small logical parts, is very opinionated about how HTTP services should operate. The default implementation of ReqBody, which you are probably using, is hard-coded to spit out a text string.

However, we can switch out ReqBody for our own data type:

module Body where

import Control.Monad.Trans (liftIO)
import Data.Proxy (Proxy(..))
import Network.Wai (lazyRequestBody)

import Data.Aeson
import Servant.API
import Servant.Server
import Servant.Server.Internal

data Body a
instance (FromJSON a, HasServer api context) => HasServer (Body a :> api) context where
  type ServerT (Body a :> api) m = a -> ServerT api m

  route Proxy context subserver =
    route (Proxy :: Proxy api) context (addBodyCheck subserver (withRequest bodyCheck))
    where
      bodyCheck request = do
        body <- liftIO (lazyRequestBody request)
        case eitherDecode body of
          Left (BodyError -> e) ->
            delayedFailFatal err400 { errBody = encode e }
          Right v ->
            return v

In this very brief amount of code a lot is happening:

• We are teaching the servant-server package on how to handle our new datatype when it appears in the type resolution for serve (Proxy :: Proxy (Body foo :> bar)) server.

• We have ripped most of the code from the v0.8.1 release of ReqBody.

• We are adding a function to the pipeline that processes request bodies.

• In it, we attempt to decode to the a parameter of Body. On failure, we spit out a JSON blob and an HTTP 400.

• We are entirely ignoring content-type headers here, for brevity.

Here is the type of the JSON blob:

newtype BodyError = BodyError String
instance ToJSON BodyError where
  toJSON (BodyError b) = object ["error" .= b]

Most of this machinery is internal to servant-server and underdocumented and rather fragile. For example, already I see that the code diverges on master branch and the arity of my addBodyCheck has changed.

Though the Servant project is still quite young and remarkably ambitious, I have to say that the aesthetics and robustness of this solution are definitely underwhelming.

To test this

We will need a Main module:

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE TypeOperators         #-}
module Main where
import Data.Proxy (Proxy(..))
import Network.Wai.Handler.Warp (run)
import Servant.API
import Servant.Server

import Body

type API = Body [Int] :> Post '[JSON] [Int]

server :: Server API
server = pure

main :: IO ()
main = do
  putStrLn "running on port 8000"
  run 8000 (serve (Proxy :: Proxy API) server)

And a shell:

~ ❯❯❯ curl -i -XPOST 'http://localhost:8000/'
HTTP/1.1 400 Bad Request
Transfer-Encoding: chunked
Date: Fri, 20 Jan 2017 01:18:57 GMT
Server: Warp/3.2.9

{"error":"Error in $: not enough input"}%

~ ❯❯❯ curl -id 'hey' -XPOST 'http://localhost:8000/'
HTTP/1.1 400 Bad Request
Transfer-Encoding: chunked
Date: Fri, 20 Jan 2017 01:19:02 GMT
Server: Warp/3.2.9

{"error":"Error in $: Failed reading: not a valid json value"}%

~ ❯❯❯ curl -id '[1,2,3]' -XPOST 'http://localhost:8000/'
HTTP/1.1 200 OK
Transfer-Encoding: chunked
Date: Fri, 20 Jan 2017 01:19:07 GMT
Server: Warp/3.2.9
Content-Type: application/json

[1,2,3]%

Ta-da!

You should be able to run all this code on LTS-7.16.

What did we learn

(1) Servant and Haskell are fun.

(2) The typeclass machinery of Servant allows for a kind of plug-and-play when it comes to the types you specify in your API. We can take out ReqBody and replace it with our own; on a project I did at work we even replaced the Servant verbs (GET, POST, ...) with our own. We wrote new content types and we even did something similar with ReqBody like you saw here.

(3) It is the remarkable ability of the GHC compiler that we can destructure types during compile-time to influence runtime behavior in a safe and logically sound way. That we can express a tree of API routes at the type-level and then walk over them using typeclass instances, accumulating a server type using type families, is a wonderfully elegant way to build a well-typed web service.

Answer 3

Taking inspiration from @codedmart I also use a middleware, but it does not construct the json, it only changes the content type of the response when there is an error, and keep the original error message.

startApp :: IO ()
startApp = run 8081 . (modifyResponse errorHeadersToJson) $ serve api server

errorHeadersToJson :: Response -> Response
errorHeadersToJson r
  | responseStatus r == status200 = r
  | otherwise = mapResponseHeaders text2json r

text2json :: ResponseHeaders -> ResponseHeaders
text2json h = Map.assocs (Map.fromList [("Content-Type", "application/json")] `Map.union` Map.fromList h)

The json is built beforehand with a function overriding the Servant throwError function.

data ServerError = ServerError
  { statusCode        :: Int
  , error :: String
  , message  :: String
  } deriving (Eq, Show)

$(deriveJSON defaultOptions ''ServerError)

throwJsonError :: ServantErr -> String -> Servant.Handler b
throwJsonError err "" = throwError $ err { errBody = encode $ ServerError (errHTTPCode err) ("Server error"::String) (show $ errBody err) }
throwJsonError err message = throwError $ err { errBody = encode $ ServerError (errHTTPCode err) ("Server error"::String) message }

then I can throw any error with a custom message, it will be served as a json with the correct content-type :

throwJsonError err500 "Oh no !"