add some basic tests for the cleanup machinery in Delayed

Author: alpmestan

servant-server/servant-server.cabal

@@ -109,6 +109,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

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)
@@ -290,9 +290,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

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