module Database.PostgreSQL.PQTypes.Internal.Connection
  ( -- * Connection
    Connection (..)
  , getBackendPidIO
  , ConnectionData (..)
  , withConnectionData
  , ConnectionStats (..)
  , ConnectionSettings (..)
  , defaultConnectionSettings
  , ConnectionSourceM (..)
  , ConnectionSource (..)
  , simpleSource
  , poolSource
  , connect
  , disconnect

    -- * Running queries
  , runQueryIO
  , QueryName (..)
  , runPreparedQueryIO
  ) where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception qualified as E
import Control.Monad
import Control.Monad.Base
import Control.Monad.Catch
import Data.ByteString.Char8 qualified as BS
import Data.Foldable qualified as F
import Data.Functor.Identity
import Data.IORef
import Data.Int
import Data.Kind
import Data.Maybe
import Data.Pool
import Data.Set qualified as S
import Data.String
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import GHC.Conc (closeFdWith)
import GHC.Stack

import Database.PostgreSQL.PQTypes.Internal.BackendPid
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.Error.Code
import Database.PostgreSQL.PQTypes.Internal.Exception
import Database.PostgreSQL.PQTypes.Internal.QueryResult
import Database.PostgreSQL.PQTypes.Internal.Utils
import Database.PostgreSQL.PQTypes.SQL.Class
import Database.PostgreSQL.PQTypes.SQL.Raw
import Database.PostgreSQL.PQTypes.ToSQL

data ConnectionSettings = ConnectionSettings
  { ConnectionSettings -> Text
csConnInfo :: !T.Text
  -- ^ Connection info string.
  , ConnectionSettings -> Maybe Text
csClientEncoding :: !(Maybe T.Text)
  -- ^ Client-side encoding. If set to 'Nothing', database encoding is used.
  , ConnectionSettings -> Maybe (RawSQL ())
csRole :: !(Maybe (RawSQL ()))
  -- ^ A custom role to set with "SET ROLE".
  , ConnectionSettings -> [Text]
csComposites :: ![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.
  }
  deriving (ConnectionSettings -> ConnectionSettings -> Bool
(ConnectionSettings -> ConnectionSettings -> Bool)
-> (ConnectionSettings -> ConnectionSettings -> Bool)
-> Eq ConnectionSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnectionSettings -> ConnectionSettings -> Bool
== :: ConnectionSettings -> ConnectionSettings -> Bool
$c/= :: ConnectionSettings -> ConnectionSettings -> Bool
/= :: 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
$ccompare :: ConnectionSettings -> ConnectionSettings -> Ordering
compare :: ConnectionSettings -> ConnectionSettings -> Ordering
$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
>= :: ConnectionSettings -> ConnectionSettings -> Bool
$cmax :: ConnectionSettings -> ConnectionSettings -> ConnectionSettings
max :: ConnectionSettings -> ConnectionSettings -> ConnectionSettings
$cmin :: ConnectionSettings -> ConnectionSettings -> ConnectionSettings
min :: ConnectionSettings -> ConnectionSettings -> 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
$cshowsPrec :: Int -> ConnectionSettings -> ShowS
showsPrec :: Int -> ConnectionSettings -> ShowS
$cshow :: ConnectionSettings -> String
show :: ConnectionSettings -> String
$cshowList :: [ConnectionSettings] -> ShowS
showList :: [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 = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"UTF-8"
    , csRole :: Maybe (RawSQL ())
csRole = Maybe (RawSQL ())
forall a. Maybe a
Nothing
    , csComposites :: [Text]
csComposites = []
    }

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

-- | Simple connection statistics.
data ConnectionStats = ConnectionStats
  { ConnectionStats -> Int
statsQueries :: !Int
  -- ^ Number of queries executed so far.
  , ConnectionStats -> Int
statsRows :: !Int
  -- ^ Number of rows fetched from the database.
  , ConnectionStats -> Int
statsValues :: !Int
  -- ^ Number of values fetched from the database.
  , ConnectionStats -> Int
statsParams :: !Int
  -- ^ Number of parameters sent to the database.
  }
  deriving (ConnectionStats -> ConnectionStats -> Bool
(ConnectionStats -> ConnectionStats -> Bool)
-> (ConnectionStats -> ConnectionStats -> Bool)
-> Eq ConnectionStats
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnectionStats -> ConnectionStats -> Bool
== :: ConnectionStats -> ConnectionStats -> Bool
$c/= :: ConnectionStats -> ConnectionStats -> Bool
/= :: 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
$ccompare :: ConnectionStats -> ConnectionStats -> Ordering
compare :: ConnectionStats -> ConnectionStats -> Ordering
$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
>= :: ConnectionStats -> ConnectionStats -> Bool
$cmax :: ConnectionStats -> ConnectionStats -> ConnectionStats
max :: ConnectionStats -> ConnectionStats -> ConnectionStats
$cmin :: ConnectionStats -> ConnectionStats -> ConnectionStats
min :: ConnectionStats -> ConnectionStats -> 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
$cshowsPrec :: Int -> ConnectionStats -> ShowS
showsPrec :: Int -> ConnectionStats -> ShowS
$cshow :: ConnectionStats -> String
show :: ConnectionStats -> String
$cshowList :: [ConnectionStats] -> ShowS
showList :: [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 -> BackendPid
cdBackendPid :: !BackendPid
  -- ^ Process ID of the server process attached to the current session.
  , 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)
  }

getBackendPidIO :: Connection -> IO BackendPid
getBackendPidIO :: Connection -> IO BackendPid
getBackendPidIO Connection
conn = do
  Connection
-> String
-> (ConnectionData -> IO (ConnectionData, BackendPid))
-> IO BackendPid
forall r.
Connection
-> String -> (ConnectionData -> IO (ConnectionData, r)) -> IO r
withConnectionData Connection
conn String
"getBackendPidIO" ((ConnectionData -> IO (ConnectionData, BackendPid))
 -> IO BackendPid)
-> (ConnectionData -> IO (ConnectionData, BackendPid))
-> IO BackendPid
forall a b. (a -> b) -> a -> b
$ \ConnectionData
cd -> do
    (ConnectionData, BackendPid) -> IO (ConnectionData, BackendPid)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionData
cd, ConnectionData -> BackendPid
cdBackendPid ConnectionData
cd)

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 = 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
$ \case
  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 -> do
    (ConnectionData
cd', r
r) <- ConnectionData -> IO (ConnectionData, r)
f ConnectionData
cd
    ConnectionData
cd' ConnectionData
-> IO (Maybe ConnectionData, r) -> IO (Maybe ConnectionData, r)
forall a b. a -> b -> b
`seq` (Maybe ConnectionData, r) -> IO (Maybe ConnectionData, r)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionData -> Maybe ConnectionData
forall a. a -> Maybe a
Just ConnectionData
cd', r
r)

