From 124c6de1eb9390b3b9ceebfecdb1224efdb68639 Mon Sep 17 00:00:00 2001
From: Alp Mestanogullari <alpmestan@gmail.com>
Date: Sat, 15 Oct 2016 12:02:30 +0200
Subject: [PATCH 1/7] add a field in Delayed that lets us specify a clean up
 action that can use the result of bodyD to perform some IO clean up operation

---
 servant-server/src/Servant/Server/Internal.hs |  2 +-
 .../Server/Internal/RoutingApplication.hs     | 41 +++++++++++++------
 2 files changed, 30 insertions(+), 13 deletions(-)

diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index 7c89b8f5..9a27a4dc 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -400,7 +400,7 @@ instance HasServer Raw context where
   type ServerT Raw m = Application
 
   route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
-    r <- runDelayed rawApplication env request
+    (r, _) <- runDelayed rawApplication env request
     case r of
       Route app   -> app request (respond . Route)
       Fail a      -> respond $ Fail a
diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
index 85fb04dc..ec6fc1e6 100644
--- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
+++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
@@ -6,10 +6,13 @@
 {-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TupleSections              #-}
 module Servant.Server.Internal.RoutingApplication where
 
 import           Control.Monad                      (ap, liftM)
 import           Control.Monad.Trans                (MonadIO(..))
+import           Control.Monad.Trans.Except         (runExceptT)
+import           Data.IORef                         (newIORef, readIORef, writeIORef)
 import           Network.Wai                        (Application, Request,
                                                      Response, ResponseReceived)
 import           Prelude                            ()
@@ -103,6 +106,10 @@ data Delayed env c where
              , authD     :: DelayedIO auth
              , bodyD     :: DelayedIO body
              , serverD   :: captures -> auth -> body -> Request -> RouteResult c
+             , cleanupD  :: body -> IO ()
+               -- not in DelayedIO because:
+               -- - most likely should not depend on the request
+               -- - simpler
              } -> Delayed env c
 
 instance Functor (Delayed env) where
@@ -142,7 +149,7 @@ instance MonadIO DelayedIO where
 -- | A 'Delayed' without any stored checks.
 emptyDelayed :: RouteResult a -> Delayed env a
 emptyDelayed result =
-  Delayed (const r) r r r (\ _ _ _ _ -> result)
+  Delayed (const r) r r r (\ _ _ _ _ -> result) (const $ return ())
   where
     r = return ()
 
@@ -196,8 +203,9 @@ addBodyCheck :: Delayed env (a -> b)
              -> Delayed env b
 addBodyCheck Delayed{..} new =
   Delayed
-    { bodyD   = (,) <$> bodyD <*> new
-    , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
+    { bodyD    = (,) <$> bodyD <*> new
+    , serverD  = \ c a (z, v) req -> ($ v) <$> serverD c a z req
+    , cleanupD = cleanupD . fst -- not sure that's right
     , ..
     } -- Note [Existential Record Update]
 
@@ -240,13 +248,19 @@ passToServer Delayed{..} x =
 runDelayed :: Delayed env a
            -> env
            -> Request
-           -> IO (RouteResult a)
-runDelayed Delayed{..} env = runDelayedIO $ do
-  c <- capturesD env
-  methodD
-  a <- authD
-  b <- bodyD
-  DelayedIO (\ req -> return $ serverD c a b req)
+           -> IO (RouteResult a, IO ())
+runDelayed Delayed{..} env req = do
+  cleanupRef <- newIORef (return ())
+  routeRes <- runDelayedIO
+    (do c <- capturesD env
+        methodD
+        a <- authD
+        b <- bodyD
+        liftIO (writeIORef cleanupRef $ cleanupD b)
+        DelayedIO $ \ req -> return (serverD c a b req)
+    )
+    req
+  fmap (routeRes,) $ readIORef cleanupRef
 
 -- | Runs a delayed server and the resulting action.
 -- Takes a continuation that lets us send a response.
@@ -258,8 +272,11 @@ runAction :: Delayed env (Handler a)
           -> (RouteResult Response -> IO r)
           -> (a -> RouteResult Response)
           -> IO r
-runAction action env req respond k =
-  runDelayed action env req >>= go >>= respond
+runAction action env req respond k = do
+  (routeResult, cleanup) <- runDelayed action env req
+  resp <- go routeResult
+  cleanup
+  respond resp
   where
     go (Fail e)      = return $ Fail e
     go (FailFatal e) = return $ FailFatal e

From 6ab0296d62aac99af386280447dc7227da4fc9e3 Mon Sep 17 00:00:00 2001
From: Alp Mestanogullari <alpmestan@gmail.com>
Date: Sun, 16 Oct 2016 10:21:01 +0200
Subject: [PATCH 2/7] fix a warning

---
 .../src/Servant/Server/Internal/RoutingApplication.hs           | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
index ec6fc1e6..5389dd53 100644
--- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
+++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
@@ -257,7 +257,7 @@ runDelayed Delayed{..} env req = do
         a <- authD
         b <- bodyD
         liftIO (writeIORef cleanupRef $ cleanupD b)
-        DelayedIO $ \ req -> return (serverD c a b req)
+        DelayedIO $ \ r -> return (serverD c a b r)
     )
     req
   fmap (routeRes,) $ readIORef cleanupRef

