diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 9179cf67..8aaf0a95 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -102,6 +102,7 @@ test-suite spec Servant.ArbitraryMonadServerSpec Servant.Server.ErrorSpec Servant.Server.Internal.ContextSpec + Servant.Server.Internal.RoutingApplicationSpec Servant.Server.RouterSpec Servant.Server.StreamingSpec Servant.Server.UsingContextSpec diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 785bac26..bf36cbb9 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -9,7 +9,7 @@ {-# LANGUAGE TupleSections #-} module Servant.Server.Internal.RoutingApplication where -import Control.Exception (bracket) +import Control.Exception (finally) import Control.Monad (ap, liftM, (>=>)) import Control.Monad.Trans (MonadIO(..)) import Control.Monad.Trans.Except (runExceptT) @@ -289,9 +289,8 @@ runAction :: Delayed env (Handler a) -> IO r runAction action env req respond k = do cleanupRef <- newCleanupRef - bracket (runDelayed action env req cleanupRef) - (const $ runCleanup cleanupRef) - (go >=> respond) + (runDelayed action env req cleanupRef >>= go >>= respond) + `finally` runCleanup cleanupRef where go (Fail e) = return $ Fail e diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs new file mode 100644 index 00000000..c0c400ca --- /dev/null +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -0,0 +1,51 @@ +module Servant.Server.Internal.RoutingApplicationSpec (spec) where + +import Control.Exception hiding (Handler) +import Control.Monad.IO.Class +import Servant.Server +import Servant.Server.Internal.RoutingApplication +import System.Directory +import Test.Hspec + +ok :: IO (RouteResult ()) +ok = return (Route ()) + +delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ()) +delayed body srv = Delayed + { capturesD = \() -> DelayedIO $ \_req _cl -> ok + , methodD = DelayedIO $ \_req_ _cl -> ok + , authD = DelayedIO $ \_req _cl -> ok + , bodyD = do + liftIO (writeFile "delayed.test" "hia") + addCleanup (removeFile "delayed.test" >> putStrLn "file removed") + body + , serverD = \() () _body _req -> srv + } + +simpleRun :: Delayed () (Handler ()) + -> IO () +simpleRun d = fmap (either ignoreE id) . try $ + runAction d () undefined (\_ -> return ()) (\_ -> FailFatal err500) + + where ignoreE :: SomeException -> () + ignoreE = const () + +spec :: Spec +spec = do + describe "Delayed" $ do + it "actually runs clean up actions" $ do + _ <- simpleRun $ delayed (return ()) (Route $ return ()) + fileStillThere <- doesFileExist "delayed.test" + fileStillThere `shouldBe` False + it "even with exceptions in serverD" $ do + _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero) + fileStillThere <- doesFileExist "delayed.test" + fileStillThere `shouldBe` False + it "even with routing failure in bodyD" $ do + _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ()) + fileStillThere <- doesFileExist "delayed.test" + fileStillThere `shouldBe` False + it "even with exceptions in bodyD" $ do + _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ()) + fileStillThere <- doesFileExist "delayed.test" + fileStillThere `shouldBe` False