-- | 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 (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
      { withConnection :: forall r. (Connection -> m r) -> m r
withConnection = m Connection -> (Connection -> m ()) -> (Connection -> m r) -> m r
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO Connection -> m Connection
forall α. IO α -> m α
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 α. 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)
      }

-- | Pooled source. It uses striped pool from @resource-pool@ package to cache
-- established connections and reuse them.
poolSource
  :: ConnectionSettings
  -> (IO Connection -> (Connection -> IO ()) -> PoolConfig Connection)
  -- ^ A function for creating the 'PoolConfig' with desired parameters.
  --
  -- /Note:/ supplied arguments are for creation and destruction of a database
  -- connection.
  -> IO (ConnectionSource [MonadBase IO, MonadMask])
poolSource :: ConnectionSettings
-> (IO Connection
    -> (Connection -> IO ()) -> PoolConfig Connection)
-> IO (ConnectionSource '[MonadBase IO, MonadMask])
poolSource ConnectionSettings
cs IO Connection -> (Connection -> IO ()) -> PoolConfig Connection
mkPoolConfig = do
  Pool Connection
pool <- PoolConfig Connection -> IO (Pool Connection)
forall a. PoolConfig a -> IO (Pool a)
newPool (PoolConfig Connection -> IO (Pool Connection))
-> PoolConfig Connection -> IO (Pool Connection)
forall a b. (a -> b) -> a -> b
$ IO Connection -> (Connection -> IO ()) -> PoolConfig Connection
mkPoolConfig (ConnectionSettings -> IO Connection
connect ConnectionSettings
cs) Connection -> IO ()
disconnect
  ConnectionSource '[MonadBase IO, MonadMask]
-> IO (ConnectionSource '[MonadBase IO, MonadMask])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (Pool Connection -> ConnectionSourceM m
forall {m :: * -> *}.
(MonadMask m, MonadBase IO m) =>
Pool Connection -> ConnectionSourceM m
sourceM Pool Connection
pool)
  where
    sourceM :: Pool Connection -> ConnectionSourceM m
sourceM Pool Connection
pool =
      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
doWithConnection 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
>=>)
        }

    doWithConnection :: Pool t -> (t -> f b) -> f b
doWithConnection 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 a b c.
HasCallStack =>
f a -> (a -> ExitCase b -> f c) -> (a -> f b) -> f (b, c)
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
          (IO (t, LocalPool t) -> f (t, LocalPool t)
forall α. IO α -> f α
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) -> \case
              ExitCaseSuccess b
_ -> IO () -> f ()
forall α. 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 α. 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)

    clearStats :: Connection -> m Connection
clearStats conn :: Connection
conn@(Connection MVar (Maybe ConnectionData)
mv) = do
      IO () -> m ()
