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

Expose ResourceT, fix the test

Browse source
This commit is contained in:
Oleg Grenrus 2017-01-18 12:25:18 +02:00
parent 091f6f4412
commit 2caabad61a
2 changed files with 10 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -24,6 +24,7 @@ module Servant.Server.Internal
) where ) where
import Control.Monad.Trans (liftIO) import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Resource (runResourceT)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
@ -399,12 +400,12 @@ instance HasServer Raw context where
type ServerT Raw m = Application 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 -- note: a Raw application doesn't register any cleanup
-- but for the sake of consistency, we nonetheless run -- but for the sake of consistency, we nonetheless run
-- the cleanup once its done -- the cleanup once its done
r <- runDelayed rawApplication env request r <- runDelayed rawApplication env request
go r request respond liftIO $ go r request respond
where go r request respond = case r of where go r request respond = case r of
Route app -> app request (respond . Route) Route app -> app request (respond . Route)

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

@ -21,7 +21,7 @@ import Control.Monad.Reader (MonadReader (..), ReaderT,
import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans (MonadIO (..), MonadTrans (..))
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..),
defaultLiftBaseWith, defaultRestoreM) 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 Network.Wai (Application, Request, Response, ResponseReceived)
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
@ -197,8 +197,8 @@ instance MonadBaseControl IO DelayedIO where
liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO') liftBaseWith f = DelayedIO $ liftBaseWith $ \g -> f (g . runDelayedIO')
restoreM = DelayedIO . restoreM restoreM = DelayedIO . restoreM
runDelayedIO :: DelayedIO a -> Request -> IO (RouteResult a) runDelayedIO :: DelayedIO a -> Request -> ResourceT IO (RouteResult a)
runDelayedIO m req = runRouteResultT $ runResourceT $ runReaderT (runDelayedIO' m) req runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO' m) req
-- | A 'Delayed' without any stored checks. -- | A 'Delayed' without any stored checks.
emptyDelayed :: RouteResult a -> Delayed env a emptyDelayed :: RouteResult a -> Delayed env a
@ -303,7 +303,7 @@ passToServer Delayed{..} x =
runDelayed :: Delayed env a runDelayed :: Delayed env a
-> env -> env
-> Request -> Request
-> IO (RouteResult a) -> ResourceT IO (RouteResult a)
runDelayed Delayed{..} env req = runDelayed Delayed{..} env req =
runDelayedIO runDelayedIO
(do c <- capturesD env (do c <- capturesD env
@ -325,12 +325,12 @@ runAction :: Delayed env (Handler a)
-> (RouteResult Response -> IO r) -> (RouteResult Response -> IO r)
-> (a -> RouteResult Response) -> (a -> RouteResult Response)
-> IO r -> IO r
runAction action env req respond k = do runAction action env req respond k = runResourceT $ do
runDelayed action env req >>= go >>= respond runDelayed action env req >>= go >>= liftIO . respond
where where
go (Fail e) = return $ Fail e go (Fail e) = return $ Fail e
go (FailFatal e) = return $ FailFatal e go (FailFatal e) = return $ FailFatal e
go (Route a) = do go (Route a) = liftIO $ do
e <- runHandler a e <- runHandler a
case e of case e of
Left err -> return . Route $ responseServantErr err Left err -> return . Route $ responseServantErr err