From ff4e2afcdf837ccfbbfd2ff832f85394d21a6c0e Mon Sep 17 00:00:00 2001 From: Sasa Bogicevic Date: Thu, 26 Apr 2018 14:24:02 +0200 Subject: [PATCH 1/7] Remove duplicate import --- servant/src/Servant/Utils/Links.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 6ae8bb37b..a50712534 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -109,8 +109,6 @@ import Data.Singletons.Bool (SBool (..), SBoolI (..)) import qualified Data.Text as Text import qualified Data.Text.Encoding as TE -import Data.Type.Bool - (If) import Data.Type.Bool (If) import GHC.TypeLits From 547adabfe368e693d9686099c4f960f96586d290 Mon Sep 17 00:00:00 2001 From: Sasa Bogicevic Date: Thu, 26 Apr 2018 15:35:11 +0200 Subject: [PATCH 2/7] Add NFData instance add deepseq dep Hardcode bool param for now --- servant-server/servant-server.cabal | 1 + servant-server/src/Servant/Server.hs | 6 +++++- .../src/Servant/Server/Internal/RoutingApplication.hs | 8 ++++++-- .../src/Servant/Server/Internal/ServantErr.hs | 10 +++++++--- 4 files changed, 19 insertions(+), 6 deletions(-) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 1823eba30..ca8d14d2d 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -83,6 +83,7 @@ library , base-compat >= 0.9.3 && < 0.11 , attoparsec >= 0.13.2.0 && < 0.14 , base64-bytestring >= 1.0.0.1 && < 1.1 + , deepseq >= 1.4.3.0 && < 1.5 , exceptions >= 0.8.3 && < 0.11 , http-api-data >= 0.3.7.1 && < 0.4 , http-media >= 0.7.1.1 && < 0.8 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index f05128eaf..9b325103b 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -125,10 +125,14 @@ import Servant.Server.Internal serve :: (HasServer api '[]) => Proxy api -> Server api -> Application serve p = serveWithContext p EmptyContext +type FullyEvaluateResponse = Bool + serveWithContext :: (HasServer api context) => Proxy api -> Context context -> Server api -> Application serveWithContext p context server = - toApplication (runRouter (route p context (emptyDelayed (Route server)))) + toApplication + False + (runRouter (route p context (emptyDelayed (Route server)))) -- | Hoist server implementation. -- diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 8a01894d2..a9cc95cc3 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -10,6 +10,7 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.RoutingApplication where +import Control.DeepSeq (force) import Control.Monad (ap, liftM) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch (MonadThrow (..)) @@ -84,9 +85,12 @@ instance MonadTransControl RouteResultT where instance MonadThrow m => MonadThrow (RouteResultT m) where throwM = lift . throwM -toApplication :: RoutingApplication -> Application -toApplication ra request respond = ra request routingRespond +toApplication :: Bool -> RoutingApplication -> Application +toApplication fullyEvaluate ra request respond = ra request routingRespond where + maybeEval :: (RouteResult Response -> IO ResponseReceived) + -> RouteResult Response -> IO ResponseReceived + maybeEval resp = if fullyEvaluate then force resp else resp routingRespond :: RouteResult Response -> IO ResponseReceived routingRespond (Fail err) = respond $ responseServantErr err routingRespond (FailFatal err) = respond $ responseServantErr err diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index 82a5ccb0d..22c7ffcc9 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -1,20 +1,24 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} module Servant.Server.Internal.ServantErr where +import Control.DeepSeq (NFData) import Control.Exception (Exception) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import Data.Typeable (Typeable) import qualified Network.HTTP.Types as HTTP import Network.Wai (Response, responseLBS) +import GHC.Generics (Generic) 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 From a90b6716072c9b2b1cdc87f1c8c2022cd8267711 Mon Sep 17 00:00:00 2001 From: Sasa Bogicevic Date: Thu, 26 Apr 2018 15:51:37 +0200 Subject: [PATCH 3/7] Fix all errors --- servant-server/src/Servant/Server.hs | 7 +++--- .../Server/Internal/RoutingApplication.hs | 22 +++++++++++-------- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 9b325103b..350606b9d 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -122,16 +122,15 @@ import Servant.Server.Internal -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- -serve :: (HasServer api '[]) => Proxy api -> Server api -> Application -serve p = serveWithContext p EmptyContext -type FullyEvaluateResponse = Bool +serve :: (HasServer api '[Bool]) => Proxy api -> Server api -> Application +serve p = serveWithContext p (False :. EmptyContext) serveWithContext :: (HasServer api context) => Proxy api -> Context context -> Server api -> Application serveWithContext p context server = toApplication - False + False -- determins if we should fully evaluate response (runRouter (route p context (emptyDelayed (Route server)))) -- | Hoist server implementation. diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index a9cc95cc3..5ac4b6676 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -86,15 +86,19 @@ instance MonadThrow m => MonadThrow (RouteResultT m) where throwM = lift . throwM toApplication :: Bool -> RoutingApplication -> Application -toApplication fullyEvaluate ra request respond = ra request routingRespond - where - maybeEval :: (RouteResult Response -> IO ResponseReceived) - -> RouteResult Response -> IO ResponseReceived - maybeEval resp = if fullyEvaluate then force resp else resp - routingRespond :: RouteResult Response -> IO ResponseReceived - routingRespond (Fail err) = respond $ responseServantErr err - routingRespond (FailFatal err) = respond $ responseServantErr err - routingRespond (Route v) = respond v +toApplication fullyEvaluate ra request respond = + ra request (maybeEval routingRespond) + where + maybeEval :: (RouteResult Response -> IO ResponseReceived) + -> RouteResult Response -> IO ResponseReceived + maybeEval resp = + if fullyEvaluate + then force resp + else 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. From 4d46e98419fa1ce69cdf8a689460c558a3879bdf Mon Sep 17 00:00:00 2001 From: Sasa Bogicevic Date: Fri, 27 Apr 2018 11:03:37 +0200 Subject: [PATCH 4/7] Remove hardcoded param in serveWithContext --- servant-server/src/Servant/Server.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 350606b9d..c5c4e1fe9 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -126,11 +126,12 @@ import Servant.Server.Internal serve :: (HasServer api '[Bool]) => Proxy api -> Server api -> Application serve p = serveWithContext p (False :. EmptyContext) -serveWithContext :: (HasServer api context) +serveWithContext :: (HasServer api context, HasContextEntry context Bool) => Proxy api -> Context context -> Server api -> Application serveWithContext p context server = toApplication - False -- determins if we should fully evaluate response + (getContextEntry context :: Bool) + -- ^ determins if we should fully evaluate response (runRouter (route p context (emptyDelayed (Route server)))) -- | Hoist server implementation. From 3d9a151412db831d93511d201c741d43153de668 Mon Sep 17 00:00:00 2001 From: Sasa Bogicevic Date: Fri, 27 Apr 2018 11:34:03 +0200 Subject: [PATCH 5/7] Add helper functions --- servant-server/src/Servant/Server.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index c5c4e1fe9..732038f42 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -10,6 +10,8 @@ module Servant.Server ( -- * Run a wai application from an API serve , serveWithContext + , fullyEvalResponse + , noEvalResponse , -- * Construct a wai Application from an API toApplication @@ -124,16 +126,23 @@ import Servant.Server.Internal -- serve :: (HasServer api '[Bool]) => Proxy api -> Server api -> Application -serve p = serveWithContext p (False :. EmptyContext) +serve p = serveWithContext p noEvalResponse serveWithContext :: (HasServer api context, HasContextEntry context Bool) => Proxy api -> Context context -> Server api -> Application serveWithContext p context server = toApplication - (getContextEntry context :: Bool) + ((getContextEntry context :: Bool) || False) -- ^ determins if we should fully evaluate response + -- defaults to False (runRouter (route p context (emptyDelayed (Route server)))) +fullyEvalResponse :: Context '[Bool] +fullyEvalResponse = True :. EmptyContext + +noEvalResponse :: Context '[Bool] +noEvalResponse = False :. EmptyContext + -- | Hoist server implementation. -- -- Sometimes our cherished `Handler` monad isn't quite the type you'd like for From 465e0b8f10edb174e9741d9f07f511f925c06970 Mon Sep 17 00:00:00 2001 From: Sasa Bogicevic Date: Fri, 6 Jul 2018 17:10:15 +0200 Subject: [PATCH 6/7] Make everyting compile again --- servant-server/example/greet.hs | 1 - servant-server/src/Servant/Server.hs | 21 ++++----------------- 2 files changed, 4 insertions(+), 18 deletions(-) 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/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 85c0568d8..10bb4d975 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -10,8 +10,6 @@ module Servant.Server ( -- * Run a wai application from an API serve , serveWithContext - , fullyEvalResponse - , noEvalResponse , -- * Construct a wai Application from an API toApplication @@ -128,24 +126,13 @@ import Servant.Server.Internal -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- +serve :: (HasServer api '[]) => Proxy api -> Server api -> Application +serve p = serveWithContext p EmptyContext -serve :: (HasServer api '[Bool]) => Proxy api -> Server api -> Application -serve p = serveWithContext p noEvalResponse - -serveWithContext :: (HasServer api context, HasContextEntry context Bool) +serveWithContext :: (HasServer api context) => Proxy api -> Context context -> Server api -> Application serveWithContext p context server = - toApplication - ((getContextEntry context :: Bool) || False) - -- ^ determins if we should fully evaluate response - -- defaults to False - (runRouter (route p context (emptyDelayed (Route server)))) - -fullyEvalResponse :: Context '[Bool] -fullyEvalResponse = True :. EmptyContext - -noEvalResponse :: Context '[Bool] -noEvalResponse = False :. EmptyContext + toApplication True (runRouter (route p context (emptyDelayed (Route server)))) -- | Hoist server implementation. -- From a786dc421f3504eb6439f0f64c092b370857ee1d Mon Sep 17 00:00:00 2001 From: Sasa Bogicevic Date: Mon, 9 Jul 2018 23:35:38 +0200 Subject: [PATCH 7/7] Use Evaluate instead of Bool --- servant-server/src/Servant/Server.hs | 2 +- servant-server/src/Servant/Server/Internal/Handler.hs | 7 +++++++ .../src/Servant/Server/Internal/RoutingApplication.hs | 8 ++++---- servant-server/test/Servant/Server/RouterSpec.hs | 2 +- 4 files changed, 13 insertions(+), 6 deletions(-) diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 10bb4d975..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 True (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 95af657bd..6c69bb022 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -95,16 +95,16 @@ instance MonadTransControl RouteResultT where instance MonadThrow m => MonadThrow (RouteResultT m) where throwM = lift . throwM -toApplication :: Bool -> RoutingApplication -> Application +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 = - if fullyEvaluate - then force resp - else 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 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