Listing alternative responses and exceptions in your API types

Servant allows you to talk about the exceptions you throw in your API types. This is not limited to actual exceptions, you can write handlers that respond with arbitrary open unions of types.

Preliminaries

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall -Wno-orphans #-}

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async)
import Control.Monad (when)
import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT)
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.String.Conversions (cs)
import Data.Swagger (ToSchema)
import Data.Typeable (Proxy (Proxy))
import qualified GHC.Generics as GHC
import qualified Network.HTTP.Client as Client
import qualified Network.Wai.Handler.Warp as Warp
import Servant.API
import Servant.Client
import Servant.Server
import Servant.Swagger

The API

This looks like a Verb-based routing table, except that UVerb has no status, and carries a list of response types rather than a single one. Each entry in the list carries its own response code.

type API =
         "fisx"  :> Capture "bool" Bool
         :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String]
    :<|> "arian"
         :> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser]

Here are the details:

data FisxUser = FisxUser {name :: String}
  deriving (Eq, Show, GHC.Generic)

instance ToJSON FisxUser
instance FromJSON FisxUser
instance ToSchema FisxUser

-- | 'HasStatus' allows us to can get around 'WithStatus' if we want
-- to, and associate the status code with our resource types directly.
--
-- (To avoid orphan instances and make it more explicit what's in the
-- API and what isn't, we could even introduce a newtype 'Resource'
-- that wraps all the types we're using in our routing table, and then
-- define lots of 'HasStatus' instances for @Resource This@ and
-- @Resource That@.)
instance HasStatus FisxUser where
  type StatusOf FisxUser = 203

data ArianUser = ArianUser
  deriving (Eq, Show, GHC.Generic)

instance ToJSON ArianUser
instance FromJSON ArianUser
instance ToSchema ArianUser

Server, Client, Swagger

You can just respond with any of the elements of the union in handlers.

fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String])
fisx True = respond (FisxUser "fisx")
fisx False = respond (WithStatus @303 ("still fisx" :: String))

arian :: Handler (Union '[WithStatus 201 ArianUser])
arian = respond (WithStatus @201 ArianUser)

You can create client functions like you’re used to:

fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String])
arianClient :: ClientM (Union '[WithStatus 201 ArianUser])
(fisxClient :<|> arianClient) = client (Proxy @API)

… and that’s basically it! Here are a few sample commands that show you how the swagger docs look like and how you can handle the result unions in clients:

main :: IO ()
main = do
  putStrLn . cs . encodePretty $ toSwagger (Proxy @API)
  _ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian)
  threadDelay 50000
  mgr <- Client.newManager Client.defaultManagerSettings
  let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")
  result <- runClientM (fisxClient True) cenv
  print $ foldMapUnion (Proxy @Show) show <$> result
  print $ matchUnion @FisxUser <$> result
  print $ matchUnion @(WithStatus 303 String) <$> result
  pure ()

Idiomatic exceptions

Since UVerb (probably) will mostly be used for error-like responses, it may be desirable to be able to early abort handler, like with current servant one would use throwError with ServerError.

newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a }
  deriving newtype (Functor, Applicative, Monad, MonadTrans)

-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use
-- underlying monad's instance.
instance MonadError e m => MonadError e (UVerbT xs m) where
  throwError = lift . throwError
  catchError (UVerbT act) h = UVerbT $ ExceptT $
    runExceptT act `catchError` (runExceptT . unUVerbT . h)

-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler
-- may use the usual 'return'.
runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs)
runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond)

-- | Short-circuit 'UVerbT' computation returning one of the response types.
throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a
throwUVerb = UVerbT . ExceptT . fmap Left . respond

Example usage:

data Foo = Foo Int Int Int
  deriving (Show, Eq, GHC.Generic, ToJSON)
  deriving HasStatus via WithStatus 200 Foo

data Bar = Bar
  deriving (Show, Eq, GHC.Generic, ToJSON)

h :: Handler (Union '[Foo, WithStatus 400 Bar])
h = runUVerbT $ do
  when ({- something bad -} True) $
    throwUVerb $ WithStatus @400 Bar

  when ({- really bad -} False) $
    throwError $ err500

  -- a lot of code here...

  return $ Foo 1 2 3