git.iko.soy/servant
on master help sign in
Merge pull request #674 from phadej/delayed-cleanup-ioref-tests
6d0aa92Oleg Grenrus
servant-server/servant-server.cabal+1
compare with master
unifiedsplit
@@ -109,6 +109,7 @@ test-suite spec
109 Servant.ArbitraryMonadServerSpec
109 Servant.ArbitraryMonadServerSpec
110 Servant.Server.ErrorSpec
110 Servant.Server.ErrorSpec
111 Servant.Server.Internal.ContextSpec
111 Servant.Server.Internal.ContextSpec
112+ Servant.Server.Internal.RoutingApplicationSpec
112 Servant.Server.RouterSpec
113 Servant.Server.RouterSpec
113 Servant.Server.StreamingSpec
114 Servant.Server.StreamingSpec
114 Servant.Server.UsingContextSpec
115 Servant.Server.UsingContextSpec
servant-server/src/Servant/Server/Internal.hs+12−5
@@ -23,6 +23,7 @@ module Servant.Server.Internal
23 , module Servant.Server.Internal.ServantErr
23 , module Servant.Server.Internal.ServantErr
24 ) where
24 ) where
25
25
26+import Control.Exception (finally)
26import Control.Monad.Trans (liftIO)
27import Control.Monad.Trans (liftIO)
27import qualified Data.ByteString as B
28import qualified Data.ByteString as B
28import qualified Data.ByteString.Char8 as BC8
29import qualified Data.ByteString.Char8 as BC8
@@ -400,11 +401,17 @@ instance HasServer Raw context where
400 type ServerT Raw m = Application
401 type ServerT Raw m = Application
401
402
402 route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
403 route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
404+ -- note: a Raw application doesn't register any cleanup
405+ -- but for the sake of consistency, we nonetheless run
406+ -- the cleanup once its done
407+ cleanupRef <- newCleanupRef
403− r <- runDelayed rawApplication env request
408+ r <- runDelayed rawApplication env request cleanupRef
404− case r of
409+ go r request respond `finally` runCleanup cleanupRef
410+
411+ where go r request respond = case r of
405− Route app -> app request (respond . Route)
412+ Route app -> app request (respond . Route)
406− Fail a -> respond $ Fail a
413+ Fail a -> respond $ Fail a
407− FailFatal e -> respond $ FailFatal e
414+ FailFatal e -> respond $ FailFatal e
408
415
409-- | If you use 'ReqBody' in one of the endpoints for your API,
416-- | If you use 'ReqBody' in one of the endpoints for your API,
410-- this automatically requires your server-side handler to be a function
417-- this automatically requires your server-side handler to be a function
servant-server/src/Servant/Server/Internal/RoutingApplication.hs+51−19
@@ -6,10 +6,13 @@
6{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE RecordWildCards #-}
8{-# LANGUAGE StandaloneDeriving #-}
8{-# LANGUAGE StandaloneDeriving #-}
9+{-# LANGUAGE TupleSections #-}
9module Servant.Server.Internal.RoutingApplication where
10module Servant.Server.Internal.RoutingApplication where
10
11
12+import Control.Exception (finally)
11import Control.Monad (ap, liftM)
13import Control.Monad (ap, liftM)
12import Control.Monad.Trans (MonadIO(..))
14import Control.Monad.Trans (MonadIO(..))
15+import Data.IORef (newIORef, readIORef, IORef, atomicModifyIORef)
13import Network.Wai (Application, Request,
16import Network.Wai (Application, Request,
14 Response, ResponseReceived)
17 Response, ResponseReceived)
15import Prelude ()
18import Prelude ()
@@ -112,12 +115,33 @@ instance Functor (Delayed env) where
112 , ..
115 , ..
113 } -- Note [Existential Record Update]
116 } -- Note [Existential Record Update]
114
117
118+-- | A mutable cleanup action
119+newtype CleanupRef = CleanupRef (IORef (IO ()))
120+
121+newCleanupRef :: IO CleanupRef
122+newCleanupRef = CleanupRef <$> newIORef (return ())
123+
124+-- | Add a clean up action to a 'CleanupRef'
125+addCleanup' :: IO () -> CleanupRef -> IO ()
126+addCleanup' act (CleanupRef ref) = atomicModifyIORef ref (\act' -> (act' >> act, ()))
127+
128+addCleanup :: IO () -> DelayedIO ()
129+addCleanup act = DelayedIO $ \_req cleanupRef ->
130+ addCleanup' act cleanupRef >> return (Route ())
131+
132+-- | Run all the clean up actions registered in
133+-- a 'CleanupRef'.
134+runCleanup :: CleanupRef -> IO ()
135+runCleanup (CleanupRef ref) = do
136+ act <- readIORef ref
137+ act
138+
115-- | Computations used in a 'Delayed' can depend on the
139-- | Computations used in a 'Delayed' can depend on the
116-- incoming 'Request', may perform 'IO, and result in a
140-- incoming 'Request', may perform 'IO, and result in a
117-- 'RouteResult, meaning they can either suceed, fail
141-- 'RouteResult, meaning they can either suceed, fail
118-- (with the possibility to recover), or fail fatally.
142-- (with the possibility to recover), or fail fatally.
119--
143--
120−newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> IO (RouteResult a) }
144+newtype DelayedIO a = DelayedIO { runDelayedIO :: Request -> CleanupRef -> IO (RouteResult a) }
121
145
122instance Functor DelayedIO where
146instance Functor DelayedIO where
123 fmap = liftM
147 fmap = liftM
@@ -127,17 +151,17 @@ instance Applicative DelayedIO where
127 (<*>) = ap
151 (<*>) = ap
128
152
129instance Monad DelayedIO where
153instance Monad DelayedIO where
130− return x = DelayedIO (const $ return (Route x))
154+ return x = DelayedIO (\_req _cleanup -> return (Route x))
131 DelayedIO m >>= f =
155 DelayedIO m >>= f =
132− DelayedIO $ \ req -> do
156+ DelayedIO $ \ req cl -> do
133− r <- m req
157+ r <- m req cl
134 case r of
158 case r of
135 Fail e -> return $ Fail e
159 Fail e -> return $ Fail e
136 FailFatal e -> return $ FailFatal e
160 FailFatal e -> return $ FailFatal e
137− Route a -> runDelayedIO (f a) req
161+ Route a -> runDelayedIO (f a) req cl
138
162
139instance MonadIO DelayedIO where
163instance MonadIO DelayedIO where
140− liftIO m = DelayedIO (const $ Route <$> m)
164+ liftIO m = DelayedIO (\_req _cl -> Route <$> m)
141
165
142-- | A 'Delayed' without any stored checks.
166-- | A 'Delayed' without any stored checks.
143emptyDelayed :: RouteResult a -> Delayed env a
167emptyDelayed :: RouteResult a -> Delayed env a
@@ -148,15 +172,15 @@ emptyDelayed result =
148
172
149-- | Fail with the option to recover.
173-- | Fail with the option to recover.
150delayedFail :: ServantErr -> DelayedIO a
174delayedFail :: ServantErr -> DelayedIO a
151−delayedFail err = DelayedIO (const $ return $ Fail err)
175+delayedFail err = DelayedIO (\_req _cleanup -> return $ Fail err)
152
176
153-- | Fail fatally, i.e., without any option to recover.
177-- | Fail fatally, i.e., without any option to recover.
154delayedFailFatal :: ServantErr -> DelayedIO a
178delayedFailFatal :: ServantErr -> DelayedIO a
155−delayedFailFatal err = DelayedIO (const $ return $ FailFatal err)
179+delayedFailFatal err = DelayedIO (\_req _cleanup -> return $ FailFatal err)
156
180
157-- | Gain access to the incoming request.
181-- | Gain access to the incoming request.
158withRequest :: (Request -> DelayedIO a) -> DelayedIO a
182withRequest :: (Request -> DelayedIO a) -> DelayedIO a
159−withRequest f = DelayedIO (\ req -> runDelayedIO (f req) req)
183+withRequest f = DelayedIO (\ req cl -> runDelayedIO (f req) req cl)
160
184
161-- | Add a capture to the end of the capture block.
185-- | Add a capture to the end of the capture block.
162addCapture :: Delayed env (a -> b)
186addCapture :: Delayed env (a -> b)
@@ -196,8 +220,8 @@ addBodyCheck :: Delayed env (a -> b)
196 -> Delayed env b
220 -> Delayed env b
197addBodyCheck Delayed{..} new =
221addBodyCheck Delayed{..} new =
198 Delayed
222 Delayed
199− { bodyD = (,) <$> bodyD <*> new
223+ { bodyD = (,) <$> bodyD <*> new
200− , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
224+ , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
201 , ..
225 , ..
202 } -- Note [Existential Record Update]
226 } -- Note [Existential Record Update]
203
227
@@ -240,13 +264,18 @@ passToServer Delayed{..} x =
240runDelayed :: Delayed env a
264runDelayed :: Delayed env a
241 -> env
265 -> env
242 -> Request
266 -> Request
267+ -> CleanupRef
243 -> IO (RouteResult a)
268 -> IO (RouteResult a)
244−runDelayed Delayed{..} env = runDelayedIO $ do
269+runDelayed Delayed{..} env req cleanupRef =
270+ runDelayedIO
245− c <- capturesD env
271+ (do c <- capturesD env
246− methodD
272+ methodD
247− a <- authD
273+ a <- authD
248− b <- bodyD
274+ b <- bodyD
249− DelayedIO (\ req -> return $ serverD c a b req)
275+ DelayedIO $ \ r _cleanup -> return (serverD c a b r)
276+ )
277+ req
278+ cleanupRef
250
279
251-- | Runs a delayed server and the resulting action.
280-- | Runs a delayed server and the resulting action.
252-- Takes a continuation that lets us send a response.
281-- Takes a continuation that lets us send a response.
@@ -258,8 +287,11 @@ runAction :: Delayed env (Handler a)
258 -> (RouteResult Response -> IO r)
287 -> (RouteResult Response -> IO r)
259 -> (a -> RouteResult Response)
288 -> (a -> RouteResult Response)
260 -> IO r
289 -> IO r
261−runAction action env req respond k =
290+runAction action env req respond k = do
291+ cleanupRef <- newCleanupRef
262− runDelayed action env req >>= go >>= respond
292+ (runDelayed action env req cleanupRef >>= go >>= respond)
293+ `finally` runCleanup cleanupRef
294+
263 where
295 where
264 go (Fail e) = return $ Fail e
296 go (Fail e) = return $ Fail e
265 go (FailFatal e) = return $ FailFatal e
297 go (FailFatal e) = return $ FailFatal e
servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hsnew file+61
@@ -0,0 +1,61 @@
1+module Servant.Server.Internal.RoutingApplicationSpec (spec) where
2+
3+import Prelude ()
4+import Prelude.Compat
5+
6+import Control.Exception hiding (Handler)
7+import Control.Monad.IO.Class
8+import Data.Maybe (isJust)
9+import Data.IORef
10+import Servant.Server
11+import Servant.Server.Internal.RoutingApplication
12+import Test.Hspec
13+
14+import System.IO.Unsafe (unsafePerformIO)
15+
16+ok :: IO (RouteResult ())
17+ok = return (Route ())
18+
19+-- Let's not write to the filesystem
20+delayedTestRef :: IORef (Maybe String)
21+delayedTestRef = unsafePerformIO $ newIORef Nothing
22+
23+delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
24+delayed body srv = Delayed
25+ { capturesD = \() -> DelayedIO $ \_req _cl -> ok
26+ , methodD = DelayedIO $ \_req_ _cl -> ok
27+ , authD = DelayedIO $ \_req _cl -> ok
28+ , bodyD = do
29+ liftIO (writeIORef delayedTestRef (Just "hia") >> putStrLn "garbage created")
30+ addCleanup (writeIORef delayedTestRef Nothing >> putStrLn "garbage collected")
31+ body
32+ , serverD = \() () _body _req -> srv
33+ }
34+
35+simpleRun :: Delayed () (Handler ())
36+ -> IO ()
37+simpleRun d = fmap (either ignoreE id) . try $
38+ runAction d () undefined (\_ -> return ()) (\_ -> FailFatal err500)
39+
40+ where ignoreE :: SomeException -> ()
41+ ignoreE = const ()
42+
43+spec :: Spec
44+spec = do
45+ describe "Delayed" $ do
46+ it "actually runs clean up actions" $ do
47+ _ <- simpleRun $ delayed (return ()) (Route $ return ())
48+ cleanUpDone <- isJust <$> readIORef delayedTestRef
49+ cleanUpDone `shouldBe` False
50+ it "even with exceptions in serverD" $ do
51+ _ <- simpleRun $ delayed (return ()) (Route $ throw DivideByZero)
52+ cleanUpDone <- isJust <$> readIORef delayedTestRef
53+ cleanUpDone `shouldBe` False
54+ it "even with routing failure in bodyD" $ do
55+ _ <- simpleRun $ delayed (delayedFailFatal err500) (Route $ return ())
56+ cleanUpDone <- isJust <$> readIORef delayedTestRef
57+ cleanUpDone `shouldBe` False
58+ it "even with exceptions in bodyD" $ do
59+ _ <- simpleRun $ delayed (liftIO $ throwIO DivideByZero) (Route $ return ())
60+ cleanUpDone <- isJust <$> readIORef delayedTestRef
61+ cleanUpDone `shouldBe` False