persistent 0.2.3 → 0.2.4

raw patch · 4 files changed

+44/−8 lines, 4 files

Files

• Database/Persist/GenericSql.hs +6/−0
• Database/Persist/GenericSql/Internal.hs +6/−0
• Database/Persist/Pool.hs +31/−7
• persistent.cabal +1/−1

@@ -10,6 +10,7 @@     , Statement     , runSqlConn     , runSqlPool+    , runSqlPoolF     , Migration     , parseMigration     , parseMigration'@@ -49,6 +50,11 @@  runSqlPool :: MonadCatchIO m => SqlPersist m a -> Pool Connection -> m a runSqlPool r pconn = withPool' pconn $ runSqlConn r++runSqlPoolF :: MonadCatchIO m+            => (m (Maybe b) -> m () -> m (Maybe b))+            -> SqlPersist m b -> Pool Connection -> m b+runSqlPoolF finally' r pconn = withPoolF' finally' pconn $ runSqlConn r  runSqlConn :: MonadCatchIO m => SqlPersist m a -> Connection -> m a runSqlConn (SqlPersist r) conn = do

@@ -6,6 +6,7 @@     , Statement (..)     , withSqlConn     , withSqlPool+    , withSqlPoolF     , RowPopper     , mkColumns     , Column (..)@@ -53,6 +54,11 @@ withSqlPool :: MonadCatchIO m             => IO Connection -> Int -> (Pool Connection -> m a) -> m a withSqlPool mkConn = createPool mkConn close'++withSqlPoolF :: MonadIO m+             => (m a -> m () -> m a)+             -> IO Connection -> Int -> (Pool Connection -> m a) -> m a+withSqlPoolF finally' mkConn = createPoolF finally' mkConn close'  withSqlConn :: MonadCatchIO m => IO Connection -> (Connection -> m a) -> m a withSqlConn open = bracket (liftIO open) (liftIO . close')

@@ -5,6 +5,9 @@     , withPool     , withPool'     , Pool+    , withPoolF'+    , withPoolF+    , createPoolF     ) where  import Control.Concurrent.STM (atomically)@@ -12,7 +15,8 @@     (TVar, newTVarIO, readTVar, writeTVar) import Control.Exception (throwIO) import Data.Typeable-import "MonadCatchIO-transformers" Control.Monad.CatchIO+import "MonadCatchIO-transformers" Control.Monad.CatchIO hiding (finally)+import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as C import Control.Monad.IO.Class import Control.Monad @@ -29,7 +33,12 @@  createPool :: MonadCatchIO m            => IO a -> (a -> IO ()) -> Int -> (Pool a -> m b) -> m b-createPool mk fr mx f = do+createPool = createPoolF C.finally++createPoolF :: MonadIO m+            => (m b -> m () -> m b)+            -> IO a -> (a -> IO ()) -> Int -> (Pool a -> m b) -> m b+createPoolF finally mk fr mx f = do     pd <- liftIO $ newTVarIO $ PoolData [] 0     finally (f $ Pool mx pd mk) $ liftIO $ do         PoolData ress _ <- atomically $ readTVar pd@@ -46,8 +55,22 @@         Nothing -> liftIO $ throwIO PoolExhaustedException         Just x' -> return x' +withPoolF' :: MonadCatchIO m+           => (m (Maybe b) -> m () -> m (Maybe b))+           -> Pool a -> (a -> m b) -> m b+withPoolF' finally p f = do+    x <- withPoolF finally p f+    case x of+        Nothing -> liftIO $ throwIO PoolExhaustedException+        Just x' -> return x'+ withPool :: MonadCatchIO m => Pool a -> (a -> m b) -> m (Maybe b)-withPool p f = block $ do+withPool = withPoolF C.finally++withPoolF :: MonadCatchIO m+          => (m (Maybe b) -> m () -> m (Maybe b))+          -> Pool a -> (a -> m b) -> m (Maybe b)+withPoolF finally p f = block $ do     eres <- liftIO $ atomically $ do         pd <- readTVar $ poolData p         let (pd', eres) =@@ -60,10 +83,11 @@         Left pc ->             if pc >= poolMax p                 then return Nothing-                else bracket-                        (liftIO $ poolMake p)-                        (insertResource 1)-                        (liftM Just . unblock . f)+                else do+                    x <- liftIO $ poolMake p+                    finally+                        (liftM Just $ unblock $ f x)+                        (insertResource 1 x)         Right res -> finally                         (liftM Just $ unblock $ f res)                         (insertResource 0 res)

@@ -1,5 +1,5 @@ name:            persistent-version:         0.2.3+version:         0.2.4 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>