From 6aab9becb95038261b77ea8390a189456d88789e Mon Sep 17 00:00:00 2001
From: Alp Mestanogullari <alpmestan@gmail.com>
Date: Thu, 12 Jan 2017 02:58:29 +0100
Subject: [PATCH] add some basic tests for the cleanup machinery in Delayed

---
 servant-server/servant-server.cabal           |  1 +
 .../Server/Internal/RoutingApplication.hs     |  7 ++-
 .../Server/Internal/RoutingApplicationSpec.hs | 51 +++++++++++++++++++
 3 files changed, 55 insertions(+), 4 deletions(-)
 create mode 100644 servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs

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