servant-exceptions impure exceptions example

Main.hs

{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeOperators         #-}

module Main where

import Control.Exception.Base    (ErrorCall)
import Control.Monad.Catch       (MonadCatch, MonadThrow (..))
import Control.Monad.IO.Class    (liftIO)
import Data.Aeson
import Data.Text                 (Text)
import Data.Typeable             (typeOf)
import GHC.Generics
import Network.HTTP.Types.Status
import Network.Wai.Handler.Warp
import Servant
import Servant.Exception         (Exception (..), Throws, ToServantErr (..), mapException)
import Servant.Exception.Server  ()

import qualified Data.Text as Text

-- * Example types

type API = "api" :> "users" :> UsersAPI

type UsersAPI = Throws UsersError :> (
  Get '[JSON] [User]
  :<|> Capture "name" Text :> Get '[PlainText, JSON] User
  )

newtype User = User Text
             deriving (Eq, Show, Generic)

instance FromJSON User

instance ToJSON User

instance MimeRender PlainText User where
  mimeRender ct = mimeRender ct . show

-- | Errors occurring at the 'UsersAPI'
data UsersError = UserNotFound
                | ErrorWasCalled String
                | InternalError
                deriving (Show)

-- | Required to be able to 'throwM' and 'catch' 'UsersError' errors.
instance Exception UsersError

-- | Provide means to convert 'UsersError' to servant's error types.
instance ToServantErr UsersError where
  status UserNotFound = status404
  status (ErrorWasCalled _) = status418
  status InternalError = status500

  message (ErrorWasCalled e) = "Do not use partial functions, anyways here is the error string and call stack:\n"
                               <> Text.pack e
  message InternalError = "Something bad happened internally"
  message e = Text.pack $ show e

-- | There is a builtin 'MimeRender JSON' instance which uses 'ToJSON' to create
-- the actual error response payload. If we only use 'ToServantErr' functions,
-- we could re-use this implementation easily 'forall e. ToServantErr e'.
instance ToJSON UsersError where
  toJSON e = object [ "type" .= show (typeOf e)
                    , "message" .= message e
                    ]

-- | For 'PlainText' we
instance MimeRender PlainText UsersError where
  mimeRender ct = mimeRender ct . message

-- * Example server

server :: MonadCatch m => ServerT API m
server = getUsers
    :<|> getUser

getUsers :: Monad m => m [User]
getUsers = return [User "foo"]

getUser :: MonadThrow m => Text -> m User
getUser n
  | n == "foo" = return $ User "foo"
  | n == "bar" = error "oops"
  | otherwise = throwM UserNotFound

nt :: IO a -> Handler a
nt = mapException impureExceptions . liftIO
 where
  impureExceptions :: ErrorCall -> UsersError
  impureExceptions e = ErrorWasCalled $ show e

main :: IO ()
main =
  run 8000
  . serve (Proxy :: Proxy API)
  $ hoistServer (Proxy :: Proxy API) nt server