diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 662c2c33f..d4121ab41 100644 --- a/servant-server/example/greet.hs +++ b/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 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 6b0bee2ee..7c38bbee5 100644 --- a/servant-server/servant-server.cabal +++ b/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 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 5c8d40e6d..6c8e28550 100644 --- a/servant-server/src/Servant/Server.hs +++ b/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. -- diff --git a/servant-server/src/Servant/Server/Internal/Handler.hs b/servant-server/src/Servant/Server/Internal/Handler.hs index c7e5f07d7..587fac6a6 100644 --- a/servant-server/src/Servant/Server/Internal/Handler.hs +++ b/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) + diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index acd0db143..6c69bb022 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/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. diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index 766d92a19..86dc7570f 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/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 diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs index 24e920a49..0d9d10aea 100644 --- a/servant-server/test/Servant/Server/RouterSpec.hs +++ b/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