module Database.PostgreSQL.PQTypes.Internal.Connection
  ( -- * Connection
    Connection(..)
  , 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.Monad
import Control.Monad.Base
import Control.Monad.Catch
import Data.Bifunctor
import Data.Function
import Data.IORef
import Data.Kind
import Data.Pool
import Data.String
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Ptr
import GHC.Conc (closeFdWith)
import qualified Control.Exception as E
import qualified Data.ByteString.Char8 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.Error.Code
import Database.PostgreSQL.PQTypes.Internal.Exception
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
  { -- | 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 custom role to set with "SET ROLE".
  , ConnectionSettings -> Maybe (RawSQL ())
csRole           :: !(Maybe (RawSQL ()))
    -- | 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"
  , csRole :: Maybe (RawSQL ())
csRole           = forall a. Maybe a
Nothing
  , 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 (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
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
  -> (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 <- forall a. PoolConfig a -> IO (Pool a)
newPool forall a b. (a -> b) -> a -> b
$ IO Connection -> (Connection -> IO ()) -> PoolConfig Connection
mkPoolConfig (ConnectionSettings -> IO Connection
connect ConnectionSettings
cs) Connection -> IO ()
disconnect
  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
Maybe (RawSQL ())
Text
csComposites :: [Text]
csRole :: Maybe (RawSQL ())
csClientEncoding :: Maybe Text
csConnInfo :: Text
csComposites :: ConnectionSettings -> [Text]
csRole :: ConnectionSettings -> Maybe (RawSQL ())
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
connPtr <- 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
connPtr) 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
connPtr
    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
connPtr 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
connPtr)
      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
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 <- 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
connPtr
        , cdStats :: ConnectionStats
cdStats = ConnectionStats
initialStats
        , cdPreparedQueries :: IORef (Set Text)
cdPreparedQueries = IORef (Set Text)
preparedQueries
        }
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Maybe (RawSQL ())
csRole forall a b. (a -> b) -> a -> b
$ \RawSQL ()
role -> forall sql.
IsSQL sql =>
Connection -> sql -> IO (Int, ForeignPtr PGresult)
runQueryIO Connection
conn forall a b. (a -> b) -> a -> b
$ RawSQL ()
"SET ROLE " forall a. Semigroup a => a -> a -> a
<> RawSQL ()
role
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Connection
conn
  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

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

-- | Low-level function for running an SQL query.
runQueryIO
  :: IsSQL sql
  => Connection
  -> sql
  -> IO (Int, ForeignPtr PGresult)
runQueryIO :: forall sql.
IsSQL sql =>
Connection -> sql -> IO (Int, ForeignPtr PGresult)
runQueryIO Connection
conn sql
sql = do
  forall sql.
IsSQL sql =>
String
-> Connection
-> sql
-> (ConnectionData -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
runQueryImpl String
"runQueryIO" Connection
conn sql
sql forall a b. (a -> b) -> a -> b
$ \ConnectionData{Ptr PGconn
IORef (Set Text)
ConnectionStats
cdPreparedQueries :: IORef (Set Text)
cdStats :: ConnectionStats
cdPtr :: Ptr PGconn
cdPreparedQueries :: ConnectionData -> IORef (Set Text)
cdStats :: ConnectionData -> ConnectionStats
cdPtr :: ConnectionData -> Ptr PGconn
..} -> do
    let allocParam :: ParamAllocator
allocParam = (forall r. (Ptr PGparam -> IO r) -> IO r) -> ParamAllocator
ParamAllocator forall a b. (a -> b) -> a -> b
$ forall r. Ptr PGconn -> (Ptr PGparam -> IO r) -> IO r
withPGparam Ptr PGconn
cdPtr
    forall sql r.
IsSQL sql =>
sql -> ParamAllocator -> (Ptr PGparam -> CString -> IO r) -> IO r
withSQL sql
sql ParamAllocator
allocParam forall a b. (a -> b) -> a -> b
$ \Ptr PGparam
param CString
query -> (,)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PGparam -> IO CInt
c_PQparamCount Ptr PGparam
param)
      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 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QueryName -> QueryName -> Bool
$c/= :: QueryName -> QueryName -> Bool
== :: QueryName -> QueryName -> Bool
$c== :: QueryName -> QueryName -> Bool
Eq, Eq 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
min :: QueryName -> QueryName -> QueryName
$cmin :: QueryName -> QueryName -> QueryName
max :: QueryName -> QueryName -> QueryName
$cmax :: QueryName -> QueryName -> QueryName
>= :: QueryName -> QueryName -> Bool
$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
compare :: QueryName -> QueryName -> Ordering
$ccompare :: QueryName -> QueryName -> Ordering
Ord, Int -> QueryName -> ShowS
[QueryName] -> ShowS
QueryName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QueryName] -> ShowS
$cshowList :: [QueryName] -> ShowS
show :: QueryName -> String
$cshow :: QueryName -> String
showsPrec :: Int -> QueryName -> ShowS
$cshowsPrec :: Int -> QueryName -> ShowS
Show, String -> QueryName
forall a. (String -> a) -> IsString a
fromString :: String -> QueryName
$cfromString :: String -> QueryName
IsString)

