module Database.PostgreSQL.PQTypes.Internal.Connection (
Connection(..)
, ConnectionData(..)
, withConnectionData
, ConnectionStats(..)
, ConnectionSettings(..)
, defaultConnectionSettings
, ConnectionSourceM(..)
, ConnectionSource(..)
, simpleSource
, poolSource
, connect
, disconnect
) where
import Control.Arrow (first)
import Control.Concurrent
import Control.Monad
import Control.Monad.Base
import Control.Monad.Catch
import Data.Function
import Data.IORef
import Data.Kind
import Data.Pool
import Foreign.C.String
import Foreign.Ptr
import GHC.Conc (closeFdWith)
import qualified Control.Exception as E
import qualified Data.ByteString as BS
import qualified Data.Foldable as F
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Database.PostgreSQL.PQTypes.Internal.C.Interface
import Database.PostgreSQL.PQTypes.Internal.C.Types
import Database.PostgreSQL.PQTypes.Internal.Composite
import Database.PostgreSQL.PQTypes.Internal.Error
import Database.PostgreSQL.PQTypes.Internal.Utils
data ConnectionSettings = ConnectionSettings
{
ConnectionSettings -> Text
csConnInfo :: !T.Text
, ConnectionSettings -> Maybe Text
csClientEncoding :: !(Maybe T.Text)
, ConnectionSettings -> [Text]
csComposites :: ![T.Text]
} deriving (ConnectionSettings -> ConnectionSettings -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectionSettings -> ConnectionSettings -> Bool
$c/= :: ConnectionSettings -> ConnectionSettings -> Bool
== :: ConnectionSettings -> ConnectionSettings -> Bool
$c== :: ConnectionSettings -> ConnectionSettings -> Bool
Eq, Eq ConnectionSettings
ConnectionSettings -> ConnectionSettings -> Bool
ConnectionSettings -> ConnectionSettings -> Ordering
ConnectionSettings -> ConnectionSettings -> ConnectionSettings
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ConnectionSettings -> ConnectionSettings -> ConnectionSettings
$cmin :: ConnectionSettings -> ConnectionSettings -> ConnectionSettings
max :: ConnectionSettings -> ConnectionSettings -> ConnectionSettings
$cmax :: ConnectionSettings -> ConnectionSettings -> ConnectionSettings
>= :: ConnectionSettings -> ConnectionSettings -> Bool
$c>= :: ConnectionSettings -> ConnectionSettings -> Bool
> :: ConnectionSettings -> ConnectionSettings -> Bool
$c> :: ConnectionSettings -> ConnectionSettings -> Bool
<= :: ConnectionSettings -> ConnectionSettings -> Bool
$c<= :: ConnectionSettings -> ConnectionSettings -> Bool
< :: ConnectionSettings -> ConnectionSettings -> Bool
$c< :: ConnectionSettings -> ConnectionSettings -> Bool
compare :: ConnectionSettings -> ConnectionSettings -> Ordering
$ccompare :: ConnectionSettings -> ConnectionSettings -> Ordering
Ord, Int -> ConnectionSettings -> ShowS
[ConnectionSettings] -> ShowS
ConnectionSettings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionSettings] -> ShowS
$cshowList :: [ConnectionSettings] -> ShowS
show :: ConnectionSettings -> String
$cshow :: ConnectionSettings -> String
showsPrec :: Int -> ConnectionSettings -> ShowS
$cshowsPrec :: Int -> ConnectionSettings -> ShowS
Show)
defaultConnectionSettings :: ConnectionSettings
defaultConnectionSettings :: ConnectionSettings
defaultConnectionSettings =
ConnectionSettings
{ csConnInfo :: Text
csConnInfo = Text
T.empty
, csClientEncoding :: Maybe Text
csClientEncoding = forall a. a -> Maybe a
Just Text
"UTF-8"
, csComposites :: [Text]
csComposites = []
}
data ConnectionStats = ConnectionStats
{
ConnectionStats -> Int
statsQueries :: !Int
, ConnectionStats -> Int
statsRows :: !Int
, ConnectionStats -> Int
statsValues :: !Int
, ConnectionStats -> Int
statsParams :: !Int
} deriving (ConnectionStats -> ConnectionStats -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectionStats -> ConnectionStats -> Bool
$c/= :: ConnectionStats -> ConnectionStats -> Bool
== :: ConnectionStats -> ConnectionStats -> Bool
$c== :: ConnectionStats -> ConnectionStats -> Bool
Eq, Eq ConnectionStats
ConnectionStats -> ConnectionStats -> Bool
ConnectionStats -> ConnectionStats -> Ordering
ConnectionStats -> ConnectionStats -> ConnectionStats
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ConnectionStats -> ConnectionStats -> ConnectionStats
$cmin :: ConnectionStats -> ConnectionStats -> ConnectionStats
max :: ConnectionStats -> ConnectionStats -> ConnectionStats
$cmax :: ConnectionStats -> ConnectionStats -> ConnectionStats
>= :: ConnectionStats -> ConnectionStats -> Bool
$c>= :: ConnectionStats -> ConnectionStats -> Bool
> :: ConnectionStats -> ConnectionStats -> Bool
$c> :: ConnectionStats -> ConnectionStats -> Bool
<= :: ConnectionStats -> ConnectionStats -> Bool
$c<= :: ConnectionStats -> ConnectionStats -> Bool
< :: ConnectionStats -> ConnectionStats -> Bool
$c< :: ConnectionStats -> ConnectionStats -> Bool
compare :: ConnectionStats -> ConnectionStats -> Ordering
$ccompare :: ConnectionStats -> ConnectionStats -> Ordering
Ord, Int -> ConnectionStats -> ShowS
[ConnectionStats] -> ShowS
ConnectionStats -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionStats] -> ShowS
$cshowList :: [ConnectionStats] -> ShowS
show :: ConnectionStats -> String
$cshow :: ConnectionStats -> String
showsPrec :: Int -> ConnectionStats -> ShowS
$cshowsPrec :: Int -> ConnectionStats -> ShowS
Show)
initialStats :: ConnectionStats
initialStats :: ConnectionStats
initialStats = ConnectionStats {
statsQueries :: Int
statsQueries = Int
0
, statsRows :: Int
statsRows = Int
0
, statsValues :: Int
statsValues = Int
0
, statsParams :: Int
statsParams = Int
0
}
data ConnectionData = ConnectionData
{ ConnectionData -> Ptr PGconn
cdPtr :: !(Ptr PGconn)
, ConnectionData -> ConnectionStats
cdStats :: !ConnectionStats
, ConnectionData -> IORef (Set Text)
cdPreparedQueries :: !(IORef (S.Set T.Text))
}
newtype Connection = Connection {
Connection -> MVar (Maybe ConnectionData)
unConnection :: MVar (Maybe ConnectionData)
}
withConnectionData
:: Connection
-> String
-> (ConnectionData -> IO (ConnectionData, r))
-> IO r
withConnectionData :: forall r.
Connection
-> String -> (ConnectionData -> IO (ConnectionData, r)) -> IO r
withConnectionData (Connection MVar (Maybe ConnectionData)
mvc) String
fname ConnectionData -> IO (ConnectionData, r)
f =
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe ConnectionData)
mvc forall a b. (a -> b) -> a -> b
$ \Maybe ConnectionData
mc -> case Maybe ConnectionData
mc of
Maybe ConnectionData
Nothing -> forall a. String -> IO a
hpqTypesError forall a b. (a -> b) -> a -> b
$ String
fname forall a. [a] -> [a] -> [a]
++ String
": no connection"
Just ConnectionData
cd -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnectionData -> IO (ConnectionData, r)
f ConnectionData
cd
newtype ConnectionSourceM m = ConnectionSourceM {
forall (m :: * -> *).
ConnectionSourceM m -> forall r. (Connection -> m r) -> m r
withConnection :: forall r. (Connection -> m r) -> m r
}
newtype ConnectionSource (cs :: [(Type -> Type) -> Constraint]) = ConnectionSource {
forall (cs :: [(* -> *) -> Constraint]).
ConnectionSource cs
-> forall (m :: * -> *). MkConstraint m cs => ConnectionSourceM m
unConnectionSource :: forall m. MkConstraint m cs => ConnectionSourceM m
}
simpleSource
:: ConnectionSettings
-> ConnectionSource [MonadBase IO, MonadMask]
simpleSource :: ConnectionSettings -> ConnectionSource '[MonadBase IO, MonadMask]
simpleSource ConnectionSettings
cs = forall (cs :: [(* -> *) -> Constraint]).
(forall (m :: * -> *). MkConstraint m cs => ConnectionSourceM m)
-> ConnectionSource cs
ConnectionSource forall a b. (a -> b) -> a -> b
$ ConnectionSourceM {
withConnection :: forall r. (Connection -> m r) -> m r
withConnection = forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ ConnectionSettings -> IO Connection
connect ConnectionSettings
cs) (forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO ()
disconnect)
}
poolSource
:: ConnectionSettings
-> Double
-> Int
-> IO (ConnectionSource [MonadBase IO, MonadMask])
poolSource :: ConnectionSettings
-> Double
-> Int
-> IO (ConnectionSource '[MonadBase IO, MonadMask])
poolSource ConnectionSettings
cs Double
idleTime Int
maxResources = do
Pool Connection
pool <- forall a. PoolConfig a -> IO (Pool a)
newPool PoolConfig
{ createResource :: IO Connection
createResource = ConnectionSettings -> IO Connection
connect ConnectionSettings
cs
, freeResource :: Connection -> IO ()
freeResource = Connection -> IO ()
disconnect
, poolCacheTTL :: Double
poolCacheTTL = Double
idleTime
, poolMaxResources :: Int
poolMaxResources = Int
maxResources
}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (cs :: [(* -> *) -> Constraint]).
(forall (m :: * -> *). MkConstraint m cs => ConnectionSourceM m)
-> ConnectionSource cs
ConnectionSource forall a b. (a -> b) -> a -> b
$ ConnectionSourceM {
withConnection :: forall r. (Connection -> m r) -> m r
withConnection = forall {f :: * -> *} {t} {b}.
(MonadMask f, MonadBase IO f) =>
Pool t -> (t -> f b) -> f b
doWithConnection Pool Connection
pool forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {m :: * -> *}. MonadBase IO m => Connection -> m Connection
clearStats forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>)
}
where
doWithConnection :: Pool t -> (t -> f b) -> f b
doWithConnection Pool t
pool t -> f b
m = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
(forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall a. Pool a -> IO (a, LocalPool a)
takeResource Pool t
pool)
(\(t
resource, LocalPool t
local) -> \case
ExitCaseSuccess b
_ -> forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall a. LocalPool a -> a -> IO ()
putResource LocalPool t
local t
resource
ExitCase b
_ -> forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall a. Pool a -> LocalPool a -> a -> IO ()
destroyResource Pool t
pool LocalPool t
local t
resource
)
(\(t
resource, LocalPool t
_) -> t -> f b
m t
resource)
clearStats :: Connection -> m Connection
clearStats conn :: Connection
conn@(Connection MVar (Maybe ConnectionData)
mv) = do
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe ConnectionData)
mv forall a b. (a -> b) -> a -> b
$ \Maybe ConnectionData
mconn ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (\ConnectionData
cd -> ConnectionData
cd { cdStats :: ConnectionStats
cdStats = ConnectionStats
initialStats }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConnectionData
mconn
forall (m :: * -> *) a. Monad m => a -> m a
return Connection
conn
connect :: ConnectionSettings -> IO Connection
connect :: ConnectionSettings -> IO Connection
connect ConnectionSettings{[Text]
Maybe Text
Text
csComposites :: [Text]
csClientEncoding :: Maybe Text
csConnInfo :: Text
csComposites :: ConnectionSettings -> [Text]
csClientEncoding :: ConnectionSettings -> Maybe Text
csConnInfo :: ConnectionSettings -> Text
..} = forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
Ptr PGconn
conn <- forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString (Text -> ByteString
T.encodeUtf8 Text
csConnInfo) ((forall a. IO a -> IO a) -> CString -> IO (Ptr PGconn)
openConnection forall a. IO a -> IO a
unmask)
(forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` Ptr PGconn -> IO ()
c_PQfinish Ptr PGconn
conn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ do
ConnStatusType
status <- Ptr PGconn -> IO ConnStatusType
c_PQstatus Ptr PGconn
conn
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnStatusType
status forall a. Eq a => a -> a -> Bool
/= ConnStatusType
c_CONNECTION_OK) forall a b. (a -> b) -> a -> b
$
forall a. Ptr PGconn -> String -> IO a
throwLibPQError Ptr PGconn
conn String
fname
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Maybe Text
csClientEncoding forall a b. (a -> b) -> a -> b
$ \Text
enc -> do
CInt
res <- forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString (Text -> ByteString
T.encodeUtf8 Text
enc) (Ptr PGconn -> CString -> IO CInt
c_PQsetClientEncoding Ptr PGconn
conn)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res forall a. Eq a => a -> a -> Bool
== -CInt
1) forall a b. (a -> b) -> a -> b
$
forall a. Ptr PGconn -> String -> IO a
throwLibPQError Ptr PGconn
conn String
fname
Ptr PGconn -> IO ()
c_PQinitTypes Ptr PGconn
conn
Ptr PGconn -> [Text] -> IO ()
registerComposites Ptr PGconn
conn [Text]
csComposites
IORef (Set Text)
preparedQueries <- forall a. a -> IO (IORef a)
newIORef forall a. Set a
S.empty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVar (Maybe ConnectionData) -> Connection
Connection forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> IO (MVar a)
newMVar forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ConnectionData
{ cdPtr :: Ptr PGconn
cdPtr = Ptr PGconn
conn
, cdStats :: ConnectionStats
cdStats = ConnectionStats
initialStats
, cdPreparedQueries :: IORef (Set Text)
cdPreparedQueries = IORef (Set Text)
preparedQueries
}
where
fname :: String
fname = String
"connect"
openConnection :: (forall r. IO r -> IO r) -> CString -> IO (Ptr PGconn)
openConnection :: (forall a. IO a -> IO a) -> CString -> IO (Ptr PGconn)
openConnection forall a. IO a -> IO a
unmask CString
conninfo = do
Ptr PGconn
conn <- CString -> IO (Ptr PGconn)
c_PQconnectStart CString
conninfo
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr PGconn
conn forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr) forall a b. (a -> b) -> a -> b
$
forall a. String -> IO a
throwError String
"PQconnectStart returned a null pointer"
(forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` Ptr PGconn -> IO ()
c_PQfinish Ptr PGconn
conn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO (Ptr PGconn)
loop -> do
PostgresPollingStatusType
ps <- Ptr PGconn -> IO PostgresPollingStatusType
c_PQconnectPoll Ptr PGconn
conn
if | PostgresPollingStatusType
ps forall a. Eq a => a -> a -> Bool
== PostgresPollingStatusType
c_PGRES_POLLING_READING -> (Fd -> IO ()
threadWaitRead forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr PGconn -> IO Fd
getFd Ptr PGconn
conn) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Ptr PGconn)
loop
| PostgresPollingStatusType
ps forall a. Eq a => a -> a -> Bool
== PostgresPollingStatusType
c_PGRES_POLLING_WRITING -> (Fd -> IO ()
threadWaitWrite forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr PGconn -> IO Fd
getFd Ptr PGconn
conn) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Ptr PGconn)
loop
| PostgresPollingStatusType
ps forall a. Eq a => a -> a -> Bool
== PostgresPollingStatusType
c_PGRES_POLLING_OK -> forall (m :: * -> *) a. Monad m => a -> m a
return Ptr PGconn
conn
| Bool
otherwise -> do
Maybe String
merr <- Ptr PGconn -> IO CString
c_PQerrorMessage Ptr PGconn
conn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO (Maybe String)
safePeekCString
let reason :: String
reason = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
err -> String
": " forall a. Semigroup a => a -> a -> a
<> String
err) Maybe String
merr
forall a. String -> IO a
throwError forall a b. (a -> b) -> a -> b
$ String
"openConnection failed" forall a. Semigroup a => a -> a -> a
<> String
reason
where
getFd :: Ptr PGconn -> IO Fd
getFd Ptr PGconn
conn = do
Fd
fd <- Ptr PGconn -> IO Fd
c_PQsocket Ptr PGconn
conn
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Fd
fd forall a. Eq a => a -> a -> Bool
== -Fd
1) forall a b. (a -> b) -> a -> b
$
forall a. String -> IO a
throwError String
"invalid file descriptor"
forall (m :: * -> *) a. Monad m => a -> m a
return Fd
fd
throwError :: String -> IO a
throwError :: forall a. String -> IO a
throwError = forall a. String -> IO a
hpqTypesError forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
fname forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
": " forall a. [a] -> [a] -> [a]
++)
disconnect :: Connection -> IO ()
disconnect :: Connection -> IO ()
disconnect (Connection MVar (Maybe ConnectionData)
mvconn) = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe ConnectionData)
mvconn forall a b. (a -> b) -> a -> b
$ \Maybe ConnectionData
mconn -> do
case Maybe ConnectionData
mconn of
Just ConnectionData
cd -> do
let conn :: Ptr PGconn
conn = ConnectionData -> Ptr PGconn
cdPtr ConnectionData
cd
Ptr PGconn -> IO Fd
c_PQsocket Ptr PGconn
conn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
-1 -> Ptr PGconn -> IO ()
c_PQfinish Ptr PGconn
conn
Fd
fd -> (Fd -> IO ()) -> Fd -> IO ()
closeFdWith (\Fd
_ -> Ptr PGconn -> IO ()
c_PQfinish Ptr PGconn
conn) Fd
fd
Maybe ConnectionData
Nothing -> forall e a. Exception e => e -> IO a
E.throwIO (String -> HPQTypesError
HPQTypesError String
"disconnect: no connection (shouldn't happen)")
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing