Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Async exception protection on withResource

  • Loading branch information...
commit 318dab86500ea3f49d208f6e1ec5e679174c717e 1 parent db5dbfc
@snoyberg snoyberg authored
Showing with 16 additions and 4 deletions.
  1. +16 −4 Data/Pool.hs
View
20 Data/Pool.hs
@@ -4,6 +4,10 @@
{-# LANGUAGE FlexibleContexts #-}
#endif
+#if !MIN_VERSION_base(4,3,0)
+{-# LANGUAGE RankNTypes #-}
+#endif
+
-- |
-- Module: Data.Pool
-- Copyright: (c) 2011 MailRank, Inc.
@@ -55,6 +59,14 @@ import Control.Monad.IO.Class (liftIO)
#define liftBase liftIO
#endif
+#if MIN_VERSION_base(4,3,0)
+import Control.Exception (mask)
+#else
+-- Don't do any async exception protection for older GHCs.
+mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
+mask f = f id
+#endif
+
-- | A single resource pool entry.
data Entry a = Entry {
entry :: a
@@ -188,11 +200,11 @@ withResource ::
#endif
=> Pool a -> (a -> m b) -> m b
{-# SPECIALIZE withResource :: Pool a -> (a -> IO b) -> IO b #-}
-withResource pool act = do
- (resource, local) <- liftBase (takeResource pool)
- ret <- control $ \runInIO -> runInIO (act resource) `onException`
+withResource pool act = control $ \runInIO -> mask $ \restore -> do
+ (resource, local) <- takeResource pool
+ ret <- restore (runInIO (act resource)) `onException`
destroyResource pool local resource
- liftBase (putResource local resource)
+ putResource local resource
return ret
#if __GLASGOW_HASKELL__ >= 700
{-# INLINABLE withResource #-}
Please sign in to comment.
Something went wrong with that request. Please try again.