Add NFData instance
add deepseq dep Hardcode bool param for now
This commit is contained in:
parent
ff4e2afcdf
commit
547adabfe3
4 changed files with 19 additions and 6 deletions
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
--
|
--
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue