add some basic tests for the cleanup machinery in Delayed
This commit is contained in:
parent
5d1f03ba1a
commit
92786feead
3 changed files with 55 additions and 4 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
Loading…
Reference in a new issue