I was thinking about how to get some sort of stack trace when a Servant handler throws an exception (like, say, an IOException).
I was ok with it not being automatic, requiring manual annotation of each function.
I was not ok with changing the type of the exception while inside the handler, or having to change throw/catch sites inside the handler. That would require some careful thought, because it might break some assumption a layer makes about the exceptions thrown by a lower layer.
I came up with this. The basic idea is, for each request, allocate an IORef that will hold the stack trace for the thread servicing the request:
-- | Just a convenient type synonym
type RIO e = ReaderT e IO
type Annotation = String
type StackTrace = [Annotation]
type StackTraceRef = IORef StackTrace
with :: (StackTraceRef -> IO r) -> IO r
with f = do
ref <- newIORef []
er <- try @SomeException (f ref)
case er of
Left exception -> case fromException @SomeAsyncException exception of
Just _ -> do
-- Asynchronous exceptions pass through undecorated.
throwIO exception
Nothing -> do
stackTrace <- readIORef ref
throwIO (ExceptionWithStackTrace stackTrace exception)
Right r -> pure r
Where the decorated exception type is
data ExceptionWithStackTrace
= ExceptionWithStackTrace StackTrace SomeException
deriving (Show)
instance Exception ExceptionWithStackTrace
So, when we want to add some debug context to a function, we can use annotate:
annotate :: Annotation -> RIO StackTraceRef a -> RIO StackTraceRef a
annotate frame action = do
ref <- ask
let clear = liftIO $ modifyIORef' ref (const [])
add = liftIO $ modifyIORef' ref (frame :)
clear
r <- withRunInIO $ \runInIO ->
runInIO action `onException` runInIO add
clear
pure r
Note that annotate only adds the annotation to the ref’s contents when an exception bubbles up. Normal entries and exits clear the ref’s contents.
How to use this in a Servant server? Imagine we have these “components”
newtype Foo m = Foo {runFoo :: m ()}
newtype Bar m = Bar {runBar :: m ()}
newtype Baz m = Baz {runBaz :: m ()}
makeFoo :: Bar m -> Foo m
makeFoo bar = Foo {runFoo = runBar bar}
makeBar :: Baz m -> Bar m
makeBar baz = Bar {runBar = runBaz baz}
makeBaz :: Baz (RIO e)
makeBaz = Baz {runBaz = liftIO $ throwIO $ userError "some exception"}
And this trivial Servant API definition
type API = PostNoContent
makeFooServer :: Foo (RIO StackTraceRef) -> ServerT API (RIO StackTraceRef)
makeFooServer foo = runFoo foo $> NoContent
We can wire the components and run the server like this
main :: IO ()
main = do
let fooServer = makeFooServer foo
-- Construct the compoents and add the stack trace annoations
foo = makeFoo bar & \Foo {runFoo} -> Foo {runFoo = StackTrace.annotate "runFoo" runFoo}
bar = makeBar baz & \Bar {runBar} -> Bar {runBar = StackTrace.annotate "runBar" runBar}
baz = makeBaz & \Baz {runBaz} -> Baz {runBaz = StackTrace.annotate "runBaz" runBaz}
-- We allocate an stack trace ref per request, when hoisting the server.
hoistRequest action = Servant.Handler $ lift $ StackTrace.with $ runReaderT action
run 8000 $ serve (Proxy @API) $ hoistServer (Proxy @API) hoistRequest fooServer
Note that we call StackTrace.with in the function that we pass to hoistServer. It will run for each request.
If we start the server and perform a curl -v -X POST localhost:8000, the following will be logged:
ExceptionWithStackTrace ["runFoo","runBar","runBaz"] user error (some exception)
This method has (at least one) problem. If we catch an exception inside a StackTrace.annotate and throw a different exception without having exited the annotate, the old exception will remain in the stack trace 
. I don’t know hot to solve this. 
Are there other problems with this method? What are other methods methods for getting “stack trace”-like context for uncaught exceptions in Servant?