forall α. 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ConnectionData -> IO (Maybe ConnectionData))
-> Maybe ConnectionData -> IO (Maybe ConnectionData)
forall a b. (a -> b) -> a -> b
$ (\ConnectionData
cd -> ConnectionData
cd {cdStats = 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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
Maybe (RawSQL ())
Text
csConnInfo :: ConnectionSettings -> Text
csClientEncoding :: ConnectionSettings -> Maybe Text
csRole :: ConnectionSettings -> Maybe (RawSQL ())
csComposites :: ConnectionSettings -> [Text]
csConnInfo :: Text
csClientEncoding :: Maybe Text
csRole :: Maybe (RawSQL ())
csComposites :: [Text]
..} = ((forall a. IO a -> IO a) -> IO Connection) -> IO Connection
forall b.
HasCallStack =>
((forall a. IO a -> IO a) -> IO b) -> IO b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO Connection) -> IO Connection)
-> ((forall a. IO a -> IO a) -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
  Ptr PGconn
connPtr <- ByteString -> (CString -> IO (Ptr PGconn)) -> IO (Ptr PGconn)
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 IO r -> IO r
forall a. IO a -> IO a
unmask)
  (IO Connection -> IO () -> IO Connection
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` Ptr PGconn -> IO ()
c_PQfinish Ptr PGconn
connPtr) (IO Connection -> IO Connection)
-> (IO Connection -> IO Connection)
-> IO Connection
-> IO Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Connection -> IO Connection
forall a. IO a -> IO a
unmask (IO Connection -> IO Connection) -> IO Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$ do
    ConnStatusType
status <- Ptr PGconn -> IO ConnStatusType
c_PQstatus Ptr PGconn
connPtr
    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
connPtr 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
connPtr)
      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
connPtr String
fname
    Ptr PGconn -> IO ()
c_PQinitTypes Ptr PGconn
connPtr
    Ptr PGconn -> [Text] -> IO ()
registerComposites Ptr PGconn
connPtr [Text]
csComposites
    Connection
conn <- do
      IORef (Set Text)
preparedQueries <- Set Text -> IO (IORef (Set Text))
forall a. a -> IO (IORef a)
newIORef Set Text
forall a. Set a
S.empty
      (MVar (Maybe ConnectionData) -> Connection)
-> IO (MVar (Maybe ConnectionData)) -> IO Connection
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVar (Maybe ConnectionData) -> Connection
Connection (IO (MVar (Maybe ConnectionData)) -> IO Connection)
-> (Maybe ConnectionData -> IO (MVar (Maybe ConnectionData)))
-> Maybe ConnectionData
-> IO Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ConnectionData -> IO (MVar (Maybe ConnectionData))
forall a. a -> IO (MVar a)
newMVar (Maybe ConnectionData -> IO Connection)
-> Maybe ConnectionData -> IO Connection
forall a b. (a -> b) -> a -> b
$
        ConnectionData -> Maybe ConnectionData
forall a. a -> Maybe a
Just
          ConnectionData
            { cdPtr :: Ptr PGconn
cdPtr = Ptr PGconn
connPtr
            , cdBackendPid :: BackendPid
cdBackendPid = BackendPid
noBackendPid
            , cdStats :: ConnectionStats
cdStats = ConnectionStats
initialStats
            , cdPreparedQueries :: IORef (Set Text)
cdPreparedQueries = IORef (Set Text)
preparedQueries
            }
    Maybe (RawSQL ())
-> (RawSQL () -> IO (Int, ForeignPtr PGresult)) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Maybe (RawSQL ())
csRole ((RawSQL () -> IO (Int, ForeignPtr PGresult)) -> IO ())
-> (RawSQL () -> IO (Int, ForeignPtr PGresult)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RawSQL ()
role -> Connection -> RawSQL () -> IO (Int, ForeignPtr PGresult)
forall sql.
(HasCallStack, IsSQL sql) =>
Connection -> sql -> IO (Int, ForeignPtr PGresult)
runQueryIO Connection
conn (RawSQL () -> IO (Int, ForeignPtr PGresult))
-> RawSQL () -> IO (Int, ForeignPtr PGresult)
forall a b. (a -> b) -> a -> b
$ RawSQL ()
"SET ROLE " RawSQL () -> RawSQL () -> RawSQL ()
forall a. Semigroup a => a -> a -> a
<> RawSQL ()
role

    let selectPid :: RawSQL ()
selectPid = RawSQL ()
"SELECT pg_backend_pid()" :: RawSQL ()
    (Int
_, ForeignPtr PGresult
res) <- Connection -> RawSQL () -> IO (Int, ForeignPtr PGresult)
forall sql.
(HasCallStack, IsSQL sql) =>
Connection -> sql -> IO (Int, ForeignPtr PGresult)
runQueryIO Connection
conn RawSQL ()
selectPid
    case QueryResult (Identity Int32) -> [Identity Int32]
forall a. QueryResult a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (QueryResult (Identity Int32) -> [Identity Int32])
-> QueryResult (Identity Int32) -> [Identity Int32]
forall a b. (a -> b) -> a -> b
$ forall t sql.
(FromRow t, IsSQL sql) =>
sql -> BackendPid -> ForeignPtr PGresult -> QueryResult t
mkQueryResult @(Identity Int32) RawSQL ()
selectPid BackendPid
noBackendPid ForeignPtr PGresult
res of
      [Identity Int32
pid] -> Connection
-> String -> (ConnectionData -> IO (ConnectionData, ())) -> IO ()
forall r.
Connection
-> String -> (ConnectionData -> IO (ConnectionData, r)) -> IO r
withConnectionData Connection
conn String
fname ((ConnectionData -> IO (ConnectionData, ())) -> IO ())
-> (ConnectionData -> IO (ConnectionData, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ConnectionData
cd -> do
        (ConnectionData, ()) -> IO (ConnectionData, ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionData
cd {cdBackendPid = BackendPid $ fromIntegral pid}, ())
      [Identity Int32]
pids -> do
        let err :: HPQTypesError
err = String -> HPQTypesError
HPQTypesError (String -> HPQTypesError) -> String -> HPQTypesError
forall a b. (a -> b) -> a -> b
$ String
"unexpected backend pid: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Identity Int32] -> String
forall a. Show a => a -> String
show [Identity Int32]
pids
        RawSQL () -> BackendPid -> SomeException -> IO ()
forall sql a.
(HasCallStack, IsSQL sql) =>
sql -> BackendPid -> SomeException -> IO a
rethrowWithContext RawSQL ()
selectPid BackendPid
noBackendPid (SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ HPQTypesError -> SomeException
forall e. Exception e => e -> SomeException
toException HPQTypesError
err

    Connection -> IO Connection
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn
  where
    noBackendPid :: BackendPid
noBackendPid = Int -> BackendPid
BackendPid Int
0

    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 use synchronous version of connecting to the database using
      -- 'PQconnectdb' instead of 'PQconnectStart' and 'PQconnectPoll', because
      -- the second method doesn't properly support the connect_timeout
      -- parameter from the connection string nor multihost setups.
      --
      -- The disadvantage of this is that a call to 'PQconnectdb' cannot be
      -- interrupted if the Haskell thread running it receives an asynchronous
      -- exception, so to guarantee prompt return in such scenario 'PQconnectdb'
      -- is run in a separate child thread. If the parent receives an exception
      -- while the child still runs, the child is signaled to clean up after
      -- itself and left behind.
      TMVar (Ptr PGconn)
connVar <- IO (TMVar (Ptr PGconn))
forall a. IO (TMVar a)
newEmptyTMVarIO
      TVar Bool
runningVar <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
True
      ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        Ptr PGconn
conn <- CString -> IO (Ptr PGconn)
c_PQconnectdb CString
conninfo
        IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ())
-> (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO ()) -> STM (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
          TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
runningVar STM Bool -> (Bool -> STM (IO ())) -> STM (IO ())
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True -> do
              TMVar (Ptr PGconn) -> Ptr PGconn -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Ptr PGconn)
connVar Ptr PGconn
conn
              IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Bool
False -> IO () -> STM (IO ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ Ptr PGconn -> IO ()
c_PQfinish Ptr PGconn
conn
      Ptr PGconn
conn <-
        STM (Ptr PGconn) -> IO (Ptr PGconn)
forall a. STM a -> IO a
atomically (TMVar (Ptr PGconn) -> STM (Ptr PGconn)
forall a. TMVar a -> STM a
takeTMVar TMVar (Ptr PGconn)
connVar) IO (Ptr PGconn) -> IO () -> IO (Ptr PGconn)
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` do
          IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ())
