Add NFData instance

add deepseq dep
Hardcode bool param for now
This commit is contained in:
Sasa Bogicevic 2018-04-26 15:35:11 +02:00
parent ff4e2afcdf
commit 547adabfe3
4 changed files with 19 additions and 6 deletions

View file

@ -83,6 +83,7 @@ library
, base-compat >= 0.9.3 && < 0.11 , base-compat >= 0.9.3 && < 0.11
, attoparsec >= 0.13.2.0 && < 0.14 , attoparsec >= 0.13.2.0 && < 0.14
, base64-bytestring >= 1.0.0.1 && < 1.1 , base64-bytestring >= 1.0.0.1 && < 1.1
, deepseq >= 1.4.3.0 && < 1.5
, exceptions >= 0.8.3 && < 0.11 , exceptions >= 0.8.3 && < 0.11
, http-api-data >= 0.3.7.1 && < 0.4 , http-api-data >= 0.3.7.1 && < 0.4
, http-media >= 0.7.1.1 && < 0.8 , http-media >= 0.7.1.1 && < 0.8

View file

@ -125,10 +125,14 @@ import Servant.Server.Internal
serve :: (HasServer api '[]) => Proxy api -> Server api -> Application serve :: (HasServer api '[]) => Proxy api -> Server api -> Application
serve p = serveWithContext p EmptyContext serve p = serveWithContext p EmptyContext
type FullyEvaluateResponse = Bool
serveWithContext :: (HasServer api context) serveWithContext :: (HasServer api context)
=> Proxy api -> Context context -> Server api -> Application => Proxy api -> Context context -> Server api -> Application
serveWithContext p context server = serveWithContext p context server =
toApplication (runRouter (route p context (emptyDelayed (Route server)))) toApplication
False
(runRouter (route p context (emptyDelayed (Route server))))
-- | Hoist server implementation. -- | Hoist server implementation.
-- --

View file

@ -10,6 +10,7 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Servant.Server.Internal.RoutingApplication where module Servant.Server.Internal.RoutingApplication where
import Control.DeepSeq (force)
import Control.Monad (ap, liftM) import Control.Monad (ap, liftM)
import Control.Monad.Base (MonadBase (..)) import Control.Monad.Base (MonadBase (..))
import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.Catch (MonadThrow (..))
@ -84,9 +85,12 @@ instance MonadTransControl RouteResultT where
instance MonadThrow m => MonadThrow (RouteResultT m) where instance MonadThrow m => MonadThrow (RouteResultT m) where
throwM = lift . throwM throwM = lift . throwM
toApplication :: RoutingApplication -> Application toApplication :: Bool -> RoutingApplication -> Application
toApplication ra request respond = ra request routingRespond toApplication fullyEvaluate ra request respond = ra request routingRespond
where 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 :: RouteResult Response -> IO ResponseReceived
routingRespond (Fail err) = respond $ responseServantErr err routingRespond (Fail err) = respond $ responseServantErr err
routingRespond (FailFatal err) = respond $ responseServantErr err routingRespond (FailFatal err) = respond $ responseServantErr err

View file

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