309 handle application exceptions with 500 errors

servant-server/example/greet.hs

@@ -6,7 +6,6 @@
 {-# LANGUAGE TypeOperators     #-}
 
 import           Data.Aeson
-import           Data.Monoid
 import           Data.Proxy
 import           Data.Text
 import           GHC.Generics

servant-server/servant-server.cabal

@@ -87,6 +87,7 @@ library
   build-depends:
       base-compat         >= 0.10.1   && < 0.11
     , base64-bytestring   >= 1.0.0.1  && < 1.1
+    , deepseq             >= 1.4.3.0  && < 1.5
     , exceptions          >= 0.10.0   && < 0.11
     , http-api-data       >= 0.3.8.1  && < 0.4
     , http-media          >= 0.7.1.2  && < 0.8

servant-server/src/Servant/Server.hs

@@ -132,7 +132,7 @@ serve p = serveWithContext p EmptyContext
 serveWithContext :: (HasServer api context)
     => Proxy api -> Context context -> Server api -> Application
 serveWithContext p context server =
-  toApplication (runRouter (route p context (emptyDelayed (Route server))))
+  toApplication Force (runRouter (route p context (emptyDelayed (Route server))))
 
 -- | Hoist server implementation.
 --

servant-server/src/Servant/Server/Internal/Handler.hs

@@ -46,3 +46,10 @@ instance MonadBaseControl IO Handler where
 
 runHandler :: Handler a -> IO (Either ServantErr a)
 runHandler = runExceptT . runHandler'
+
+-- determins if response should be reduced to NF
+data Evaluate =
+    Force
+  | Lazy
+  deriving (Show)
+

servant-server/src/Servant/Server/Internal/RoutingApplication.hs

@@ -10,6 +10,8 @@
 {-# LANGUAGE UndecidableInstances       #-}
 module Servant.Server.Internal.RoutingApplication where
 
+import           Control.DeepSeq
+                 (force)
 import           Control.Monad
                  (ap, liftM)
 import           Control.Monad.Base
@@ -93,13 +95,20 @@ instance MonadTransControl RouteResultT where
 instance MonadThrow m => MonadThrow (RouteResultT m) where
     throwM = lift . throwM
 
-toApplication :: RoutingApplication -> Application
-toApplication ra request respond = ra request routingRespond
- where
-  routingRespond :: RouteResult Response -> IO ResponseReceived
-  routingRespond (Fail err)      = respond $ responseServantErr err
-  routingRespond (FailFatal err) = respond $ responseServantErr err
-  routingRespond (Route v)       = respond v
+toApplication :: Evaluate -> RoutingApplication -> Application
+toApplication fullyEvaluate ra request respond =
+  ra request (maybeEval routingRespond)
+  where
+    maybeEval :: (RouteResult Response -> IO ResponseReceived)
+              -> RouteResult Response -> IO ResponseReceived
+    maybeEval resp =
+      case fullyEvaluate of
+        Force -> force resp
+        Lazy  -> resp
+    routingRespond :: RouteResult Response -> IO ResponseReceived
+    routingRespond (Fail err)      = respond $ responseServantErr err
+    routingRespond (FailFatal err) = respond $ responseServantErr err
+    routingRespond (Route v)       = respond v
 
 -- | A 'Delayed' is a representation of a handler with scheduled
 -- delayed checks that can trigger errors.

servant-server/src/Servant/Server/Internal/ServantErr.hs

@@ -1,14 +1,18 @@
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE RecordWildCards    #-}
 module Servant.Server.Internal.ServantErr where
 
 import           Control.Exception
                  (Exception)
+import           Control.DeepSeq (NFData)
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy  as LBS
 import           Data.Typeable
                  (Typeable)
+import           GHC.Generics (Generic)
 import qualified Network.HTTP.Types    as HTTP
 import           Network.Wai
                  (Response, responseLBS)
@@ -17,7 +21,7 @@ data ServantErr = ServantErr { errHTTPCode     :: Int
                              , errReasonPhrase :: String
                              , errBody         :: LBS.ByteString
                              , errHeaders      :: [HTTP.Header]
-                             } deriving (Show, Eq, Read, Typeable)
+                             } deriving (Show, Eq, Read, Typeable, Generic, NFData)
 
 instance Exception ServantErr
 

servant-server/test/Servant/Server/RouterSpec.hs

@@ -31,7 +31,7 @@ spec = describe "Servant.Server.Internal.Router" $ do
 routerSpec :: Spec
 routerSpec = do
   let app' :: Application
-      app' = toApplication $ runRouter router'
+      app' = toApplication Force $ runRouter router'
 
       router', router :: Router ()
       router' = tweakResponse (fmap twk) router