-> (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO ()) -> STM (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
runningVar Bool
False
            IO () -> (Ptr PGconn -> IO ()) -> Maybe (Ptr PGconn) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Ptr PGconn -> IO ()
c_PQfinish (Maybe (Ptr PGconn) -> IO ())
-> STM (Maybe (Ptr PGconn)) -> STM (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar (Ptr PGconn) -> STM (Maybe (Ptr PGconn))
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar (Ptr PGconn)
connVar
      (IO (Ptr PGconn) -> IO () -> IO (Ptr PGconn)
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` Ptr PGconn -> IO ()
c_PQfinish Ptr PGconn
conn) (IO (Ptr PGconn) -> IO (Ptr PGconn))
-> (IO (Ptr PGconn) -> IO (Ptr PGconn))
-> IO (Ptr PGconn)
-> IO (Ptr PGconn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Ptr PGconn) -> IO (Ptr PGconn)
forall a. IO a -> IO a
unmask (IO (Ptr PGconn) -> IO (Ptr PGconn))
-> IO (Ptr PGconn) -> IO (Ptr PGconn)
forall a b. (a -> b) -> a -> b
$ do
        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
$ do
          String -> IO ()
forall a. String -> IO a
throwError String
"PQconnectdb returned a null pointer"
        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
$ do
          Maybe String
merr <- Ptr PGconn -> IO CString
c_PQerrorMessage Ptr PGconn
conn IO CString -> (CString -> IO (Maybe String)) -> IO (Maybe String)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO (Maybe String)
safePeekCString
          let reason :: String
reason = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) Maybe String
merr
          String -> IO ()
forall a. String -> IO a
throwError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"openConnection failed" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
reason
        Ptr PGconn -> IO (Ptr PGconn)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ptr PGconn
conn
      where
        throwError :: String -> IO a
        throwError :: forall a. String -> IO a
throwError = String -> IO a
forall a. String -> IO a
hpqTypesError (String -> IO a) -> ShowS -> String -> IO a
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]
++)

-- | 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) = 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 -> 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 IO Fd -> (Fd -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 -> 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ConnectionData
forall a. Maybe a
Nothing

----------------------------------------
-- Query running

-- | Low-level function for running an SQL query.
runQueryIO
  :: (HasCallStack, IsSQL sql)
  => Connection
  -> sql
  -> IO (Int, ForeignPtr PGresult)
runQueryIO :: forall sql.
(HasCallStack, IsSQL sql) =>
Connection -> sql -> IO (Int, ForeignPtr PGresult)
runQueryIO Connection
conn sql
sql = do
  String
-> Connection
-> sql
-> (ConnectionData -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
forall sql.
(HasCallStack, IsSQL sql) =>
String
-> Connection
-> sql
-> (ConnectionData -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
runQueryImpl String
"runQueryIO" Connection
conn sql
sql ((ConnectionData -> IO (Int, ForeignPtr PGresult))
 -> IO (Int, ForeignPtr PGresult))
-> (ConnectionData -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
forall a b. (a -> b) -> a -> b
$ \ConnectionData {Ptr PGconn
IORef (Set Text)
BackendPid
ConnectionStats
cdPtr :: ConnectionData -> Ptr PGconn
cdBackendPid :: ConnectionData -> BackendPid
cdStats :: ConnectionData -> ConnectionStats
cdPreparedQueries :: ConnectionData -> IORef (Set Text)
cdPtr :: Ptr PGconn
cdBackendPid :: BackendPid
cdStats :: ConnectionStats
cdPreparedQueries :: IORef (Set Text)
..} -> do
    let allocParam :: ParamAllocator
allocParam = (forall r. (Ptr PGparam -> IO r) -> IO r) -> ParamAllocator
ParamAllocator ((forall r. (Ptr PGparam -> IO r) -> IO r) -> ParamAllocator)
-> (forall r. (Ptr PGparam -> IO r) -> IO r) -> ParamAllocator
forall a b. (a -> b) -> a -> b
$ Ptr PGconn -> (Ptr PGparam -> IO r) -> IO r
forall r. Ptr PGconn -> (Ptr PGparam -> IO r) -> IO r
withPGparam Ptr PGconn
cdPtr
    sql
-> ParamAllocator
-> (Ptr PGparam -> CString -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
forall r.
sql -> ParamAllocator -> (Ptr PGparam -> CString -> IO r) -> IO r
forall sql r.
IsSQL sql =>
sql -> ParamAllocator -> (Ptr PGparam -> CString -> IO r) -> IO r
withSQL sql
sql ParamAllocator
allocParam ((Ptr PGparam -> CString -> IO (Int, ForeignPtr PGresult))
 -> IO (Int, ForeignPtr PGresult))
-> (Ptr PGparam -> CString -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
forall a b. (a -> b) -> a -> b
$ \Ptr PGparam
param CString
query ->
      (,)
        (Int -> ForeignPtr PGresult -> (Int, ForeignPtr PGresult))
-> IO Int -> IO (ForeignPtr PGresult -> (Int, ForeignPtr PGresult))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PGparam -> IO CInt
c_PQparamCount Ptr PGparam
param)
        IO (ForeignPtr PGresult -> (Int, ForeignPtr PGresult))
-> IO (ForeignPtr PGresult) -> IO (Int, ForeignPtr PGresult)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr PGconn
-> Ptr PGerror
-> Ptr PGparam
-> CString
-> ResultFormat
-> IO (ForeignPtr PGresult)
c_PQparamExec Ptr PGconn
cdPtr Ptr PGerror
forall a. Ptr a
nullPtr Ptr PGparam
param CString
query ResultFormat
c_RESULT_BINARY

-- | Name of a prepared query.
newtype QueryName = QueryName T.Text
  deriving (QueryName -> QueryName -> Bool
(QueryName -> QueryName -> Bool)
-> (QueryName -> QueryName -> Bool) -> Eq QueryName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QueryName -> QueryName -> Bool
== :: QueryName -> QueryName -> Bool
$c/= :: QueryName -> QueryName -> Bool
/= :: QueryName -> QueryName -> Bool
Eq, Eq QueryName
Eq QueryName =>
(QueryName -> QueryName -> Ordering)
-> (QueryName -> QueryName -> Bool)
-> (QueryName -> QueryName -> Bool)
-> (QueryName -> QueryName -> Bool)
-> (QueryName -> QueryName -> Bool)
-> (QueryName -> QueryName -> QueryName)
-> (QueryName -> QueryName -> QueryName)
-> Ord QueryName
QueryName -> QueryName -> Bool
QueryName -> QueryName -> Ordering
QueryName -> QueryName -> QueryName
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
$ccompare :: QueryName -> QueryName -> Ordering
compare :: QueryName -> QueryName -> Ordering
$c< :: QueryName -> QueryName -> Bool
< :: QueryName -> QueryName -> Bool
$c<= :: QueryName -> QueryName -> Bool
<= :: QueryName -> QueryName -> Bool
$c> :: QueryName -> QueryName -> Bool
> :: QueryName -> QueryName -> Bool
$c>= :: QueryName -> QueryName -> Bool
>= :: QueryName -> QueryName -> Bool
$cmax :: QueryName -> QueryName -> QueryName
max :: QueryName -> QueryName -> QueryName
$cmin :: QueryName -> QueryName -> QueryName
min :: QueryName -> QueryName -> QueryName
Ord, Int -> QueryName -> ShowS
[QueryName] -> ShowS
QueryName -> String
(Int -> QueryName -> ShowS)
-> (QueryName -> String)
-> ([QueryName] -> ShowS)
-> Show QueryName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueryName -> ShowS
showsPrec :: Int -> QueryName -> ShowS
$cshow :: QueryName -> String
show :: QueryName -> String
$cshowList :: [QueryName] -> ShowS
showList :: [QueryName] -> ShowS
Show, String -> QueryName
(String -> QueryName) -> IsString QueryName
forall a. (String -> a) -> IsString a
$cfromString :: String -> QueryName
fromString :: String -> QueryName
IsString)

-- | Low-level function for running a prepared SQL query.
runPreparedQueryIO
  :: (HasCallStack, IsSQL sql)
  => Connection
  -> QueryName
  -> sql
  -> IO (Int, ForeignPtr PGresult)
runPreparedQueryIO :: forall sql.
(HasCallStack, IsSQL sql) =>
Connection -> QueryName -> sql -> IO (Int, ForeignPtr PGresult)
runPreparedQueryIO Connection
conn (QueryName Text
queryName) sql
sql = do
  String
-> Connection
-> sql
-> (ConnectionData -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
forall sql.
(HasCallStack, IsSQL sql) =>
String
-> Connection
-> sql
-> (ConnectionData -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
runQueryImpl String
"runPreparedQueryIO" Connection
conn sql
sql ((ConnectionData -> IO (Int, ForeignPtr PGresult))
 -> IO (Int, ForeignPtr PGresult))
-> (ConnectionData -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
forall a b. (a -> b) -> a -> b
$ \ConnectionData {Ptr PGconn
IORef (Set Text)
BackendPid
ConnectionStats
cdPtr :: ConnectionData -> Ptr PGconn
cdBackendPid :: ConnectionData -> BackendPid
cdStats :: ConnectionData -> ConnectionStats
cdPreparedQueries :: ConnectionData -> IORef (Set Text)
cdPtr :: Ptr PGconn
cdBackendPid :: BackendPid
cdStats :: ConnectionStats
cdPreparedQueries :: IORef (Set Text)
..} -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null Text
queryName) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      DBException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO
        DBException
          { dbeQueryContext :: sql
dbeQueryContext = sql
sql
          , dbeBackendPid :: BackendPid
dbeBackendPid = BackendPid
cdBackendPid
          , dbeError :: HPQTypesError
dbeError = String -> HPQTypesError
HPQTypesError String
"runPreparedQueryIO: unnamed prepared query is not supported"
          , dbeCallStack :: CallStack
dbeCallStack = CallStack
HasCallStack => CallStack
callStack
          }
    let allocParam :: ParamAllocator
allocParam = (forall r. (Ptr PGparam -> IO r) -> IO r) -> ParamAllocator
ParamAllocator ((forall r. (Ptr PGparam -> IO r) -> IO r) -> ParamAllocator)
-> (forall r. (Ptr PGparam -> IO r) -> IO r) -> ParamAllocator
forall a b. (a -> b) -> a -> b
$ Ptr PGconn -> (Ptr PGparam -> IO r) -> IO r
forall r. Ptr PGconn -> (Ptr PGparam -> IO r) -> IO r
withPGparam Ptr PGconn
cdPtr
    sql
-> ParamAllocator
-> (Ptr PGparam -> CString -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
forall r.
sql -> ParamAllocator -> (Ptr PGparam -> CString -> IO r) -> IO r
forall sql r.
IsSQL sql =>
sql -> ParamAllocator -> (Ptr PGparam -> CString -> IO r) -> IO r
withSQL sql
sql ParamAllocator
allocParam ((Ptr PGparam -> CString -> IO (Int, ForeignPtr PGresult))
 -> IO (Int, ForeignPtr PGresult))
-> (Ptr PGparam -> CString -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
forall a b. (a -> b) -> a -> b
$ \Ptr PGparam
param CString
query -> do
      Set Text
preparedQueries <- IORef (Set Text) -> IO (Set Text)
forall a. IORef a -> IO a
readIORef IORef (Set Text)
cdPreparedQueries
      ByteString
-> (CString -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString (Text -> ByteString
T.encodeUtf8 Text
queryName) ((CString -> IO (Int, ForeignPtr PGresult))
 -> IO (Int, ForeignPtr PGresult))
-> (CString -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
forall a b. (a -> b) -> a -> b
$ \CString
cname -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
queryName Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Text
preparedQueries) (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall a. IO a -> IO a
E.mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          -- Mask asynchronous exceptions, because if preparation of the query
          -- succeeds, we need to reflect that fact in cdPreparedQueries since
          -- you can't prepare a query with the same name more than once.
          ForeignPtr PGresult
res <- Ptr PGconn
-> Ptr PGerror
-> Ptr PGparam
-> CString
-> CString
-> IO (ForeignPtr PGresult)
c_PQparamPrepare Ptr PGconn
cdPtr Ptr PGerror
forall a. Ptr a
nullPtr Ptr PGparam
param CString
cname CString
query
          IO (Either Int Int) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either Int Int) -> IO ())
-> ((Ptr PGresult -> IO (Either Int Int)) -> IO (Either Int Int))
-> (Ptr PGresult -> IO (Either Int Int))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr PGresult
-> (Ptr PGresult -> IO (Either Int Int)) -> IO (Either Int Int)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr PGresult
res ((Ptr PGresult -> IO (Either Int Int)) -> IO ())
-> (Ptr PGresult -> IO (Either Int Int)) -> IO ()
forall a b. (a -> b) -> a -> b
$ sql
-> BackendPid -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
forall sql.
(HasCallStack, IsSQL sql) =>
sql
-> BackendPid -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
verifyResult sql
sql BackendPid
cdBackendPid Ptr PGconn
cdPtr
          IORef (Set Text) -> (Set Text -> Set Text) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Set Text)
cdPreparedQueries ((Set Text -> Set Text) -> IO ())
-> (Set Text -> Set Text) -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
S.insert Text
queryName
        (,)
          (Int -> ForeignPtr PGresult -> (Int, ForeignPtr PGresult))
-> IO Int -> IO (ForeignPtr PGresult -> (Int, ForeignPtr PGresult))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PGparam -> IO CInt
c_PQparamCount Ptr PGparam
param)
          IO (ForeignPtr PGresult -> (Int, ForeignPtr PGresult))
-> IO (ForeignPtr PGresult) -> IO (Int, ForeignPtr PGresult)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr PGconn
-> Ptr PGerror
-> Ptr PGparam
-> CString
-> ResultFormat
-> IO (ForeignPtr PGresult)
c_PQparamExecPrepared Ptr PGconn
cdPtr Ptr PGerror
forall a. Ptr a
nullPtr Ptr PGparam
param CString
cname ResultFormat
c_RESULT_BINARY

-- | Shared implementation of 'runQueryIO' and 'runPreparedQueryIO'.
runQueryImpl
  :: (HasCallStack, IsSQL sql)
  => String
  -> Connection
  -> sql
  -> (ConnectionData -> IO (Int, ForeignPtr PGresult))
  -> IO (Int, ForeignPtr PGresult)
runQueryImpl :: forall sql.
(HasCallStack, IsSQL sql) =>
String
-> Connection
-> sql
-> (ConnectionData -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
runQueryImpl String
fname Connection
conn sql
sql ConnectionData -> IO (Int, ForeignPtr PGresult)
execSql = do
  (ConnectionData -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> IO (Int, ForeignPtr PGresult)
withConnDo ((ConnectionData
  -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
 -> IO (Int, ForeignPtr PGresult))
-> (ConnectionData
    -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> IO (Int, ForeignPtr PGresult)
forall a b. (a -> b) -> a -> b
$ \cd :: ConnectionData
cd@ConnectionData {Ptr PGconn
IORef (Set Text)
BackendPid
ConnectionStats
cdPtr :: ConnectionData -> Ptr PGconn
cdBackendPid :: ConnectionData -> BackendPid
cdStats :: ConnectionData -> ConnectionStats
cdPreparedQueries :: ConnectionData -> IORef (Set Text)
cdPtr :: Ptr PGconn
cdBackendPid :: BackendPid
cdStats :: ConnectionStats
cdPreparedQueries :: IORef (Set Text)
..} -> ((forall a. IO a -> IO a)
 -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (((forall a. IO a -> IO a)
  -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
 -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> ((forall a. IO a -> IO a)
    -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    -- While the query runs, the current thread will not be able to receive
    -- asynchronous exceptions. This prevents clients of the library from
    -- interrupting execution of the query. To remedy that we spawn a separate
    -- thread for the query execution and while we wait for its completion, we
    -- are able to receive asynchronous exceptions (assuming that threaded GHC
    -- runtime system is used) and react appropriately.
    Async (ConnectionData, (Int, ForeignPtr PGresult))
queryRunner <- IO (ConnectionData, (Int, ForeignPtr PGresult))
-> IO (Async (ConnectionData, (Int, ForeignPtr PGresult)))
forall a. IO a -> IO (Async a)
async (IO (ConnectionData, (Int, ForeignPtr PGresult))
 -> IO (Async (ConnectionData, (Int, ForeignPtr PGresult))))
-> (IO (ConnectionData, (Int, ForeignPtr PGresult))
    -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
-> IO (Async (ConnectionData, (Int, ForeignPtr PGresult)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (ConnectionData, (Int, ForeignPtr PGresult))
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
forall a. IO a -> IO a
restore (IO (ConnectionData, (Int, ForeignPtr PGresult))
 -> IO (Async (ConnectionData, (Int, ForeignPtr PGresult))))
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
-> IO (Async (ConnectionData, (Int, ForeignPtr PGresult)))
forall a b. (a -> b) -> a -> b
$ do
      (Int
paramCount, ForeignPtr PGresult
res) <- ConnectionData -> IO (Int, ForeignPtr PGresult)
execSql ConnectionData
cd
      Either Int Int
affected <- ForeignPtr PGresult
-> (Ptr PGresult -> IO (Either Int Int)) -> IO (Either Int Int)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr PGresult
res ((Ptr PGresult -> IO (Either Int Int)) -> IO (Either Int Int))
-> (Ptr PGresult -> IO (Either Int Int)) -> IO (Either Int Int)
forall a b. (a -> b) -> a -> b
$ sql
-> BackendPid -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
forall sql.
(HasCallStack, IsSQL sql) =>
sql
-> BackendPid -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
verifyResult sql
sql BackendPid
cdBackendPid Ptr PGconn
cdPtr
      ConnectionStats
stats' <- case Either Int Int
affected of
        Left Int
_ ->
          ConnectionStats -> IO ConnectionStats
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ConnectionStats
cdStats
              { statsQueries = statsQueries cdStats + 1
              , statsParams = statsParams cdStats + paramCount
              }
        Right Int
rows -> do
          Int
columns <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ForeignPtr PGresult -> (Ptr PGresult -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr PGresult
res Ptr PGresult -> IO CInt
c_PQnfields
          ConnectionStats -> IO ConnectionStats
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ConnectionStats
              { statsQueries :: Int
statsQueries = ConnectionStats -> Int
statsQueries ConnectionStats
cdStats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              , statsRows :: Int
statsRows = ConnectionStats -> Int
statsRows ConnectionStats
cdStats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rows
              , statsValues :: Int
statsValues = ConnectionStats -> Int
statsValues ConnectionStats
cdStats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
rows Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
columns)
              , statsParams :: Int
statsParams = ConnectionStats -> Int
statsParams ConnectionStats
cdStats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
paramCount
              }
      (ConnectionData, (Int, ForeignPtr PGresult))
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionData
cd {cdStats = stats'}, ((Int -> Int) -> (Int -> Int) -> Either Int Int -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Int -> Int
forall a. a -> a
id Int -> Int
forall a. a -> a
id Either Int Int
affected, ForeignPtr PGresult
res))
    -- If we receive an exception while waiting for the execution to complete,
    -- we need to send a request to PostgreSQL for query cancellation and wait
    -- for the query runner thread to terminate. It is paramount we make the
    -- exception handler uninterruptible as we can't exit from the main block
    -- until the query runner thread has terminated.
    IO (ConnectionData, (Int, ForeignPtr PGresult))
-> IO () -> IO (ConnectionData, (Int, ForeignPtr PGresult))
forall a b. IO a -> IO b -> IO a
E.onException (IO (ConnectionData, (Int, ForeignPtr PGresult))
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
forall a. IO a -> IO a
restore (IO (ConnectionData, (Int, ForeignPtr PGresult))
 -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
forall a b. (a -> b) -> a -> b
$ Async (ConnectionData, (Int, ForeignPtr PGresult))
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
forall a. Async a -> IO a
wait Async (ConnectionData, (Int, ForeignPtr PGresult))
queryRunner) (IO () -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> (IO () -> IO ())
-> IO ()
-> IO (ConnectionData, (Int, ForeignPtr PGresult))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall a. IO a -> IO a
E.uninterruptibleMask_ (IO () -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> IO () -> IO (ConnectionData, (Int, ForeignPtr PGresult))
forall a b. (a -> b) -> a -> b
$ do
      Ptr PGconn -> IO (Maybe String)
c_PQcancel Ptr PGconn
cdPtr IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- If query cancellation request was successfully processed, there is
        -- nothing else to do apart from waiting for the runner to terminate.
        Maybe String
Nothing -> Async (ConnectionData, (Int, ForeignPtr PGresult)) -> IO ()
forall a. Async a -> IO ()
cancel Async (ConnectionData, (Int, ForeignPtr PGresult))
queryRunner
        -- Otherwise we check what happened with the runner. If it already
        -- finished we're fine, just ignore the result. If it didn't, something
        -- weird is going on. Maybe the cancellation request went through when
        -- the thread wasn't making a request to the server? In any case, try to
        -- cancel again and wait for the thread to terminate.
        Just String
_ ->
          Async (ConnectionData, (Int, ForeignPtr PGresult))
-> IO
     (Maybe
        (Either
           SomeException (ConnectionData, (Int, ForeignPtr PGresult))))
forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async (ConnectionData, (Int, ForeignPtr PGresult))
queryRunner IO
  (Maybe
     (Either
        SomeException (ConnectionData, (Int, ForeignPtr PGresult))))
-> (Maybe
      (Either SomeException (ConnectionData, (Int, ForeignPtr PGresult)))
    -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Either SomeException (ConnectionData, (Int, ForeignPtr PGresult))
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Maybe
  (Either SomeException (ConnectionData, (Int, ForeignPtr PGresult)))
Nothing -> do
              IO (Maybe String) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe String) -> IO ()) -> IO (Maybe String) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr PGconn -> IO (Maybe String)
c_PQcancel Ptr PGconn
cdPtr
              Async (ConnectionData, (Int, ForeignPtr PGresult)) -> IO ()
forall a. Async a -> IO ()
cancel Async (ConnectionData, (Int, ForeignPtr PGresult))
queryRunner
  where
    withConnDo :: (ConnectionData -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> IO (Int, ForeignPtr PGresult)
withConnDo = Connection
-> String
-> (ConnectionData
    -> IO (ConnectionData, (Int, ForeignPtr PGresult)))
-> IO (Int, ForeignPtr PGresult)
forall r.
Connection
-> String -> (ConnectionData -> IO (ConnectionData, r)) -> IO r
withConnectionData Connection
conn String
fname

verifyResult
  :: (HasCallStack, IsSQL sql)
  => sql
  -> BackendPid
  -> Ptr PGconn
  -> Ptr PGresult
  -> IO (Either Int Int)
verifyResult :: forall sql.
(HasCallStack, IsSQL sql) =>
sql
-> BackendPid -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
verifyResult sql
sql BackendPid
pid Ptr PGconn
conn Ptr PGresult
res = do
  -- works even if res is NULL
  ExecStatusType
rst <- Ptr PGresult -> IO ExecStatusType
c_PQresultStatus Ptr PGresult
res
  case ExecStatusType
rst of
    ExecStatusType
_ | ExecStatusType
rst ExecStatusType -> ExecStatusType -> Bool
forall a. Eq a => a -> a -> Bool
== ExecStatusType
c_PGRES_COMMAND_OK -> do
      ByteString
sn <- Ptr PGresult -> IO CString
c_PQcmdTuples Ptr PGresult
res IO CString -> (CString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO ByteString
BS.packCString
      case ByteString -> Maybe (Int, ByteString)
BS.readInt ByteString
sn of
        Maybe (Int, ByteString)
Nothing
          | ByteString -> Bool
BS.null ByteString
sn -> Either Int Int -> IO (Either Int Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Int Int -> IO (Either Int Int))
-> (Int -> Either Int Int) -> Int -> IO (Either Int Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Either Int Int
forall a b. a -> Either a b
Left (Int -> IO (Either Int Int)) -> Int -> IO (Either Int Int)
forall a b. (a -> b) -> a -> b
$ Int
0
          | Bool
otherwise -> ByteString -> IO (Either Int Int)
throwParseError ByteString
sn
        Just (Int
n, ByteString
rest)
          | ByteString
rest ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
BS.empty -> ByteString -> IO (Either Int Int)
throwParseError ByteString
sn
          | Bool
otherwise -> Either Int Int -> IO (Either Int Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Int Int -> IO (Either Int Int))
-> (Int -> Either Int Int) -> Int -> IO (Either Int Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Either Int Int
forall a b. a -> Either a b
Left (Int -> IO (Either Int Int)) -> Int -> IO (Either Int Int)
forall a b. (a -> b) -> a -> b
$ Int
n
    ExecStatusType
_ | ExecStatusType
rst ExecStatusType -> ExecStatusType -> Bool
forall a. Eq a => a -> a -> Bool
== ExecStatusType
c_PGRES_TUPLES_OK -> Int -> Either Int Int
forall a b. b -> Either a b
Right (Int -> Either Int Int) -> (CInt -> Int) -> CInt -> Either Int Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Either Int Int) -> IO CInt -> IO (Either Int Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PGresult -> IO CInt
c_PQntuples Ptr PGresult
res
    ExecStatusType
_ | ExecStatusType
rst ExecStatusType -> ExecStatusType -> Bool
forall a. Eq a => a -> a -> Bool
== ExecStatusType
c_PGRES_FATAL_ERROR -> IO (Either Int Int)
throwSQLError
    ExecStatusType
_ | ExecStatusType
rst ExecStatusType -> ExecStatusType -> Bool
forall a. Eq a => a -> a -> Bool
== ExecStatusType
c_PGRES_BAD_RESPONSE -> IO (Either Int Int)
throwSQLError
    ExecStatusType
_ | Bool
otherwise -> Either Int Int -> IO (Either Int Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Int Int -> IO (Either Int Int))
-> (Int -> Either Int Int) -> Int -> IO (Either Int Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Either Int Int
forall a b. a -> Either a b
Left (Int -> IO (Either Int Int)) -> Int -> IO (Either Int Int)
forall a b. (a -> b) -> a -> b
$ Int
0
  where
    throwSQLError :: IO (Either Int Int)
throwSQLError =
      sql -> BackendPid -> SomeException -> IO (Either Int Int)
forall sql a.
(HasCallStack, IsSQL sql) =>
sql -> BackendPid -> SomeException -> IO a
rethrowWithContext sql
sql BackendPid
pid
        (SomeException -> IO (Either Int Int))
-> IO SomeException -> IO (Either Int Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if Ptr PGresult
res Ptr PGresult -> Ptr PGresult -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr PGresult
forall a. Ptr a
nullPtr
          then
            QueryError -> SomeException
forall e. Exception e => e -> SomeException
E.toException (QueryError -> SomeException)
-> (String -> QueryError) -> String -> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QueryError
QueryError (String -> SomeException) -> IO String -> IO SomeException
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CString -> IO String
safePeekCString' (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr PGconn -> IO CString
c_PQerrorMessage Ptr PGconn
conn)
          else
            DetailedQueryError -> SomeException
forall e. Exception e => e -> SomeException
E.toException
              (DetailedQueryError -> SomeException)
-> IO DetailedQueryError -> IO SomeException
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( String
-> ErrorCode
-> String
-> Maybe String
-> Maybe String
-> Maybe Int
-> Maybe Int
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe Int
-> Maybe String
-> DetailedQueryError
DetailedQueryError
                      (String
 -> ErrorCode
 -> String
 -> Maybe String
 -> Maybe String
 -> Maybe Int
 -> Maybe Int
 -> Maybe String
 -> Maybe String
 -> Maybe String
 -> Maybe Int
 -> Maybe String
 -> DetailedQueryError)
-> IO String
-> IO
     (ErrorCode
      -> String
      -> Maybe String
      -> Maybe String
      -> Maybe Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> Maybe Int
      -> Maybe String
      -> DetailedQueryError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO String
field ErrorField
c_PG_DIAG_SEVERITY
                      IO
  (ErrorCode
   -> String
   -> Maybe String
   -> Maybe String
   -> Maybe Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe Int
   -> Maybe String
   -> DetailedQueryError)
-> IO ErrorCode
-> IO
     (String
      -> Maybe String
      -> Maybe String
      -> Maybe Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> Maybe Int
      -> Maybe String
      -> DetailedQueryError)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> ErrorCode
stringToErrorCode (String -> ErrorCode) -> IO String -> IO ErrorCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO String
field ErrorField
c_PG_DIAG_SQLSTATE)
                      IO
  (String
   -> Maybe String
   -> Maybe String
   -> Maybe Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe Int
   -> Maybe String
   -> DetailedQueryError)
-> IO String
-> IO
     (Maybe String
      -> Maybe String
      -> Maybe Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> Maybe Int
      -> Maybe String
      -> DetailedQueryError)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO String
field ErrorField
c_PG_DIAG_MESSAGE_PRIMARY
                      IO
  (Maybe String
   -> Maybe String
   -> Maybe Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe Int
   -> Maybe String
   -> DetailedQueryError)
-> IO (Maybe String)
-> IO
     (Maybe String
      -> Maybe Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> Maybe Int
      -> Maybe String
      -> DetailedQueryError)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_MESSAGE_DETAIL
                      IO
  (Maybe String
   -> Maybe Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe Int
   -> Maybe String
   -> DetailedQueryError)
-> IO (Maybe String)
-> IO
     (Maybe Int
      -> Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> Maybe Int
      -> Maybe String
      -> DetailedQueryError)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_MESSAGE_HINT
                      IO
  (Maybe Int
   -> Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe Int
   -> Maybe String
   -> DetailedQueryError)
-> IO (Maybe Int)
-> IO
     (Maybe Int
      -> Maybe String
      -> Maybe String
      -> Maybe String
      -> Maybe Int
      -> Maybe String
      -> DetailedQueryError)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((String -> Maybe Int
forall a. Read a => String -> Maybe a
mread (String -> Maybe Int) -> Maybe String -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe String -> Maybe Int) -> IO (Maybe String) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_STATEMENT_POSITION)
                      IO
  (Maybe Int
   -> Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe Int
   -> Maybe String
   -> DetailedQueryError)
-> IO (Maybe Int)
-> IO
     (Maybe String
      -> Maybe String
      -> Maybe String
      -> Maybe Int
      -> Maybe String
      -> DetailedQueryError)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((String -> Maybe Int
forall a. Read a => String -> Maybe a
mread (String -> Maybe Int) -> Maybe String -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe String -> Maybe Int) -> IO (Maybe String) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_INTERNAL_POSITION)
                      IO
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe Int
   -> Maybe String
   -> DetailedQueryError)
-> IO (Maybe String)
-> IO
     (Maybe String
      -> Maybe String -> Maybe Int -> Maybe String -> DetailedQueryError)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_INTERNAL_QUERY
                      IO
  (Maybe String
   -> Maybe String -> Maybe Int -> Maybe String -> DetailedQueryError)
-> IO (Maybe String)
-> IO
     (Maybe String -> Maybe Int -> Maybe String -> DetailedQueryError)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_CONTEXT
                      IO
  (Maybe String -> Maybe Int -> Maybe String -> DetailedQueryError)
-> IO (Maybe String)
-> IO (Maybe Int -> Maybe String -> DetailedQueryError)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_SOURCE_FILE
                      IO (Maybe Int -> Maybe String -> DetailedQueryError)
-> IO (Maybe Int) -> IO (Maybe String -> DetailedQueryError)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((String -> Maybe Int
forall a. Read a => String -> Maybe a
mread (String -> Maybe Int) -> Maybe String -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe String -> Maybe Int) -> IO (Maybe String) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_SOURCE_LINE)
                      IO (Maybe String -> DetailedQueryError)
-> IO (Maybe String) -> IO DetailedQueryError
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_SOURCE_FUNCTION
                  )
      where
        field :: ErrorField -> IO String
field ErrorField
f = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO (Maybe String)
mfield ErrorField
f
        mfield :: ErrorField -> IO (Maybe String)
mfield ErrorField
f = CString -> IO (Maybe String)
safePeekCString (CString -> IO (Maybe String)) -> IO CString -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr PGresult -> ErrorField -> IO CString
c_PQresultErrorField Ptr PGresult
res ErrorField
f

    throwParseError :: ByteString -> IO (Either Int Int)
throwParseError ByteString
sn =
      DBException -> IO (Either Int Int)
forall e a. Exception e => e -> IO a
E.throwIO
        DBException
          { dbeQueryContext :: sql
dbeQueryContext = sql
sql
          , dbeBackendPid :: BackendPid
dbeBackendPid = BackendPid
pid
          , dbeError :: HPQTypesError
dbeError = String -> HPQTypesError
HPQTypesError (String
"verifyResult: string returned by PQcmdTuples is not a valid number: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
sn)
          , dbeCallStack :: CallStack
dbeCallStack = CallStack
HasCallStack => CallStack
callStack
          }