|
| 1 | +# Listing alternative responses and exceptions in your API types |
| 2 | + |
| 3 | +Servant allows you to talk about the exceptions you throw in your API |
| 4 | +types. This is not limited to actual exceptions, you can write |
| 5 | +handlers that respond with arbitrary open unions of types. |
| 6 | + |
| 7 | +## Preliminaries |
| 8 | + |
| 9 | +```haskell |
| 10 | +{-# LANGUAGE ConstraintKinds #-} |
| 11 | +{-# LANGUAGE DataKinds #-} |
| 12 | +{-# LANGUAGE DeriveAnyClass #-} |
| 13 | +{-# LANGUAGE DeriveGeneric #-} |
| 14 | +{-# LANGUAGE DerivingStrategies #-} |
| 15 | +{-# LANGUAGE DerivingVia #-} |
| 16 | +{-# LANGUAGE FlexibleContexts #-} |
| 17 | +{-# LANGUAGE FlexibleInstances #-} |
| 18 | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
| 19 | +{-# LANGUAGE InstanceSigs #-} |
| 20 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 21 | +{-# LANGUAGE OverloadedStrings #-} |
| 22 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 23 | +{-# LANGUAGE StandaloneDeriving #-} |
| 24 | +{-# LANGUAGE TypeApplications #-} |
| 25 | +{-# LANGUAGE TypeFamilies #-} |
| 26 | +{-# LANGUAGE TypeOperators #-} |
| 27 | +{-# LANGUAGE UndecidableInstances #-} |
| 28 | +{-# OPTIONS_GHC -Wall -Wno-orphans #-} |
| 29 | +
|
| 30 | +import Control.Concurrent (threadDelay) |
| 31 | +import Control.Concurrent.Async (async) |
| 32 | +import Control.Monad (when) |
| 33 | +import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT) |
| 34 | +import Data.Aeson (FromJSON (..), ToJSON (..)) |
| 35 | +import Data.Aeson.Encode.Pretty (encodePretty) |
| 36 | +import Data.String.Conversions (cs) |
| 37 | +import Data.Swagger (ToSchema) |
| 38 | +import Data.Typeable (Proxy (Proxy)) |
| 39 | +import qualified GHC.Generics as GHC |
| 40 | +import qualified Network.HTTP.Client as Client |
| 41 | +import qualified Network.Wai.Handler.Warp as Warp |
| 42 | +import Servant.API |
| 43 | +import Servant.Client |
| 44 | +import Servant.Server |
| 45 | +import Servant.Swagger |
| 46 | +``` |
| 47 | +
|
| 48 | +## The API |
| 49 | +
|
| 50 | +This looks like a `Verb`-based routing table, except that `UVerb` has |
| 51 | +no status, and carries a list of response types rather than a single |
| 52 | +one. Each entry in the list carries its own response code. |
| 53 | +
|
| 54 | +```haskell |
| 55 | +type API = |
| 56 | + "fisx" :> Capture "bool" Bool |
| 57 | + :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String] |
| 58 | + :<|> "arian" |
| 59 | + :> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser] |
| 60 | +``` |
| 61 | +
|
| 62 | +Here are the details: |
| 63 | +
|
| 64 | +```haskell |
| 65 | +data FisxUser = FisxUser {name :: String} |
| 66 | + deriving (Eq, Show, GHC.Generic) |
| 67 | +
|
| 68 | +instance ToJSON FisxUser |
| 69 | +instance FromJSON FisxUser |
| 70 | +instance ToSchema FisxUser |
| 71 | +
|
| 72 | +-- | 'HasStatus' allows us to can get around 'WithStatus' if we want |
| 73 | +-- to, and associate the status code with our resource types directly. |
| 74 | +-- |
| 75 | +-- (To avoid orphan instances and make it more explicit what's in the |
| 76 | +-- API and what isn't, we could even introduce a newtype 'Resource' |
| 77 | +-- that wraps all the types we're using in our routing table, and then |
| 78 | +-- define lots of 'HasStatus' instances for @Resource This@ and |
| 79 | +-- @Resource That@.) |
| 80 | +instance HasStatus FisxUser where |
| 81 | + type StatusOf FisxUser = 203 |
| 82 | +
|
| 83 | +data ArianUser = ArianUser |
| 84 | + deriving (Eq, Show, GHC.Generic) |
| 85 | +
|
| 86 | +instance ToJSON ArianUser |
| 87 | +instance FromJSON ArianUser |
| 88 | +instance ToSchema ArianUser |
| 89 | +``` |
| 90 | +
|
| 91 | +## Server, Client, Swagger |
| 92 | +
|
| 93 | +You can just respond with any of the elements of the union in handlers. |
| 94 | +
|
| 95 | +```haskell |
| 96 | +fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String]) |
| 97 | +fisx True = respond (FisxUser "fisx") |
| 98 | +fisx False = respond (WithStatus @303 ("still fisx" :: String)) |
| 99 | + |
| 100 | +arian :: Handler (Union '[WithStatus 201 ArianUser]) |
| 101 | +arian = respond (WithStatus @201 ArianUser) |
| 102 | +``` |
| 103 | +
|
| 104 | +You can create client functions like you're used to: |
| 105 | +
|
| 106 | +``` |
| 107 | +fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String]) |
| 108 | +arianClient :: ClientM (Union '[WithStatus 201 ArianUser]) |
| 109 | +(fisxClient :<|> arianClient) = client (Proxy @API) |
| 110 | +``` |
| 111 | +
|
| 112 | +... and that's basically it! Here are a few sample commands that |
| 113 | +show you how the swagger docs look like and how you can handle the |
| 114 | +result unions in clients: |
| 115 | +
|
| 116 | +``` |
| 117 | +main :: IO () |
| 118 | +main = do |
| 119 | + putStrLn . cs . encodePretty $ toSwagger (Proxy @API) |
| 120 | + _ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian) |
| 121 | + threadDelay 50000 |
| 122 | + mgr <- Client.newManager Client.defaultManagerSettings |
| 123 | + let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "") |
| 124 | + result <- runClientM (fisxClient True) cenv |
| 125 | + print $ foldMapUnion (Proxy @Show) show <$> result |
| 126 | + print $ matchUnion @FisxUser <$> result |
| 127 | + print $ matchUnion @(WithStatus 303 String) <$> result |
| 128 | + pure () |
| 129 | +``` |
| 130 | +
|
| 131 | +## Idiomatic exceptions |
| 132 | +
|
| 133 | +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`. |
| 134 | +
|
| 135 | +```haskell |
| 136 | +newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a } |
| 137 | + deriving newtype (Functor, Applicative, Monad, MonadTrans) |
| 138 | +
|
| 139 | +-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use |
| 140 | +-- underlying monad's instance. |
| 141 | +instance MonadError e m => MonadError e (UVerbT xs m) where |
| 142 | + throwError = lift . throwError |
| 143 | + catchError (UVerbT act) h = UVerbT $ ExceptT $ |
| 144 | + runExceptT act `catchError` (runExceptT . unUVerbT . h) |
| 145 | +
|
| 146 | +-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler |
| 147 | +-- may use the usual 'return'. |
| 148 | +runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs) |
| 149 | +runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond) |
| 150 | +
|
| 151 | +-- | Short-circuit 'UVerbT' computation returning one of the response types. |
| 152 | +throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a |
| 153 | +throwUVerb = UVerbT . ExceptT . fmap Left . respond |
| 154 | +``` |
| 155 | +
|
| 156 | +Example usage: |
| 157 | +
|
| 158 | +```haskell |
| 159 | +data Foo = Foo Int Int Int |
| 160 | + deriving (Show, Eq, GHC.Generic, ToJSON) |
| 161 | + deriving HasStatus via WithStatus 200 Foo |
| 162 | +
|
| 163 | +data Bar = Bar |
| 164 | + deriving (Show, Eq, GHC.Generic, ToJSON) |
| 165 | +
|
| 166 | +h :: Handler (Union '[Foo, WithStatus 400 Bar]) |
| 167 | +h = runUVerbT $ do |
| 168 | + when ({- something bad -} True) $ |
| 169 | + throwUVerb $ WithStatus @400 Bar |
| 170 | +
|
| 171 | + when ({- really bad -} False) $ |
| 172 | + throwError $ err500 |
| 173 | +
|
| 174 | + -- a lot of code here... |
| 175 | +
|
| 176 | + return $ Foo 1 2 3 |
| 177 | +``` |
| 178 | +
|
| 179 | +## Related Work |
| 180 | +
|
| 181 | +There is the [issue from |
| 182 | +2017](https://github.com/haskell-servant/servant/issues/841) that was |
| 183 | +resolved by the introduction of `UVerb`, with a long discussion on |
| 184 | +alternative designs. |
| 185 | +
|
| 186 | +[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions) |
| 187 | +is a good solution to the problem, but it restricts the user to JSON |
| 188 | +and a very specific envelop encoding for the union type, which is |
| 189 | +often not acceptable. (One good reason for this design choice is that |
| 190 | +it makes writing clients easier, where you need to get to the union |
| 191 | +type from one representative, and you don't want to run several |
| 192 | +parsers in the hope that the ones that should will always error out so |
| 193 | +you can try until the right one returns a value.) |
| 194 | +
|
| 195 | +[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is |
| 196 | +another shot at at the problem. It is inspired by |
| 197 | +servant-checked-exceptions, so it may be worth taking a closer look. |
| 198 | +The README claims that |
| 199 | +[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has |
| 200 | +some code for generalized error handling. |
| 201 | +
|
| 202 | +In an earier version of the `UVerb` implementation, we have used some |
| 203 | +code from |
| 204 | +[world-peace](https://hackage.haskell.org/package/world-peace), but |
| 205 | +that package itself wasn't flexible enough, and we had to use |
| 206 | +[sop-core](https://hackage.haskell.org/package/sop-core) to implement |
| 207 | +the `HasServer` instance. |
| 208 | +
|
| 209 | +Here is a blog post we found on the subject: |
| 210 | +https://lukwagoallan.com/posts/unifying-servant-server-error-responses |
| 211 | +
|
| 212 | +(If you have anything else, please add it here or let us know.) |
| 213 | +
|
| 214 | +```haskell |
| 215 | +main :: IO () |
| 216 | +main = return () |
| 217 | +``` |
0 commit comments