-- | Low-level function for running a prepared SQL query.
runPreparedQueryIO
  :: IsSQL sql
  => Connection
  -> QueryName
  -> sql
  -> IO (Int, ForeignPtr PGresult)
runPreparedQueryIO :: forall sql.
IsSQL sql =>
Connection -> QueryName -> sql -> IO (Int, ForeignPtr PGresult)
runPreparedQueryIO Connection
conn (QueryName Text
queryName) sql
sql = do
  forall sql.
IsSQL sql =>
String
-> Connection
-> sql
-> (ConnectionData -> IO (Int, ForeignPtr PGresult))
-> IO (Int, ForeignPtr PGresult)
runQueryImpl String
"runPreparedQueryIO" Connection
conn sql
sql forall a b. (a -> b) -> a -> b
$ \ConnectionData{Ptr PGconn
IORef (Set Text)
ConnectionStats
cdPreparedQueries :: IORef (Set Text)
cdStats :: ConnectionStats
cdPtr :: Ptr PGconn
cdPreparedQueries :: ConnectionData -> IORef (Set Text)
cdStats :: ConnectionData -> ConnectionStats
cdPtr :: ConnectionData -> Ptr PGconn
..} -> do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null Text
queryName) forall a b. (a -> b) -> a -> b
$ do
      forall e a. Exception e => e -> IO a
E.throwIO DBException
        { dbeQueryContext :: sql
dbeQueryContext = sql
sql
        , dbeError :: HPQTypesError
dbeError = String -> HPQTypesError
HPQTypesError String
"runPreparedQueryIO: unnamed prepared query is not supported"
        }
    let allocParam :: ParamAllocator
allocParam = (forall r. (Ptr PGparam -> IO r) -> IO r) -> ParamAllocator
ParamAllocator forall a b. (a -> b) -> a -> b
$ forall r. Ptr PGconn -> (Ptr PGparam -> IO r) -> IO r
withPGparam Ptr PGconn
cdPtr
    forall sql r.
IsSQL sql =>
sql -> ParamAllocator -> (Ptr PGparam -> CString -> IO r) -> IO r
withSQL sql
sql ParamAllocator
allocParam forall a b. (a -> b) -> a -> b
$ \Ptr PGparam
param CString
query -> do
      Set Text
preparedQueries <- forall a. IORef a -> IO a
readIORef IORef (Set Text)
cdPreparedQueries
      forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString (Text -> ByteString
T.encodeUtf8 Text
queryName) forall a b. (a -> b) -> a -> b
$ \CString
cname -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
queryName forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Text
preparedQueries) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO a
E.mask_ 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 forall a. Ptr a
nullPtr Ptr PGparam
param CString
cname CString
query
          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr PGresult
res forall a b. (a -> b) -> a -> b
$ forall sql.
IsSQL sql =>
sql -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
verifyResult sql
sql Ptr PGconn
cdPtr
          forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Set Text)
cdPreparedQueries forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
S.insert Text
queryName
        (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PGparam -> IO CInt
c_PQparamCount Ptr PGparam
param)
            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 forall a. Ptr a
nullPtr Ptr PGparam
param CString
cname ResultFormat
c_RESULT_BINARY

-- | Shared implementation of 'runQueryIO' and 'runPreparedQueryIO'.
runQueryImpl
  :: IsSQL sql
  => String
  -> Connection
  -> sql
  -> (ConnectionData -> IO (Int, ForeignPtr PGresult))
  -> IO (Int, ForeignPtr PGresult)
runQueryImpl :: forall sql.
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 forall a b. (a -> b) -> a -> b
$ \cd :: ConnectionData
cd@ConnectionData{Ptr PGconn
IORef (Set Text)
ConnectionStats
cdPreparedQueries :: IORef (Set Text)
cdStats :: ConnectionStats
cdPtr :: Ptr PGconn
cdPreparedQueries :: ConnectionData -> IORef (Set Text)
cdStats :: ConnectionData -> ConnectionStats
cdPtr :: ConnectionData -> Ptr PGconn
..} -> forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask 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 <- forall a. IO a -> IO (Async a)
async forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO a
restore 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 <- forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr PGresult
res forall a b. (a -> b) -> a -> b
$ forall sql.
IsSQL sql =>
sql -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
verifyResult sql
sql Ptr PGconn
cdPtr
      ConnectionStats
stats' <- case Either Int Int
affected of
        Left Int
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ConnectionStats
cdStats {
          statsQueries :: Int
statsQueries = ConnectionStats -> Int
statsQueries ConnectionStats
cdStats forall a. Num a => a -> a -> a
+ Int
1
        , statsParams :: Int
statsParams  = ConnectionStats -> Int
statsParams ConnectionStats
cdStats forall a. Num a => a -> a -> a
+ Int
paramCount
        }
        Right Int
rows -> do
          Int
