eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Add NFData instance

Browse source 
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
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-server/servant-server.cabal
View file

@ -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

6
servant-server/src/Servant/Server.hs
View file

@ -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.
--

8
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

@ -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

10
servant-server/src/Servant/Server/Internal/ServantErr.hs
View file

@ -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