{-# LANGUAGE
DeriveFunctor
, FlexibleContexts
, FlexibleInstances
, InstanceSigs
, MultiParamTypeClasses
, RankNTypes
, ScopedTypeVariables
, TypeFamilies
, TypeInType
, UndecidableInstances
#-}
module Squeal.PostgreSQL.Pool
(
PoolPQ (..)
, createConnectionPool
, Pool
, destroyAllResources
) where
import Control.Monad.Trans
import Data.ByteString
import Data.Time
import Generics.SOP (K(..))
import UnliftIO (MonadUnliftIO (..))
import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)
import qualified Control.Monad.Fail as Fail
import Squeal.PostgreSQL.PQ
import Squeal.PostgreSQL.Schema
newtype PoolPQ (schemas :: SchemasType) m x =
PoolPQ { runPoolPQ :: Pool (K Connection schemas) -> m x }
deriving Functor
createConnectionPool
:: MonadUnliftIO io
=> ByteString
-> Int
-> NominalDiffTime
-> Int
-> io (Pool (K Connection schemas))
createConnectionPool conninfo stripes idle maxResrc =
createPool (connectdb conninfo) finish stripes idle maxResrc
instance Monad m => Applicative (PoolPQ schemas m) where
pure x = PoolPQ $ \ _ -> pure x
PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do
f' <- f pool
x' <- x pool
return $ f' x'
instance Monad m => Monad (PoolPQ schemas m) where
return = pure
PoolPQ x >>= f = PoolPQ $ \ pool -> do
x' <- x pool
runPoolPQ (f x') pool
instance Monad m => Fail.MonadFail (PoolPQ schemas m) where
fail = Fail.fail
instance MonadTrans (PoolPQ schemas) where
lift m = PoolPQ $ \ _pool -> m
instance MonadUnliftIO io => MonadPQ schemas (PoolPQ schemas io) where
manipulateParams manipulation params = PoolPQ $ \ pool -> do
withResource pool $ \ conn -> do
(K result :: K (K Result ys) schemas) <- flip unPQ conn $
manipulateParams manipulation params
return result
traversePrepared manipulation params = PoolPQ $ \ pool ->
withResource pool $ \ conn -> do
(K result :: K (list (K Result ys)) schemas) <- flip unPQ conn $
traversePrepared manipulation params
return result
traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
withResource pool $ \ conn -> do
(_ :: K () schemas) <- flip unPQ conn $
traversePrepared_ manipulation params
return ()
liftPQ m = PoolPQ $ \ pool ->
withResource pool $ \ conn -> do
(K result :: K result schemas) <- flip unPQ conn $
liftPQ m
return result
instance (MonadIO m)
=> MonadIO (PoolPQ schemas m) where
liftIO = lift . liftIO
instance (MonadUnliftIO m)
=> MonadUnliftIO (PoolPQ schemas m) where
withRunInIO
:: ((forall a . PoolPQ schemas m a -> IO a) -> IO b)
-> PoolPQ schemas m b
withRunInIO inner = PoolPQ $ \pool ->
withRunInIO $ \(run :: (forall x . m x -> IO x)) ->
inner (\poolpq -> run $ runPoolPQ poolpq pool)