module Database.PostgreSQL.Config
(
PostgresConf(..)
, PGPool(..)
, createPGPool
, PGCallback
, createPGPoolWithCallback
, pingPGPool
, withPGPool
, withPGPoolPrim
) where
import Prelude
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.Aeson
import Data.ByteString ( ByteString )
import Data.Pool
import Data.Time
import Data.Typeable
import GHC.Generics
import qualified Database.PostgreSQL.Simple as PG
newtype PGPool = PGPool
{ unPGPool :: (Pool PG.Connection)
} deriving ( Show, Typeable, Generic )
data PostgresConf = PostgresConf
{ pgConnStr :: ByteString
, pgPoolSize :: Int
, pgPoolTimeout :: NominalDiffTime
, pgPoolStripes :: Int
} deriving (Ord, Eq, Show)
instance FromJSON PostgresConf where
parseJSON = withObject "PostgresConf" $ \o -> do
database <- o .: "database"
host <- o .:? "host" .!= "127.0.0.1"
port <- o .:? "port" .!= 5432
user <- o .: "user"
password <- o .: "password"
pSize <- o .:? "poolsize" .!= 10
pTimeout <- o .:? "pooltimeout" .!= 60
pStripes <- o .:? "poolstripes" .!= 1
let ci = PG.ConnectInfo
{ PG.connectHost = host
, PG.connectPort = port
, PG.connectUser = user
, PG.connectPassword = password
, PG.connectDatabase = database
}
cstr = PG.postgreSQLConnectionString ci
return $ PostgresConf
{ pgConnStr = cstr
, pgPoolSize = pSize
, pgPoolTimeout = fromInteger pTimeout
, pgPoolStripes = pStripes
}
createPGPool :: PostgresConf -> IO PGPool
createPGPool = flip createPGPoolWithCallback mock
where mock = const $ return ()
type PGCallback = PG.Connection -> IO ()
createPGPoolWithCallback
:: PostgresConf
-> PGCallback
-> IO PGPool
createPGPoolWithCallback pgc callback =
fmap PGPool
$ createPool
(connectAndExecQuery pgc callback)
PG.close
(pgPoolStripes pgc)
(pgPoolTimeout pgc)
(pgPoolSize pgc)
connectAndExecQuery :: PostgresConf
-> PGCallback
-> IO PG.Connection
connectAndExecQuery pgc callback = do
conn <- PG.connectPostgreSQL $ pgConnStr pgc
_ <- callback conn
return conn
withPGPool :: (MonadReader site m, MonadBaseControl IO m)
=> (site -> PGPool)
-> (PG.Connection -> m a)
-> m a
withPGPool extract action = do
(PGPool pool) <- asks extract
withResource pool action
withPGPoolPrim :: (MonadBaseControl IO m)
=> m PGPool
-> (PG.Connection -> m a)
-> m a
withPGPoolPrim pget action = do
(PGPool pool) <- pget
withResource pool action
pingPGPool :: PGPool -> IO ()
pingPGPool (PGPool pool) = withResource pool $ const (return ())