From a786dc421f3504eb6439f0f64c092b370857ee1d Mon Sep 17 00:00:00 2001
From: Sasa Bogicevic <t4nt0r@protonmail.com>
Date: Mon, 9 Jul 2018 23:35:38 +0200
Subject: [PATCH] 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 10bb4d97..6c8e2855 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 c7e5f07d..587fac6a 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 95af657b..6c69bb02 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 24e920a4..0d9d10ae 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