From 7fb11dae3c0eeb88bde0f1c7ebd068b7d999307a Mon Sep 17 00:00:00 2001
From: Alp Mestanogullari <alpmestan@gmail.com>
Date: Fri, 21 Oct 2016 19:24:15 +0200
Subject: [PATCH 3/7] make cleanup in Delayed more resistant to exceptions

---
 servant-server/src/Servant/Server/Internal.hs       | 13 ++++++++-----
 .../Servant/Server/Internal/RoutingApplication.hs   | 11 ++++++-----
 2 files changed, 14 insertions(+), 10 deletions(-)

diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index 9a27a4dc..89fd133e 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -23,6 +23,7 @@ module Servant.Server.Internal
   , module Servant.Server.Internal.ServantErr
   ) where
 
+import           Control.Exception          (finally)
 import           Control.Monad.Trans        (liftIO)
 import qualified Data.ByteString            as B
 import qualified Data.ByteString.Char8      as BC8
@@ -400,11 +401,13 @@ instance HasServer Raw context where
   type ServerT Raw m = Application
 
   route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
-    (r, _) <- runDelayed rawApplication env request
-    case r of
-      Route app   -> app request (respond . Route)
-      Fail a      -> respond $ Fail a
-      FailFatal e -> respond $ FailFatal e
+    (r, cleanup) <- runDelayed rawApplication env request
+    go r request respond `finally` cleanup
+
+    where go r request respond = case r of
+            Route app   -> app request (respond . Route)
+            Fail a      -> respond $ Fail a
+            FailFatal e -> respond $ FailFatal e
 
 -- | If you use 'ReqBody' in one of the endpoints for your API,
 -- this automatically requires your server-side handler to be a function
diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
index 5389dd53..247ea590 100644
--- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
+++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
@@ -9,6 +9,7 @@
 {-# LANGUAGE TupleSections              #-}
 module Servant.Server.Internal.RoutingApplication where
 
+import           Control.Exception                  (bracket)
 import           Control.Monad                      (ap, liftM)
 import           Control.Monad.Trans                (MonadIO(..))
 import           Control.Monad.Trans.Except         (runExceptT)
@@ -272,11 +273,11 @@ runAction :: Delayed env (Handler a)
           -> (RouteResult Response -> IO r)
           -> (a -> RouteResult Response)
           -> IO r
-runAction action env req respond k = do
-  (routeResult, cleanup) <- runDelayed action env req
-  resp <- go routeResult
-  cleanup
-  respond resp
+runAction action env req respond k =
+  bracket (runDelayed action env req)
+          snd
+          (\(res, _) -> go res >>= respond)
+
   where
     go (Fail e)      = return $ Fail e
     go (FailFatal e) = return $ FailFatal e

From 5d1f03ba1a6aa7b69e905c60c309715f691da4aa Mon Sep 17 00:00:00 2001
From: Alp Mestanogullari <alpmestan@gmail.com>
Date: Mon, 24 Oct 2016 19:21:28 +0200
Subject: [PATCH 4/7] use an ioref to store clean up actions instead of a field
 in Delayed, allowing early clean up registration

---
 servant-server/src/Servant/Server/Internal.hs |  8 ++-
 .../Server/Internal/RoutingApplication.hs     | 72 +++++++++++--------
 2 files changed, 50 insertions(+), 30 deletions(-)

diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index 89fd133e..890c1856 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -401,8 +401,12 @@ instance HasServer Raw context where
   type ServerT Raw m = Application
 
   route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
-    (r, cleanup) <- runDelayed rawApplication env request
-    go r request respond `finally` cleanup
+    -- note: a Raw application doesn't register any cleanup
+    -- but for the sake of consistency, we nonetheless run
+    -- the cleanup once its done
+    cleanupRef <- newCleanupRef
+    r <- runDelayed rawApplication env request cleanupRef
+    go r request respond `finally` runCleanup cleanupRef
 
     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 247ea590..31e84341 100644
--- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
+++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
@@ -10,10 +10,10 @@
 module Servant.Server.Internal.RoutingApplication where
 
 import           Control.Exception                  (bracket)
-import           Control.Monad                      (ap, liftM)
+import           Control.Monad                      (ap, liftM, (>=>))
 import           Control.Monad.Trans                (MonadIO(..))
 import           Control.Monad.Trans.Except         (runExceptT)
-import           Data.IORef                         (newIORef, readIORef, writeIORef)
+import           Data.IORef                         (newIORef, readIORef, writeIORef, IORef, atomicModifyIORef)
 import           Network.Wai                        (Application, Request,
                                                      Response, ResponseReceived)
 import           Prelude                            ()
@@ -107,10 +107,6 @@ data Delayed env c where
              , authD     :: DelayedIO auth
              , bodyD     :: DelayedIO body
              , serverD   :: captures -> auth -> body -> Request -> RouteResult c
-             , cleanupD  :: body -> IO ()
-               -- not in DelayedIO because:
-               -- - most likely should not depend on the request
-               -- - simpler
              } -> Delayed env c
 
 instance Functor (Delayed env) where
@@ -120,12 +116,33 @@ instance Functor (Delayed env) where
       , ..
       } -- Note [Existential Record Update]
 
+-- | A mutable cleanup action
+newtype CleanupRef = CleanupRef (IORef (IO ()))
+
+newCleanupRef :: IO CleanupRef
+newCleanupRef = CleanupRef <$> newIORef (return ())
+
+-- | Add a clean up action to a 'CleanupRef'
+addCleanup' :: IO () -> CleanupRef -> IO ()
+addCleanup' act (CleanupRef ref) = atomicModifyIORef ref (\act' -> (act' >> act, ()))
+
+addCleanup :: IO () -> DelayedIO ()
+addCleanup act = DelayedIO $ \_req cleanupRef ->
+  addCleanup' act cleanupRef >> return (Route ())
+
+-- | Run all the clean up actions registered in
+--   a 'CleanupRef'.
+runCleanup :: CleanupRef -> IO ()
+runCleanup (CleanupRef ref) = do
+  act <- readIORef ref
+  act
+
 -- | Computations used in a 'Delayed' can depend on the
 -- incoming 'Request', may perform 'IO, and result in a
 -- 'RouteResult, meaning they can either suceed, fail
 -- (with the possibility to recover), or fail fatally.
 --
-newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> IO (RouteResult a) }
+newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> CleanupRef -> IO (RouteResult a) }
 
 instance Functor DelayedIO where
   fmap = liftM
@@ -135,36 +152,36 @@ instance Applicative DelayedIO where
   (<*>) = ap
 
 instance Monad DelayedIO where
-  return x = DelayedIO (const $ return (Route x))
+  return x = DelayedIO (\_req _cleanup -> return (Route x))
   DelayedIO m >>= f =
-    DelayedIO $ \ req -> do
-      r <- m req
+    DelayedIO $ \ req cl -> do
+      r <- m req cl
       case r of
         Fail      e -> return $ Fail e
         FailFatal e -> return $ FailFatal e
-        Route     a -> runDelayedIO (f a) req
+        Route     a -> runDelayedIO (f a) req cl
 
 instance MonadIO DelayedIO where
-  liftIO m = DelayedIO (const $ Route <$> m)
+  liftIO m = DelayedIO (\_req _cl -> Route <$> m)
 
 -- | A 'Delayed' without any stored checks.
 emptyDelayed :: RouteResult a -> Delayed env a
 emptyDelayed result =
-  Delayed (const r) r r r (\ _ _ _ _ -> result) (const $ return ())
+  Delayed (const r) r r r (\ _ _ _ _ -> result)
   where
     r = return ()
 
 -- | Fail with the option to recover.
 delayedFail :: ServantErr -> DelayedIO a
-delayedFail err = DelayedIO (const $ return $ Fail err)
+delayedFail err = DelayedIO (\_req _cleanup -> return $ Fail err)
 
 -- | Fail fatally, i.e., without any option to recover.
 delayedFailFatal :: ServantErr -> DelayedIO a
-delayedFailFatal err = DelayedIO (const $ return $ FailFatal err)
+delayedFailFatal err = DelayedIO (\_req _cleanup -> return $ FailFatal err)
 
 -- | Gain access to the incoming request.
 withRequest :: (Request -> DelayedIO a) -> DelayedIO a
-withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)
+withRequest f = DelayedIO (\ req cl -> runDelayedIO (f req) req cl)
 
 -- | Add a capture to the end of the capture block.
 addCapture :: Delayed env (a -> b)
@@ -206,7 +223,6 @@ addBodyCheck Delayed{..} new =
   Delayed
     { bodyD    = (,) <$> bodyD <*> new
     , serverD  = \ c a (z, v) req -> ($ v) <$> serverD c a z req
-    , cleanupD = cleanupD . fst -- not sure that's right
     , ..
     } -- Note [Existential Record Update]
 
@@ -249,19 +265,18 @@ passToServer Delayed{..} x =
 runDelayed :: Delayed env a
            -> env
            -> Request
-           -> IO (RouteResult a, IO ())
-runDelayed Delayed{..} env req = do
-  cleanupRef <- newIORef (return ())
-  routeRes <- runDelayedIO
+           -> CleanupRef
+           -> IO (RouteResult a)
+runDelayed Delayed{..} env req cleanupRef =
+  runDelayedIO
     (do c <- capturesD env
         methodD
         a <- authD
         b <- bodyD
-        liftIO (writeIORef cleanupRef $ cleanupD b)
-        DelayedIO $ \ r -> return (serverD c a b r)
+        DelayedIO $ \ r _cleanup -> return (serverD c a b r)
     )
     req
-  fmap (routeRes,) $ readIORef cleanupRef
+    cleanupRef
 
 -- | Runs a delayed server and the resulting action.
 -- Takes a continuation that lets us send a response.
@@ -273,10 +288,11 @@ runAction :: Delayed env (Handler a)
           -> (RouteResult Response -> IO r)
           -> (a -> RouteResult Response)
           -> IO r
-runAction action env req respond k =
-  bracket (runDelayed action env req)
-          snd
-          (\(res, _) -> go res >>= respond)
+runAction action env req respond k = do
+  cleanupRef <- newCleanupRef
+  bracket (runDelayed action env req cleanupRef)
+          (const $ runCleanup cleanupRef)
+          (go >=> respond)
 
   where
     go (Fail e)      = return $ Fail e

From 92786feeada3a81074f4e8bd62c93436633d392f Mon Sep 17 00:00:00 2001
From: Alp Mestanogullari <alpmestan@gmail.com>
Date: Thu, 12 Jan 2017 02:58:29 +0100
Subject: [PATCH 5/7] 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 fc07f74a..fb03edd7 100644
--- a/servant-server/servant-server.cabal
+++ b/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
diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
index 31e84341..03ff57ab 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)
@@ -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
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

From bc13d5cd3eb7628ccaee66d37a28917d7a120ce4 Mon Sep 17 00:00:00 2001
From: Alp Mestanogullari <alpmestan@gmail.com>
Date: Thu, 12 Jan 2017 03:01:49 +0100
Subject: [PATCH 6/7] warning free

---
 .../src/Servant/Server/Internal/RoutingApplication.hs        | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
index 03ff57ab..e8bd7bc6 100644
--- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
+++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs
@@ -10,10 +10,9 @@
 module Servant.Server.Internal.RoutingApplication where
 
 import           Control.Exception                  (finally)
-import           Control.Monad                      (ap, liftM, (>=>))
+import           Control.Monad                      (ap, liftM)
 import           Control.Monad.Trans                (MonadIO(..))
-import           Control.Monad.Trans.Except         (runExceptT)
-import           Data.IORef                         (newIORef, readIORef, writeIORef, IORef, atomicModifyIORef)
+import           Data.IORef                         (newIORef, readIORef, IORef, atomicModifyIORef)
 import           Network.Wai                        (Application, Request,
                                                      Response, ResponseReceived)
 import           Prelude                            ()

From 60ee1ab5706a4650a50a2bb2492bdf6cd7786847 Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Tue, 17 Jan 2017 22:36:28 +0200
Subject: [PATCH 7/7] Rewrite delayed cleanup tests using IORefs

---
 .../Server/Internal/RoutingApplicationSpec.hs | 32 ++++++++++++-------
 1 file changed, 21 insertions(+), 11 deletions(-)

diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs
index c0c400ca..abdf016d 100644
--- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs
+++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs
@@ -1,23 +1,33 @@
 module Servant.Server.Internal.RoutingApplicationSpec (spec) where
 
+import Prelude ()
+import Prelude.Compat
+
 import Control.Exception hiding (Handler)
 import Control.Monad.IO.Class
+import Data.Maybe (isJust)
+import Data.IORef
 import Servant.Server
 import Servant.Server.Internal.RoutingApplication
-import System.Directory
 import Test.Hspec
 
+import System.IO.Unsafe (unsafePerformIO)
+
 ok :: IO (RouteResult ())
 ok = return (Route ())
 
+-- Let's not write to the filesystem
+delayedTestRef :: IORef (Maybe String)
+delayedTestRef = unsafePerformIO $ newIORef Nothing
+
 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")
+      liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created")
+      addCleanup (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected")
       body
   , serverD = \() () _body _req -> srv
   }
@@ -35,17 +45,17 @@ spec = do
   describe "Delayed" $ do
     it "actually runs clean up actions" $ do
       _ <- simpleRun $ delayed (return ()) (Route $ return ())
-      fileStillThere <- doesFileExist "delayed.test"
-      fileStillThere `shouldBe` False
+      cleanUpDone <- isJust <$> readIORef delayedTestRef
+      cleanUpDone `shouldBe` False
     it "even with exceptions in serverD" $ do
       _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
-      fileStillThere <- doesFileExist "delayed.test"
-      fileStillThere `shouldBe` False
+      cleanUpDone <- isJust <$> readIORef delayedTestRef
+      cleanUpDone `shouldBe` False
     it "even with routing failure in bodyD" $ do
       _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
-      fileStillThere <- doesFileExist "delayed.test"
-      fileStillThere `shouldBe` False
+      cleanUpDone <- isJust <$> readIORef delayedTestRef
+      cleanUpDone `shouldBe` False
     it "even with exceptions in bodyD" $ do
       _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
-      fileStillThere <- doesFileExist "delayed.test"
-      fileStillThere `shouldBe` False
+      cleanUpDone <- isJust <$> readIORef delayedTestRef
+      cleanUpDone `shouldBe` False