124c6de · servant · git.iko.soy

git.iko.soy/servant

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

124c6deAlp Mestanogullari10 years ago

servant-server/src/Servant/Server/Internal.hs+1−1

compare with master

unifiedsplit

@@ -400,7 +400,7 @@ instance HasServer Raw context where

400 type ServerT Raw m = Application

401

402 route Proxy _ rawApplication = RawRouter $ \ env request respond -> do

403− r <- runDelayed rawApplication env request

403+ (r, _) <- runDelayed rawApplication env request

404 case r of

405 Route app -> app request (respond . Route)

406 Fail a -> respond $ Fail a

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+29−12

@@ -6,10 +6,13 @@

6{-# LANGUAGE KindSignatures #-}

7{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE StandaloneDeriving #-}

9+{-# LANGUAGE TupleSections #-}

9module Servant.Server.Internal.RoutingApplication where

10module Servant.Server.Internal.RoutingApplication where

11import Control.Monad (ap, liftM)

12import Control.Monad (ap, liftM)

12import Control.Monad.Trans (MonadIO(..))

13import Control.Monad.Trans (MonadIO(..))

14+import Control.Monad.Trans.Except (runExceptT)

15+import Data.IORef (newIORef, readIORef, writeIORef)

13import Network.Wai (Application, Request,

16import Network.Wai (Application, Request,

14 Response, ResponseReceived)

17 Response, ResponseReceived)

15import Prelude ()

18import Prelude ()

@@ -103,6 +106,10 @@ data Delayed env c where

103 , authD :: DelayedIO auth

106 , authD :: DelayedIO auth

104 , bodyD :: DelayedIO body

107 , bodyD :: DelayedIO body

105 , serverD :: captures -> auth -> body -> Request -> RouteResult c

108 , 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

106 } -> Delayed env c

113 } -> Delayed env c

107

114

108instance Functor (Delayed env) where

115instance Functor (Delayed env) where

@@ -142,7 +149,7 @@ instance MonadIO DelayedIO where

142-- | A 'Delayed' without any stored checks.

149-- | A 'Delayed' without any stored checks.

143emptyDelayed :: RouteResult a -> Delayed env a

150emptyDelayed :: RouteResult a -> Delayed env a

144emptyDelayed result =

151emptyDelayed result =

145− Delayed (const r) r r r (\ _ _ _ _ -> result)

152+ Delayed (const r) r r r (\ _ _ _ _ -> result) (const $ return ())

146 where

153 where

147 r = return ()

154 r = return ()

148

155

@@ -196,8 +203,9 @@ addBodyCheck :: Delayed env (a -> b)

196 -> Delayed env b

203 -> Delayed env b

197addBodyCheck Delayed{..} new =

204addBodyCheck Delayed{..} new =

198 Delayed

205 Delayed

199− { bodyD = (,) <$> bodyD <*> new

206+ { bodyD = (,) <$> bodyD <*> new

200− , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req

207+ , serverD = \ c a (z, v) req -> ($ v) <$> serverD c a z req

208+ , cleanupD = cleanupD . fst -- not sure that's right

201 , ..

209 , ..

202 } -- Note [Existential Record Update]

210 } -- Note [Existential Record Update]

203

211

@@ -240,13 +248,19 @@ passToServer Delayed{..} x =

240runDelayed :: Delayed env a

248runDelayed :: Delayed env a

241 -> env

249 -> env

242 -> Request

250 -> Request

243− -> IO (RouteResult a)

251+ -> IO (RouteResult a, IO ())

244−runDelayed Delayed{..} env = runDelayedIO $ do

252+runDelayed Delayed{..} env req = do

253+ cleanupRef <- newIORef (return ())

254+ routeRes <- runDelayedIO

245− c <- capturesD env

255+ (do c <- capturesD env

246− methodD

256+ methodD

247− a <- authD

257+ a <- authD

248− b <- bodyD

258+ b <- bodyD

259+ liftIO (writeIORef cleanupRef $ cleanupD b)

249− DelayedIO (\ req -> return $ serverD c a b req)

260+ DelayedIO $ \ req -> return (serverD c a b req)

261+ )

262+ req

263+ fmap (routeRes,) $ readIORef cleanupRef

250

264

251-- | Runs a delayed server and the resulting action.

265-- | Runs a delayed server and the resulting action.

252-- Takes a continuation that lets us send a response.

266-- Takes a continuation that lets us send a response.

@@ -258,8 +272,11 @@ runAction :: Delayed env (Handler a)

258 -> (RouteResult Response -> IO r)

272 -> (RouteResult Response -> IO r)

259 -> (a -> RouteResult Response)

273 -> (a -> RouteResult Response)

260 -> IO r

274 -> IO r

261−runAction action env req respond k =

275+runAction action env req respond k = do

262− runDelayed action env req >>= go >>= respond

276+ (routeResult, cleanup) <- runDelayed action env req

277+ resp <- go routeResult

278+ cleanup

279+ respond resp

263 where

280 where

264 go (Fail e) = return $ Fail e

281 go (Fail e) = return $ Fail e

265 go (FailFatal e) = return $ FailFatal e

282 go (FailFatal e) = return $ FailFatal e