diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 2fad4452..62b92612 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -24,6 +24,7 @@ module Servant.Server.Internal ) where import Control.Monad.Trans (liftIO) +import Control.Monad.Trans.Resource (runResourceT) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL @@ -399,12 +400,12 @@ instance HasServer Raw context where type ServerT Raw m = Application - route Proxy _ rawApplication = RawRouter $ \ env request respond -> do + route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do -- note: a Raw application doesn't register any cleanup -- but for the sake of consistency, we nonetheless run -- the cleanup once its done r <- runDelayed rawApplication env request - go r request respond + liftIO $ go r request respond where go r request respond = case r of Route app -> app request (respond . Route) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 131f4ee9..5a13b843 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -21,7 +21,7 @@ import Control.Monad.Reader (MonadReader (..), ReaderT, import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), defaultLiftBaseWith, defaultRestoreM) -import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT) +import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT, transResourceT) import Network.Wai (Application, Request, Response, ResponseReceived) import Prelude () import Prelude.Compat @@ -197,8 +197,8 @@ instance MonadBaseControl IO DelayedIO where liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO') restoreM = DelayedIO . restoreM -runDelayedIO :: DelayedIO a -> Request -> IO (RouteResult a) -runDelayedIO m req = runRouteResultT $ runResourceT $ runReaderT (runDelayedIO' m) req +runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a) +runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req -- | A 'Delayed' without any stored checks. emptyDelayed :: RouteResult a -> Delayed env a @@ -303,7 +303,7 @@ passToServer Delayed{..} x = runDelayed :: Delayed env a -> env -> Request - -> IO (RouteResult a) + -> ResourceT IO (RouteResult a) runDelayed Delayed{..} env req = runDelayedIO (do c <- capturesD env @@ -325,12 +325,12 @@ runAction :: Delayed env (Handler a) -> (RouteResult Response -> IO r) -> (a -> RouteResult Response) -> IO r -runAction action env req respond k = do - runDelayed action env req >>= go >>= respond +runAction action env req respond k = runResourceT $ do + runDelayed action env req >>= go >>= liftIO . respond where go (Fail e) = return $ Fail e go (FailFatal e) = return $ FailFatal e - go (Route a) = do + go (Route a) = liftIO $ do e <- runHandler a case e of Left err -> return . Route $ responseServantErr err