wip

persistent-postgresql/Database/Persist/Postgresql.hs

@@ -180,6 +180,14 @@ createPostgresqlPoolModifiedWithVersion
 createPostgresqlPoolModifiedWithVersion getVer modConn ci =
   createSqlPool $ open' modConn getVer ci
 
+createPostgresqlPoolWithConf
+    :: (MonadUnliftIO m, MonadLogger m)
+    => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version.
+    -> (PG.Connection -> IO ()) -- ^ Action to perform after connection is created.
+    -> PostgresConf
+    -> m (Pool SqlBackend)
+createPostgresqlPoolWithConf = error "todo"
+
 -- | Same as 'withPostgresqlPool', but instead of opening a pool
 -- of connections, only one connection is opened.
 -- The provided action should use 'runSqlConn' and *not* 'runReaderT' because
@@ -1261,19 +1269,27 @@ escape (DBName s) =
 data PostgresConf = PostgresConf
     { pgConnStr  :: ConnectionString
       -- ^ The connection string.
+
+    , pgPoolStripes :: Int
+    -- ^ How many stripes to divide the pool into. See "Data.Pool" for details.
+    , pgPoolIdleTimeout :: NominalDiffTime
+    -- ^ How long connections can remain idle before being disposed of.
     , pgPoolSize :: Int
       -- ^ How many connections should be held in the connection pool.
     } deriving (Show, Read, Data, Typeable)
 
 instance FromJSON PostgresConf where
     parseJSON v = modifyFailure ("Persistent: error loading PostgreSQL conf: " ++) $
       flip (withObject "PostgresConf") v $ \o -> do
+        let defaultPoolConfig = defaultConnectionPoolConfig
         database <- o .: "database"
         host     <- o .: "host"
         port     <- o .:? "port" .!= 5432
         user     <- o .: "user"
         password <- o .: "password"
-        pool     <- o .: "poolsize"
+        poolSize <- o .:? "poolsize" .!= (connectionPoolConfigSize defaultPoolConfig)
+        poolStripes <- o .:? "stripes" .!= (connectionPoolConfigStripes defaultPoolConfig)
+        poolIdleTimeout <- o .:? "idleTimeout" .!= (connectionPoolConfigIdleTimeout defaultPoolConfig)
         let ci = PG.ConnectInfo
                    { PG.connectHost     = host
                    , PG.connectPort     = port
@@ -1282,7 +1298,7 @@ instance FromJSON PostgresConf where
                    , PG.connectDatabase = database
                    }
             cstr = PG.postgreSQLConnectionString ci
-        return $ PostgresConf cstr pool
+        return $ PostgresConf cstr poolSize poolStripes poolIdleTimeout
 instance PersistConfig PostgresConf where
     type PersistConfigBackend PostgresConf = SqlPersistT
     type PersistConfigPool PostgresConf = ConnectionPool

persistent/Database/Persist/Sql/Run.hs

@@ -202,20 +202,34 @@ withSqlPool mkConn connCount f = withUnliftIO $ \u -> bracket
     destroyAllResources
     (unliftIO u . f)
 
+-- TODO add a version of withSqlPool that takes a ConnectionPoolConfig
+
 createSqlPool
     :: forall backend m. (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
     => (LogFunc -> IO backend)
     -> Int
     -> m (Pool backend)
-createSqlPool mkConn size = do
+createSqlPool mkConn size = createSqlPoolWithConfig mkConn (defaultConnectionPoolConfig { connectionPoolConfigSize = size } )
+
+createSqlPoolWithConfig
+    :: forall m backend. (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend)
+    => (LogFunc -> IO backend)
+    -> ConnectionPoolConfig
+    -> m (Pool backend)
+createSqlPoolWithConfig mkConn config = do
     logFunc <- askLogFunc
     -- Resource pool will swallow any exceptions from close. We want to log
     -- them instead.
     let loggedClose :: backend -> IO ()
         loggedClose backend = close' backend `UE.catchAny` \e -> runLoggingT
           (logError $ T.pack $ "Error closing database connection in pool: " ++ show e)
           logFunc
-    liftIO $ createPool (mkConn logFunc) loggedClose 1 20 size
+    liftIO $ createPool 
+        (mkConn logFunc) 
+        loggedClose 
+        (connectionPoolConfigStripes config)
+        (connectionPoolConfigIdleTimeout config)
+        (connectionPoolConfigSize config)
 
 -- NOTE: This function is a terrible, ugly hack. It would be much better to
 -- just clean up monad-logger.

persistent/Database/Persist/Sql/Types.hs

@@ -5,6 +5,8 @@ module Database.Persist.Sql.Types
     , readToUnknown, readToWrite, writeToUnknown
     , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend
     , OverflowNatural(..)
+    , ConnectionPoolConfig(..)
+    , defaultConnectionPoolConfig
     ) where
 
 import Control.Exception (Exception(..))
@@ -18,6 +20,7 @@ import Data.Typeable (Typeable)
 
 import Database.Persist.Types
 import Database.Persist.Sql.Types.Internal
+import Data.Time (NominalDiffTime)
 
 data Column = Column
     { cName      :: !DBName
@@ -56,6 +59,16 @@ type Migration = WriterT [Text] (WriterT CautiousMigration (ReaderT SqlBackend I
 
 type ConnectionPool = Pool SqlBackend
 
+data ConnectionPoolConfig = ConnectionPoolConfig
+    { connectionPoolConfigStripes :: Int
+    , connectionPoolConfigIdleTimeout :: NominalDiffTime
+    , connectionPoolConfigSize :: Int
+    }
+    deriving (Show)
+
+defaultConnectionPoolConfig :: ConnectionPoolConfig
+defaultConnectionPoolConfig = ConnectionPoolConfig 1 600 10
+
 -- $rawSql
 --
 -- Although it covers most of the useful cases, @persistent@'s