git.iko.soy/servant
on master help sign in
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
commit124c6de1eb9390b3b9ceebfecdb1224efdb68639 authorAlp Mestanogullari <alpmestan@gmail.com> dateSat 15 Oct 2016, 12:02 (10 years ago) parentcce0f59
2 files changed+30−13
compare with master
unifiedsplit
servant-server/src/Servant/Server/Internal.hs+1−1 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+29−12
servant-server/src/Servant/Server/Internal.hs+1−1
@@ -400,7 +400,7 @@ instance HasServer Raw context where
400400 type ServerT Raw m = Application
401401
402402 route Proxy _ rawApplication = RawRouter $ \ env request respond -> do
403− r <- runDelayed rawApplication env request
403+ (r, _) <- runDelayed rawApplication env request
404404 case r of
405405 Route app -> app request (respond . Route)
406406 Fail a -> respond $ Fail a
servant-server/src/Servant/Server/Internal/RoutingApplication.hs+29−12
@@ -6,10 +6,13 @@
66{-# LANGUAGE KindSignatures #-}
77{-# LANGUAGE RecordWildCards #-}
88{-# LANGUAGE StandaloneDeriving #-}
9+{-# LANGUAGE TupleSections #-}
910module Servant.Server.Internal.RoutingApplication where
1011
1112import Control.Monad (ap, liftM)
1213import Control.Monad.Trans (MonadIO(..))
14+import Control.Monad.Trans.Except (runExceptT)
15+import Data.IORef (newIORef, readIORef, writeIORef)
1316import Network.Wai (Application, Request,
1417 Response, ResponseReceived)
1518import Prelude ()
@@ -103,6 +106,10 @@ data Delayed env c where
103106 , authD :: DelayedIO auth
104107 , bodyD :: DelayedIO body
105108 , serverD :: captures -> auth -> body -> Request -> RouteResult c
109+ , cleanupD :: body -> IO ()
110+ -- not in DelayedIO because:
111+ -- - most likely should not depend on the request
112+ -- - simpler
106113 } -> Delayed env c
107114
108115instance Functor (Delayed env) where
@@ -142,7 +149,7 @@ instance MonadIO DelayedIO where
142149-- | A 'Delayed' without any stored checks.
143150emptyDelayed :: RouteResult a -> Delayed env a
144151emptyDelayed result =
145− Delayed (const r) r r r (\ _ _ _ _ -> result)
152+ Delayed (const r) r r r (\ _ _ _ _ -> result) (const $ return ())
146153 where
147154 r = return ()
148155
@@ -196,8 +203,9 @@ addBodyCheck :: Delayed env (a -> b)
196203 -> Delayed env b
197204addBodyCheck Delayed{..} new =
198205 Delayed
199− { bodyD = (,) <$> bodyD <*> new
200− , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
206+ { bodyD = (,) <$> bodyD <*> new
207+ , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req
208+ , cleanupD = cleanupD . fst -- not sure that's right
201209 , ..
202210 } -- Note [Existential Record Update]
203211
@@ -240,13 +248,19 @@ passToServer Delayed{..} x =
240248runDelayed :: Delayed env a
241249 -> env
242250 -> Request
243− -> IO (RouteResult a)
244−runDelayed Delayed{..} env = runDelayedIO $ do
245− c <- capturesD env
246− methodD
247− a <- authD
248− b <- bodyD
249− DelayedIO (\ req -> return $ serverD c a b req)
251+ -> IO (RouteResult a, IO ())
252+runDelayed Delayed{..} env req = do
253+ cleanupRef <- newIORef (return ())
254+ routeRes <- runDelayedIO
255+ (do c <- capturesD env
256+ methodD
257+ a <- authD
258+ b <- bodyD
259+ liftIO (writeIORef cleanupRef $ cleanupD b)
260+ DelayedIO $ \ req -> return (serverD c a b req)
261+ )
262+ req
263+ fmap (routeRes,) $ readIORef cleanupRef
250264
251265-- | Runs a delayed server and the resulting action.
252266-- Takes a continuation that lets us send a response.
@@ -258,8 +272,11 @@ runAction :: Delayed env (Handler a)
258272 -> (RouteResult Response -> IO r)
259273 -> (a -> RouteResult Response)
260274 -> IO r
261−runAction action env req respond k =
262− runDelayed action env req >>= go >>= respond
275+runAction action env req respond k = do
276+ (routeResult, cleanup) <- runDelayed action env req
277+ resp <- go routeResult
278+ cleanup
279+ respond resp
263280 where
264281 go (Fail e) = return $ Fail e
265282 go (FailFatal e) = return $ FailFatal e