columns <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr PGresult
res Ptr PGresult -> IO CInt
c_PQnfields
          forall (m :: * -> *) a. Monad m => a -> m a
return ConnectionStats {
            statsQueries :: Int
statsQueries = ConnectionStats -> Int
statsQueries ConnectionStats
cdStats forall a. Num a => a -> a -> a
+ Int
1
          , statsRows :: Int
statsRows    = ConnectionStats -> Int
statsRows ConnectionStats
cdStats forall a. Num a => a -> a -> a
+ Int
rows
          , statsValues :: Int
statsValues  = ConnectionStats -> Int
statsValues ConnectionStats
cdStats forall a. Num a => a -> a -> a
+ (Int
rows forall a. Num a => a -> a -> a
* Int
columns)
          , statsParams :: Int
statsParams  = ConnectionStats -> Int
statsParams ConnectionStats
cdStats forall a. Num a => a -> a -> a
+ Int
paramCount
          }
      -- Force evaluation of modified stats to squash a space leak.
      ConnectionStats
stats' seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectionData
cd { cdStats :: ConnectionStats
cdStats = ConnectionStats
stats' }, (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id 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.
    forall a b. IO a -> IO b -> IO a
E.onException (forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO a
wait Async (ConnectionData, (Int, ForeignPtr PGresult))
queryRunner) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO a
E.uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ do
      Ptr PGconn -> IO (Maybe String)
c_PQcancel Ptr PGconn
cdPtr 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 -> 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
_ -> forall a. Async a -> IO (Maybe (Either SomeException a))
poll Async (ConnectionData, (Int, ForeignPtr PGresult))
queryRunner forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just Either SomeException (ConnectionData, (Int, ForeignPtr PGresult))
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Maybe
  (Either SomeException (ConnectionData, (Int, ForeignPtr PGresult)))
Nothing -> do
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Ptr PGconn -> IO (Maybe String)
c_PQcancel Ptr PGconn
cdPtr
            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 = forall r.
Connection
-> String -> (ConnectionData -> IO (ConnectionData, r)) -> IO r
withConnectionData Connection
conn String
fname

verifyResult :: IsSQL sql => sql -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
verifyResult :: forall sql.
IsSQL sql =>
sql -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)
verifyResult sql
sql 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 forall a. Eq a => a -> a -> Bool
== ExecStatusType
c_PGRES_COMMAND_OK -> do
      ByteString
sn <- Ptr PGresult -> IO CString
c_PQcmdTuples Ptr PGresult
res 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left 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 forall a. Eq a => a -> a -> Bool
/= ByteString
BS.empty -> ByteString -> IO (Either Int Int)
throwParseError ByteString
sn
          | Bool
otherwise        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int
n
    ExecStatusType
_ | ExecStatusType
rst forall a. Eq a => a -> a -> Bool
== ExecStatusType
c_PGRES_TUPLES_OK    -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PGresult -> IO CInt
c_PQntuples Ptr PGresult
res
    ExecStatusType
_ | ExecStatusType
rst forall a. Eq a => a -> a -> Bool
== ExecStatusType
c_PGRES_FATAL_ERROR  -> IO (Either Int Int)
throwSQLError
    ExecStatusType
_ | ExecStatusType
rst forall a. Eq a => a -> a -> Bool
== ExecStatusType
c_PGRES_BAD_RESPONSE -> IO (Either Int Int)
throwSQLError
    ExecStatusType
_ | Bool
otherwise                  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int
0
    where
      throwSQLError :: IO (Either Int Int)
throwSQLError = forall sql a. IsSQL sql => sql -> SomeException -> IO a
rethrowWithContext sql
sql forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if Ptr PGresult
res forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> SomeException
E.toException forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QueryError
QueryError
          forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CString -> IO String
safePeekCString' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr PGconn -> IO CString
c_PQerrorMessage Ptr PGconn
conn
        else forall e. Exception e => e -> SomeException
E.toException 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
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO String
field ErrorField
c_PG_DIAG_SEVERITY
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> ErrorCode
stringToErrorCode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO String
field ErrorField
c_PG_DIAG_SQLSTATE)
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO String
field ErrorField
c_PG_DIAG_MESSAGE_PRIMARY
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_MESSAGE_DETAIL
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_MESSAGE_HINT
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((forall a. Read a => String -> Maybe a
mread forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_STATEMENT_POSITION)
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((forall a. Read a => String -> Maybe a
mread forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_INTERNAL_POSITION)
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_INTERNAL_QUERY
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_CONTEXT
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_SOURCE_FILE
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((forall a. Read a => String -> Maybe a
mread forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorField -> IO (Maybe String)
mfield ErrorField
c_PG_DIAG_SOURCE_LINE)
          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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" forall a. a -> a
id 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 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 = forall e a. Exception e => e -> IO a
E.throwIO DBException {
        dbeQueryContext :: sql
dbeQueryContext = sql
sql
      , dbeError :: HPQTypesError
dbeError = String -> HPQTypesError
HPQTypesError (String
"verifyResult: string returned by PQcmdTuples is not a valid number: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
sn)
      }