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
  { -- | Connection info string.
    ConnectionSettings -> Text
csConnInfo       :: !T.Text
    -- | Client-side encoding. If set to 'Nothing', database encoding is used.
  , ConnectionSettings -> Maybe Text
csClientEncoding :: !(Maybe T.Text)
    -- | A list of composite types to register. In order to be able to
    -- (de)serialize specific composite types, you need to register them.
  , 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)

-- | Default connection settings. Note that all strings sent to PostgreSQL by
-- the library are encoded as UTF-8, so don't alter client encoding unless you
-- know what you're doing.
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     = []
  }

----------------------------------------

-- | Simple connection statistics.
data ConnectionStats = ConnectionStats
  { -- | Number of queries executed so far.
    ConnectionStats -> Int
statsQueries :: !Int
    -- | Number of rows fetched from the database.
  , ConnectionStats -> Int
statsRows    :: !Int
    -- | Number of values fetched from the database.
  , ConnectionStats -> Int
statsValues  :: !Int
    -- | Number of parameters sent to the database.
  , 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)

-- | Initial connection statistics.
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
}

-- | Representation of a connection object.
--
-- /Note:/ PGconn is not managed with a ForeignPtr because finalizers are broken
-- and at program exit might run even though another thread is inside the
-- relevant withForeignPtr block, executing a safe FFI call (in this case
-- executing an SQL query).
--
-- See https://gitlab.haskell.org/ghc/ghc/-/issues/10975 for more info.
data ConnectionData = ConnectionData
  { ConnectionData -> Ptr PGconn
cdPtr      :: !(Ptr PGconn)
  -- ^ Pointer to connection object.
  , ConnectionData -> ConnectionStats
cdStats    :: !ConnectionStats
  -- ^ Statistics associated with the connection.
  , ConnectionData -> IORef (Set Text)
cdPreparedQueries :: !(IORef (S.Set T.Text))
  -- ^ A set of named prepared statements of the connection.
  }

-- | Wrapper for hiding representation of a connection object.
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

-- | Database connection supplier.
newtype ConnectionSourceM m = ConnectionSourceM {
  forall (m :: * -> *).
ConnectionSourceM m -> forall r. (Connection -> m r) -> m r
withConnection :: forall r. (Connection -> m r) -> m r
}

-- | Wrapper for a polymorphic connection source.
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
}

-- | Default connection supplier. It establishes new
-- database connection each time 'withConnection' is called.
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)
}

-- | Pooled source. It uses striped pool from @resource-pool@ package to cache
-- established connections and reuse them.
poolSource
  :: ConnectionSettings
  -> Double
  -- ^ The amount of seconds for which an unused database connection is kept
  -- open. The smallest acceptable value is 0.5 seconds.
  --
  -- /Note:/ the elapsed time before closing database connection may be a little
  -- longer than requested, as the reaper thread wakes at 1-second intervals.
  -> Int
  -- ^ The maximum number of database connections to keep open.
  --
  -- /Note:/ for each stripe the number of resources is divided by the number of
  -- capabilities and rounded up. Therefore the pool might end up creating up to
  -- @N - 1@ resources more in total than specified, where @N@ is the number of
  -- capabilities.
  -> 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

----------------------------------------

-- | Low-level function for connecting to the database. Useful if one wants to
-- implement custom connection source.
--
-- /Warning:/ the 'Connection' needs to be explicitly destroyed with
-- 'disconnect', otherwise there will be a resource leak.
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
      -- We want to use non-blocking C functions to be able to observe incoming
      -- asynchronous exceptions, hence we don't use PQconnectdb here.
      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]
++)

-- | Low-level function for disconnecting from the database. Useful if one wants
-- to implement custom connection source.
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
      -- This covers the case when a connection is closed while other Haskell
      -- threads are using GHC's IO manager to wait on the descriptor. This is
      -- commonly the case with asynchronous notifications, for example. Since
      -- libpq is responsible for opening and closing the file descriptor, GHC's
      -- IO manager needs to be informed that the file descriptor has been
      -- closed. The IO manager will then raise an exception in those threads.
      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 -- can happen if the connection is bad/lost
        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