module Database.PostgreSQL.PQTypes.Internal.Connection
(
Connection (..)
, getBackendPidIO
, ConnectionData (..)
, withConnectionData
, ConnectionStats (..)
, ConnectionSettings (..)
, defaultConnectionSettings
, ConnectionSourceM (..)
, ConnectionSource (..)
, simpleSource
, poolSource
, connect
, disconnect
, 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
, ConnectionSettings -> Maybe Text
csClientEncoding :: !(Maybe T.Text)
, ConnectionSettings -> Maybe (RawSQL ())
csRole :: !(Maybe (RawSQL ()))
, ConnectionSettings -> [Text]
csComposites :: ![T.Text]
}
deriving (ConnectionSettings -> ConnectionSettings -> Bool
(ConnectionSettings -> ConnectionSettings -> Bool)
-> (ConnectionSettings -> ConnectionSettings -> Bool)
-> Eq ConnectionSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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)
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 = []
}
data ConnectionStats = ConnectionStats
{ ConnectionStats -> Int
statsQueries :: !Int
, ConnectionStats -> Int
statsRows :: !Int
, ConnectionStats -> Int
statsValues :: !Int
, ConnectionStats -> Int
statsParams :: !Int
}
deriving (ConnectionStats -> ConnectionStats -> Bool
(ConnectionStats -> ConnectionStats -> Bool)
-> (ConnectionStats -> ConnectionStats -> Bool)
-> Eq ConnectionStats
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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)
initialStats :: ConnectionStats
initialStats :: ConnectionStats
initialStats =
ConnectionStats
{ statsQueries :: Int
statsQueries = Int
0
, statsRows :: Int
statsRows = Int
0
, statsValues :: Int
statsValues = Int
0
, statsParams :: Int
statsParams = Int
0
}
data ConnectionData = ConnectionData
{ ConnectionData -> Ptr PGconn
cdPtr :: !(Ptr PGconn)
, ConnectionData -> BackendPid
cdBackendPid :: !BackendPid
, ConnectionData -> ConnectionStats
cdStats :: !ConnectionStats
, ConnectionData -> IORef (Set Text)
cdPreparedQueries :: !(IORef (S.Set T.Text))
}
newtype Connection = Connection
{ Connection -> MVar (Maybe ConnectionData)
unConnection :: MVar (Maybe ConnectionData)
}
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)
newtype ConnectionSourceM m = ConnectionSourceM
{ forall (m :: * -> *).
ConnectionSourceM m -> forall r. (Connection -> m r) -> m r
withConnection :: forall r. (Connection -> m r) -> m r
}
newtype ConnectionSource (cs :: [(Type -> Type) -> Constraint]) = ConnectionSource
{ forall (cs :: [(* -> *) -> Constraint]).
ConnectionSource cs
-> forall (m :: * -> *). MkConstraint m cs => ConnectionSourceM m
unConnectionSource :: forall m. MkConstraint m cs => ConnectionSourceM m
}
simpleSource
:: ConnectionSettings
-> ConnectionSource [MonadBase IO, MonadMask]
simpleSource :: ConnectionSettings -> ConnectionSource '[MonadBase IO, MonadMask]
simpleSource ConnectionSettings
cs =
(forall (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)
}
poolSource
:: ConnectionSettings
-> (IO Connection -> (Connection -> IO ()) -> PoolConfig 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
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
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]
++)
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
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
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
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
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)
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
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
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
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))
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
Maybe String
Nothing -> Async (ConnectionData, (Int, ForeignPtr PGresult)) -> IO ()
forall a. Async a -> IO ()
cancel Async (ConnectionData, (Int, ForeignPtr PGresult))
queryRunner
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
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
}