Switch to pool-conduit

.gitmodules

@@ -1,3 +1,6 @@
 [submodule "scripts"]
 	path = scripts
 	url = git://github.com/yesodweb/scripts.git
+[submodule "pool"]
+	path = pool
+	url = https://github.com/bos/pool.git

package-list.sh

@@ -1,6 +1,7 @@
 #!/bin/bash
 
 pkgs=( ./pool
+       ./pool-conduit
        ./persistent
        ./persistent-template
        ./persistent-sqlite

persistent-test/persistent-test.cabal

@@ -63,7 +63,7 @@ library
                    , random == 1.*
                    , QuickCheck == 2.4.*
                    , blaze-html
-                   , pool
+                   , pool-conduit
                    , transformers-base
 
                    -- postgresql dependencies

persistent/Database/Persist/GenericSql.hs

@@ -46,7 +46,7 @@ import Control.Arrow ((&&&))
 import Database.Persist.Store
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader
-import Data.Pool
+import Data.Conduit.Pool
 import Database.Persist.GenericSql.Internal
 import Database.Persist.GenericSql.Migration
 import qualified Database.Persist.GenericSql.Raw as R
@@ -84,8 +84,8 @@ instance PathPiece (Key SqlPersist entity) where
 execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m ()
 execute' = R.execute
 
-runSqlPool :: (MBCIO m, MonadIO m) => SqlPersist m a -> Pool Connection -> m a
-runSqlPool r pconn = withPool' pconn $ runSqlConn r
+runSqlPool :: C.ResourceIO m => SqlPersist m a -> Pool Connection -> m a
+runSqlPool r pconn = withResource pconn $ runSqlConn r
 
 runSqlConn :: (MBCIO m, MonadIO m) => SqlPersist m a -> Connection -> m a
 runSqlConn (SqlPersist r) conn = do

persistent/Database/Persist/GenericSql/Internal.hs

@@ -20,7 +20,7 @@ import Prelude hiding ((++))
 import qualified Data.Map as Map
 import Data.IORef
 import Control.Monad.IO.Class
-import Data.Pool
+import Data.Conduit.Pool
 import Database.Persist.Store
 import Database.Persist.Query
 import Control.Exception.Lifted (bracket)
@@ -58,8 +58,13 @@ data Statement = Statement
     }
 
 withSqlPool :: C.ResourceIO m
-            => IO Connection -> Int -> (Pool Connection -> m a) -> m a
-withSqlPool mkConn = createPool mkConn close'
+            => IO Connection -- ^ create a new connection
+            -> Int -- ^ connection count
+            -> (Pool Connection -> m a)
+            -> m a
+withSqlPool mkConn connCount f = do
+    pool <- liftIO $ createPool mkConn close' 1 20 connCount
+    f pool
 
 withSqlConn :: C.ResourceIO m
             => IO Connection -> (Connection -> m a) -> m a

persistent/Database/Persist/Store.hs

@@ -72,16 +72,8 @@ import qualified Data.Text.Encoding as T
 import qualified Data.Text.Encoding.Error as T
 import Web.PathPieces (PathPiece (..))
 import qualified Data.Text.Read
-import Control.Monad.IO.Class (MonadIO)
 import qualified Data.Conduit as C
 
-#if MIN_VERSION_monad_control(0, 3, 0)
-import Control.Monad.Trans.Control (MonadBaseControl)
-#define MBCIO MonadBaseControl IO
-#else
-import Control.Monad.IO.Control (MonadControlIO)
-#define MBCIO MonadControlIO
-#endif
 import Data.Aeson (Value)
 import Data.Aeson.Types (Parser)
 
@@ -557,7 +549,7 @@ class PersistConfig c where
     loadConfig :: Value -> Parser c
     -- | I really don't want Applicative here, but it's necessary for Mongo.
     withPool :: (Applicative m, C.ResourceIO m) => c -> (PersistConfigPool c -> m a) -> m a
