{-# LANGUAGE CPP #-}
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.Kind (Type)
import Data.Pool
import Data.Time.Clock
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
import GHC.Exts
import qualified Control.Exception as E
import qualified Data.ByteString as BS
import qualified Data.Foldable as F
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
(ConnectionSettings -> ConnectionSettings -> Bool)
-> (ConnectionSettings -> ConnectionSettings -> Bool)
-> Eq ConnectionSettings
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
Eq ConnectionSettings
-> (ConnectionSettings -> ConnectionSettings -> Ordering)
-> (ConnectionSettings -> ConnectionSettings -> Bool)
-> (ConnectionSettings -> ConnectionSettings -> Bool)
-> (ConnectionSettings -> ConnectionSettings -> Bool)
-> (ConnectionSettings -> ConnectionSettings -> Bool)
-> (ConnectionSettings -> ConnectionSettings -> ConnectionSettings)
-> (ConnectionSettings -> ConnectionSettings -> ConnectionSettings)
-> Ord 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
$cp1Ord :: Eq ConnectionSettings
Ord, Int -> ConnectionSettings -> ShowS
[ConnectionSettings] -> ShowS
ConnectionSettings -> String
(Int -> ConnectionSettings -> ShowS)
-> (ConnectionSettings -> String)
-> ([ConnectionSettings] -> ShowS)
-> Show ConnectionSettings
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 :: Text -> Maybe Text -> [Text] -> ConnectionSettings
ConnectionSettings
{ csConnInfo :: Text
csConnInfo = Text
T.empty
, csClientEncoding :: Maybe Text
csClientEncoding = Text -> Maybe Text
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
(ConnectionStats -> ConnectionStats -> Bool)
-> (ConnectionStats -> ConnectionStats -> Bool)
-> Eq ConnectionStats
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
Eq ConnectionStats
-> (ConnectionStats -> ConnectionStats -> Ordering)
-> (ConnectionStats -> ConnectionStats -> Bool)
-> (ConnectionStats -> ConnectionStats -> Bool)
-> (ConnectionStats -> ConnectionStats -> Bool)
-> (ConnectionStats -> ConnectionStats -> Bool)
-> (ConnectionStats -> ConnectionStats -> ConnectionStats)
-> (ConnectionStats -> ConnectionStats -> ConnectionStats)
-> Ord 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
$cp1Ord :: Eq ConnectionStats
Ord, Int -> ConnectionStats -> ShowS
[ConnectionStats] -> ShowS
ConnectionStats -> String
(Int -> ConnectionStats -> ShowS)
-> (ConnectionStats -> String)
-> ([ConnectionStats] -> ShowS)
-> Show ConnectionStats
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 :: Int -> Int -> Int -> Int -> ConnectionStats
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 -> ForeignPtr (Ptr PGconn)
cdFrgnPtr :: !(ForeignPtr (Ptr PGconn))
, ConnectionData -> Ptr PGconn
cdPtr :: !(Ptr PGconn)
, ConnectionData -> ConnectionStats
cdStats :: !ConnectionStats
}
newtype Connection = Connection {
Connection -> MVar (Maybe ConnectionData)
unConnection :: MVar (Maybe ConnectionData)
}
withConnectionData
:: Connection
-> String
-> (ConnectionData -> IO (ConnectionData, r))
-> IO r
withConnectionData :: Connection
-> String -> (ConnectionData -> IO (ConnectionData, r)) -> IO r
withConnectionData (Connection MVar (Maybe ConnectionData)
mvc) String
fname ConnectionData -> IO (ConnectionData, r)
f =
MVar (Maybe ConnectionData)
-> (Maybe ConnectionData -> IO (Maybe ConnectionData, r)) -> IO r
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe ConnectionData)
mvc ((Maybe ConnectionData -> IO (Maybe ConnectionData, r)) -> IO r)
-> (Maybe ConnectionData -> IO (Maybe ConnectionData, r)) -> IO r
forall a b. (a -> b) -> a -> b
$ \Maybe ConnectionData
mc -> case Maybe ConnectionData
mc of
Maybe ConnectionData
Nothing -> String -> IO (Maybe ConnectionData, r)
forall a. String -> IO a
hpqTypesError (String -> IO (Maybe ConnectionData, r))
-> String -> IO (Maybe ConnectionData, r)
forall a b. (a -> b) -> a -> b
$ String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": no connection"
Just ConnectionData
cd -> (ConnectionData -> Maybe ConnectionData)
-> (ConnectionData, r) -> (Maybe ConnectionData, r)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ConnectionData -> Maybe ConnectionData
forall a. a -> Maybe a
Just ((ConnectionData, r) -> (Maybe ConnectionData, r))
-> IO (ConnectionData, r) -> IO (Maybe ConnectionData, r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnectionData -> IO (ConnectionData, r)
f ConnectionData
cd
newtype ConnectionSourceM m = ConnectionSourceM {
ConnectionSourceM m -> forall r. (Connection -> m r) -> m r
withConnection :: forall r. (Connection -> m r) -> m r
}
newtype ConnectionSource (cs :: [(Type -> Type) -> Constraint]) = ConnectionSource {
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 (m :: * -> *).
MkConstraint m '[MonadBase IO, MonadMask] =>
ConnectionSourceM m)
-> ConnectionSource '[MonadBase IO, MonadMask]
forall (cs :: [(* -> *) -> Constraint]).
(forall (m :: * -> *). MkConstraint m cs => ConnectionSourceM m)
-> ConnectionSource cs
ConnectionSource ((forall (m :: * -> *).
MkConstraint m '[MonadBase IO, MonadMask] =>
ConnectionSourceM m)
-> ConnectionSource '[MonadBase IO, MonadMask])
-> (forall (m :: * -> *).
MkConstraint m '[MonadBase IO, MonadMask] =>
ConnectionSourceM m)
-> ConnectionSource '[MonadBase IO, MonadMask]
forall a b. (a -> b) -> a -> b
$ ConnectionSourceM :: forall (m :: * -> *).
(forall r. (Connection -> m r) -> m r) -> ConnectionSourceM m
ConnectionSourceM {
withConnection :: forall r. (Connection -> m r) -> m r
withConnection = m Connection -> (Connection -> m ()) -> (Connection -> m r) -> m r
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO Connection -> m Connection
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Connection -> m Connection) -> IO Connection -> m Connection
forall a b. (a -> b) -> a -> b
$ ConnectionSettings -> IO Connection
connect ConnectionSettings
cs) (IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> (Connection -> IO ()) -> Connection -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO ()
disconnect)
}
poolSource
:: ConnectionSettings
-> Int
-> NominalDiffTime
-> Int
-> IO (ConnectionSource [MonadBase IO, MonadMask])
poolSource :: ConnectionSettings
-> Int
-> NominalDiffTime
-> Int
-> IO (ConnectionSource '[MonadBase IO, MonadMask])
poolSource ConnectionSettings
cs Int
numStripes NominalDiffTime
idleTime Int
maxResources = do
Pool Connection
pool <- IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool Connection)
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
createPool (ConnectionSettings -> IO Connection
connect ConnectionSettings
cs) Connection -> IO ()
disconnect Int
numStripes NominalDiffTime
idleTime Int
maxResources
ConnectionSource '[MonadBase IO, MonadMask]
-> IO (ConnectionSource '[MonadBase IO, MonadMask])
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectionSource '[MonadBase IO, MonadMask]
-> IO (ConnectionSource '[MonadBase IO, MonadMask]))
-> ConnectionSource '[MonadBase IO, MonadMask]
-> IO (ConnectionSource '[MonadBase IO, MonadMask])
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *).
MkConstraint m '[MonadBase IO, MonadMask] =>
ConnectionSourceM m)
-> ConnectionSource '[MonadBase IO, MonadMask]
forall (cs :: [(* -> *) -> Constraint]).
(forall (m :: * -> *). MkConstraint m cs => ConnectionSourceM m)
-> ConnectionSource cs
ConnectionSource ((forall (m :: * -> *).
MkConstraint m '[MonadBase IO, MonadMask] =>
ConnectionSourceM m)
-> ConnectionSource '[MonadBase IO, MonadMask])
-> (forall (m :: * -> *).
MkConstraint m '[MonadBase IO, MonadMask] =>
ConnectionSourceM m)
-> ConnectionSource '[MonadBase IO, MonadMask]
forall a b. (a -> b) -> a -> b
$ ConnectionSourceM :: forall (m :: * -> *).
(forall r. (Connection -> m r) -> m r) -> ConnectionSourceM m
ConnectionSourceM {
withConnection :: forall r. (Connection -> m r) -> m r
withConnection = Pool Connection -> (Connection -> m r) -> m r
forall (f :: * -> *) t b.
(MonadMask f, MonadBase IO f) =>
Pool t -> (t -> f b) -> f b
withResource' Pool Connection
pool ((Connection -> m r) -> m r)
-> ((Connection -> m r) -> Connection -> m r)
-> (Connection -> m r)
-> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> m Connection
forall (m :: * -> *). MonadBase IO m => Connection -> m Connection
clearStats (Connection -> m Connection)
-> (Connection -> m r) -> Connection -> m r
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>)
}
where
#if MIN_VERSION_exceptions(0,9,0)
withResource' :: Pool t -> (t -> f b) -> f b
withResource' Pool t
pool t -> f b
m = (b, ()) -> b
forall a b. (a, b) -> a
fst ((b, ()) -> b) -> f (b, ()) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (t, LocalPool t)
-> ((t, LocalPool t) -> ExitCase b -> f ())
-> ((t, LocalPool t) -> f b)
-> f (b, ())
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
(IO (t, LocalPool t) -> f (t, LocalPool t)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (t, LocalPool t) -> f (t, LocalPool t))
-> IO (t, LocalPool t) -> f (t, LocalPool t)
forall a b. (a -> b) -> a -> b
$ Pool t -> IO (t, LocalPool t)
forall a. Pool a -> IO (a, LocalPool a)
takeResource Pool t
pool)
(\(t
resource, LocalPool t
local) ExitCase b
exitCase -> case ExitCase b
exitCase of
ExitCaseSuccess b
_ -> IO () -> f ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ LocalPool t -> t -> IO ()
forall a. LocalPool a -> a -> IO ()
putResource LocalPool t
local t
resource
ExitCase b
_ -> IO () -> f ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ Pool t -> LocalPool t -> t -> IO ()
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)
#else
withResource' pool m = mask $ \restore -> do
(resource, local) <- liftBase $ takeResource pool
ret <- restore (m resource) `onException`
liftBase (destroyResource pool local resource)
liftBase $ putResource local resource
return ret
#endif
clearStats :: Connection -> m Connection
clearStats conn :: Connection
conn@(Connection MVar (Maybe ConnectionData)
mv) = do
IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ())
-> ((Maybe ConnectionData -> IO (Maybe ConnectionData)) -> IO ())
-> (Maybe ConnectionData -> IO (Maybe ConnectionData))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (Maybe ConnectionData)
-> (Maybe ConnectionData -> IO (Maybe ConnectionData)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe ConnectionData)
mv ((Maybe ConnectionData -> IO (Maybe ConnectionData)) -> m ())
-> (Maybe ConnectionData -> IO (Maybe ConnectionData)) -> m ()
forall a b. (a -> b) -> a -> b
$ \Maybe ConnectionData
mconn ->
Maybe ConnectionData -> IO (Maybe ConnectionData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ConnectionData -> IO (Maybe ConnectionData))
-> Maybe ConnectionData -> IO (Maybe ConnectionData)
forall a b. (a -> b) -> a -> b
$ (\ConnectionData
cd -> ConnectionData
cd { cdStats :: ConnectionStats
cdStats = ConnectionStats
initialStats }) (ConnectionData -> ConnectionData)
-> Maybe ConnectionData -> Maybe ConnectionData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConnectionData
mconn
Connection -> m Connection
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
..} = do
ForeignPtr (Ptr PGconn)
fconn <- ByteString
-> (CString -> IO (ForeignPtr (Ptr PGconn)))
-> IO (ForeignPtr (Ptr PGconn))
forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString (Text -> ByteString
T.encodeUtf8 Text
csConnInfo) CString -> IO (ForeignPtr (Ptr PGconn))
openConnection
ForeignPtr (Ptr PGconn)
-> (Ptr (Ptr PGconn) -> IO Connection) -> IO Connection
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr (Ptr PGconn)
fconn ((Ptr (Ptr PGconn) -> IO Connection) -> IO Connection)
-> (Ptr (Ptr PGconn) -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr PGconn)
connPtr -> do
Ptr PGconn
conn <- Ptr (Ptr PGconn) -> IO (Ptr PGconn)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr PGconn)
connPtr
ConnStatusType
status <- Ptr PGconn -> IO ConnStatusType
c_PQstatus Ptr PGconn
conn
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnStatusType
status ConnStatusType -> ConnStatusType -> Bool
forall a. Eq a => a -> a -> Bool
/= ConnStatusType
c_CONNECTION_OK) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Ptr PGconn -> String -> IO ()
forall a. Ptr PGconn -> String -> IO a
throwLibPQError Ptr PGconn
conn String
fname
Maybe Text -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Maybe Text
csClientEncoding ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
enc -> do
CInt
res <- ByteString -> (CString -> IO CInt) -> IO CInt
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)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== -CInt
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Ptr PGconn -> String -> IO ()
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
MVar (Maybe ConnectionData) -> Connection
Connection (MVar (Maybe ConnectionData) -> Connection)
-> IO (MVar (Maybe ConnectionData)) -> IO Connection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ConnectionData -> IO (MVar (Maybe ConnectionData))
forall a. a -> IO (MVar a)
newMVar (ConnectionData -> Maybe ConnectionData
forall a. a -> Maybe a
Just ConnectionData :: ForeignPtr (Ptr PGconn)
-> Ptr PGconn -> ConnectionStats -> ConnectionData
ConnectionData {
cdFrgnPtr :: ForeignPtr (Ptr PGconn)
cdFrgnPtr = ForeignPtr (Ptr PGconn)
fconn
, cdPtr :: Ptr PGconn
cdPtr = Ptr PGconn
conn
, cdStats :: ConnectionStats
cdStats = ConnectionStats
initialStats
})
where
fname :: String
fname = String
"connect"
openConnection :: CString -> IO (ForeignPtr (Ptr PGconn))
openConnection :: CString -> IO (ForeignPtr (Ptr PGconn))
openConnection CString
conninfo = ((forall a. IO a -> IO a) -> IO (ForeignPtr (Ptr PGconn)))
-> IO (ForeignPtr (Ptr PGconn))
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (((forall a. IO a -> IO a) -> IO (ForeignPtr (Ptr PGconn)))
-> IO (ForeignPtr (Ptr PGconn)))
-> ((forall a. IO a -> IO a) -> IO (ForeignPtr (Ptr PGconn)))
-> IO (ForeignPtr (Ptr PGconn))
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
Ptr PGconn
conn <- CString -> IO (Ptr PGconn)
c_PQconnectStart CString
conninfo
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr PGconn
conn Ptr PGconn -> Ptr PGconn -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr PGconn
forall a. Ptr a
nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
throwError String
"PQconnectStart returned a null pointer"
ForeignPtr (Ptr PGconn)
connPtr <- IO (ForeignPtr (Ptr PGconn))
forall a. Storable a => IO (ForeignPtr a)
mallocForeignPtr
ForeignPtr (Ptr PGconn) -> (Ptr (Ptr PGconn) -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr (Ptr PGconn)
connPtr (Ptr (Ptr PGconn) -> Ptr PGconn -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
`poke` Ptr PGconn
conn)
FinalizerPtr (Ptr PGconn) -> ForeignPtr (Ptr PGconn) -> IO ()
forall a. FinalizerPtr a -> ForeignPtr a -> IO ()
addForeignPtrFinalizer FinalizerPtr (Ptr PGconn)
c_ptr_PQfinishPtr ForeignPtr (Ptr PGconn)
connPtr
IO (ForeignPtr (Ptr PGconn)) -> IO (ForeignPtr (Ptr PGconn))
forall a. IO a -> IO a
restore (IO (ForeignPtr (Ptr PGconn)) -> IO (ForeignPtr (Ptr PGconn)))
-> IO (ForeignPtr (Ptr PGconn)) -> IO (ForeignPtr (Ptr PGconn))
forall a b. (a -> b) -> a -> b
$ (IO (ForeignPtr (Ptr PGconn)) -> IO (ForeignPtr (Ptr PGconn)))
-> IO (ForeignPtr (Ptr PGconn))
forall a. (a -> a) -> a
fix ((IO (ForeignPtr (Ptr PGconn)) -> IO (ForeignPtr (Ptr PGconn)))
-> IO (ForeignPtr (Ptr PGconn)))
-> (IO (ForeignPtr (Ptr PGconn)) -> IO (ForeignPtr (Ptr PGconn)))
-> IO (ForeignPtr (Ptr PGconn))
forall a b. (a -> b) -> a -> b
$ \IO (ForeignPtr (Ptr PGconn))
loop -> do
PostgresPollingStatusType
ps <- Ptr PGconn -> IO PostgresPollingStatusType
c_PQconnectPoll Ptr PGconn
conn
if | PostgresPollingStatusType
ps PostgresPollingStatusType -> PostgresPollingStatusType -> Bool
forall a. Eq a => a -> a -> Bool
== PostgresPollingStatusType
c_PGRES_POLLING_READING -> (Fd -> IO ()
threadWaitRead (Fd -> IO ()) -> IO Fd -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr PGconn -> IO Fd
getFd Ptr PGconn
conn) IO ()
-> IO (ForeignPtr (Ptr PGconn)) -> IO (ForeignPtr (Ptr PGconn))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (ForeignPtr (Ptr PGconn))
loop
| PostgresPollingStatusType
ps PostgresPollingStatusType -> PostgresPollingStatusType -> Bool
forall a. Eq a => a -> a -> Bool
== PostgresPollingStatusType
c_PGRES_POLLING_WRITING -> (Fd -> IO ()
threadWaitWrite (Fd -> IO ()) -> IO Fd -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr PGconn -> IO Fd
getFd Ptr PGconn
conn) IO ()
-> IO (ForeignPtr (Ptr PGconn)) -> IO (ForeignPtr (Ptr PGconn))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (ForeignPtr (Ptr PGconn))
loop
| Bool
otherwise -> ForeignPtr (Ptr PGconn) -> IO (ForeignPtr (Ptr PGconn))
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignPtr (Ptr PGconn)
connPtr
where
getFd :: Ptr PGconn -> IO Fd
getFd Ptr PGconn
conn = do
Fd
fd <- Ptr PGconn -> IO Fd
c_PQsocket Ptr PGconn
conn
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Fd
fd Fd -> Fd -> Bool
forall a. Eq a => a -> a -> Bool
== -Fd
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
throwError String
"invalid file descriptor"
Fd -> IO Fd
forall (m :: * -> *) a. Monad m => a -> m a
return Fd
fd
throwError :: String -> IO ()
throwError = String -> IO ()
forall a. String -> IO a
hpqTypesError (String -> IO ()) -> ShowS -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++)
disconnect :: Connection -> IO ()
disconnect :: Connection -> IO ()
disconnect (Connection MVar (Maybe ConnectionData)
mvconn) = MVar (Maybe ConnectionData)
-> (Maybe ConnectionData -> IO (Maybe ConnectionData)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe ConnectionData)
mvconn ((Maybe ConnectionData -> IO (Maybe ConnectionData)) -> IO ())
-> (Maybe ConnectionData -> IO (Maybe ConnectionData)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe ConnectionData
mconn -> do
case Maybe ConnectionData
mconn of
Just ConnectionData
cd -> ForeignPtr (Ptr PGconn) -> (Ptr (Ptr PGconn) -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (ConnectionData -> ForeignPtr (Ptr PGconn)
cdFrgnPtr ConnectionData
cd) Ptr (Ptr PGconn) -> IO ()
c_PQfinishPtr
Maybe ConnectionData
Nothing -> HPQTypesError -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (String -> HPQTypesError
HPQTypesError String
"disconnect: no connection (shouldn't happen)")
Maybe ConnectionData -> IO (Maybe ConnectionData)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ConnectionData
forall a. Maybe a
Nothing