-    runPool :: (MBCIO m, MonadIO m) => c -> PersistConfigBackend c m a
+    runPool :: C.ResourceIO m => c -> PersistConfigBackend c m a
             -> PersistConfigPool c
             -> m a
 

persistent/persistent.cabal

@@ -29,7 +29,7 @@ library
                    , conduit                  >= 0.0     && < 0.1
                    , monad-control            >= 0.3     && < 0.4
                    , lifted-base              >= 0.1     && < 0.2
-                   , pool                     >= 0.1     && < 0.2
+                   , pool-conduit             >= 0.0     && < 0.1
                    , blaze-html               >= 0.4     && < 0.5
                    , path-pieces              >= 0.1     && < 0.2
                    , mtl                      >= 2.0     && < 2.1

pool-conduit/Data/Conduit/Pool.hs

@@ -0,0 +1,59 @@
+-- | Allocate resources from a pool, guaranteeing resource handling via the
+-- ResourceT transformer.
+module Data.Conduit.Pool
+    ( ManagedResource (..)
+    , takeResource
+    , takeResourceCheck
+    , P.Pool
+    , P.createPool
+    , P.withResource
+    ) where
+
+import qualified Data.Pool as P
+import Control.Monad.Trans.Resource
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.IORef as I
+
+-- | The result of taking a resource.
+data ManagedResource m a = ManagedResource
+    { mrValue :: a -- ^ The actual resource.
+    , mrReuse :: Bool -> ResourceT m ()
+    -- ^ Let's you specify whether the resource should be returned to the pool
+    -- (via 'P.putResource') or destroyed (via 'P.destroyResource') on release.
+    -- This defaults to destruction, in case of exceptions.
+    , mrRelease :: ResourceT m ()
+    -- ^ Release this resource, either destroying it or returning it to the
+    -- pool.
+    }
+
+-- | Take a resource from the pool and register a release action.
+takeResource :: ResourceIO m => P.Pool a -> ResourceT m (ManagedResource m a)
+takeResource pool = do
+    onRelRef <- liftIO $ I.newIORef False
+    (relKey, (a, _)) <- withIO
+        (P.takeResource pool)
+        (\(a, local) -> do
+            onRel <- I.readIORef onRelRef
+            if onRel
+                then P.putResource local a
+                else P.destroyResource pool local a)
+    return ManagedResource
+        { mrValue = a
+        , mrReuse = liftIO . I.writeIORef onRelRef
+        , mrRelease = release relKey
+        }
+
+-- | Same as 'takeResource', but apply some action to check if a resource is
+-- still valid.
+takeResourceCheck :: ResourceIO m
+                  => P.Pool a
+                  -> (a -> ResourceT m Bool)
+                  -> ResourceT m (ManagedResource m a)
+takeResourceCheck pool check = do
+    mr <- takeResource pool
+    isValid <- check $ mrValue mr
+    if isValid
+        then return mr
+        else do
+            mrRelease mr
+            takeResourceCheck pool check

pool-conduit/pool-conduit.cabal

@@ -0,0 +1,28 @@
+name:            pool-conduit
+version:         0.0.0
+license:         BSD3
+license-file:    LICENSE
+author:          Michael Snoyman <[email protected]>
+maintainer:      Michael Snoyman <[email protected]>
+synopsis:        Resource pool allocations via ResourceT.
+description:     Allocate resources from a pool, guaranteeing resource handling via the ResourceT transformer.
+category:        Database, Yesod, Conduit
+stability:       Stable
+cabal-version:   >= 1.8
+build-type:      Simple
+homepage:        http://www.yesodweb.com/book/persistent
+
+library
+
+    build-depends:   base                     >= 4       && < 5
+                   , resource-pool            >= 0.2.0.4 && < 0.3
+                   , transformers             >= 0.2.1   && < 0.3
+                   , conduit                  >= 0.0.2   && < 0.1
+
+    exposed-modules: Data.Conduit.Pool
+
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/yesodweb/persistent.git