hpqtypes 1.9.3.1 → 1.9.4.0

raw patch · 12 files changed

+391/−175 lines, 12 filesdep ~monad-controlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: monad-control

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• hpqtypes.cabal +1/−1
• libpqtypes/src/exec.c +13/−0
• libpqtypes/src/ffi.c +0/−13
• libpqtypes/src/libpqtypes.h +4/−3
• src/Database/PostgreSQL/PQTypes/Class.hs +12/−7
• src/Database/PostgreSQL/PQTypes/Internal/C/Interface.hs +93/−44
• src/Database/PostgreSQL/PQTypes/Internal/Connection.hs +58/−46
• src/Database/PostgreSQL/PQTypes/Internal/Monad.hs +2/−0
• src/Database/PostgreSQL/PQTypes/Internal/Query.hs +117/−59
• src/Database/PostgreSQL/PQTypes/Utils.hs +54/−0
• test/Main.hs +31/−2

@@ -1,3 +1,9 @@+# hpqtypes-1.9.4.0 (2022-05-18)+* Add support for prepared statements.+* Make more foreign C calls safe.+* Don't manage `PGconn` with a `ForeignPtr`.+* Use `closeFdWith` when closing connections.+ # hpqtypes-1.9.3.1 (2022-03-30) * Fix `withTransaction` and `withSavepoint` with short-circuiting monad   transformers such as `ExceptT`.

@@ -1,5 +1,5 @@ name:                hpqtypes-version:             1.9.3.1+version:             1.9.4.0 synopsis:            Haskell bindings to libpqtypes  description:         Efficient and easy-to-use bindings to (slightly modified)

@@ -314,6 +314,19 @@ }  PGresult *+PQparamPrepare(PGconn *conn, PGerror *err, PGparam *param, const char *stmtName,+               const char *query)+{+	BUILD_ARRAYS(PGresult *);++	r = PQprepare(conn, stmtName, query, vcnt, oids);++	r = copyExecError(conn, err, r);++	RETURN_RESULT;+}++PGresult * PQparamExecPrepared(PGconn *conn, PGerror *err, PGparam *param, const char *stmtName, 	int resultFormat) {

@@ -3,16 +3,3 @@ // Needed by bindings for passing this in case // input ByteString is null. const char pqt_hs_null_string_ptr[1];--// Workaround for bug in GHC FFI that causes foreign-// pointer finalizers to be run more than once under-// random circumstances - PQfinish invoked on already-// finished PGconn causes segmentation fault, therefore-// we introduce another level of indirection and set-// finished PGconn object to NULL so that subsequent-// calls to this function are safe.-void PQfinishPtr(PGconn **conn)-{-  PQfinish(*conn);-  *conn = NULL;-}

@@ -466,6 +466,10 @@ 	const char *command, int resultFormat);  PQT_EXPORT PGresult *+PQparamPrepare(PGconn *conn, PGerror *err, PGparam *param, const char *stmtName,+               const char *query);++PQT_EXPORT PGresult * PQparamExecPrepared(PGconn *conn, PGerror *err, PGparam *param, 	const char *stmtName, int resultFormat); @@ -479,9 +483,6 @@ PQlocalTZInfo(time_t *t, int *gmtoff, int *isdst, char **tzabbrp);  /* === in ffi.c === */--PQT_EXPORT void-PQfinishPtr(PGconn **conn);  PQT_EXPORT const char pqt_hs_null_string_ptr[1];

@@ -1,7 +1,6 @@-{-# LANGUAGE OverlappingInstances #-}-{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}-module Database.PostgreSQL.PQTypes.Class (-    MonadDB(..)+module Database.PostgreSQL.PQTypes.Class+  ( QueryName(..)+  , MonadDB(..)   ) where  import Control.Monad.Trans@@ -10,6 +9,7 @@ import Database.PostgreSQL.PQTypes.FromRow import Database.PostgreSQL.PQTypes.Internal.Connection import Database.PostgreSQL.PQTypes.Internal.Notification+import Database.PostgreSQL.PQTypes.Internal.Query import Database.PostgreSQL.PQTypes.Internal.QueryResult import Database.PostgreSQL.PQTypes.SQL.Class import Database.PostgreSQL.PQTypes.Transaction.Settings@@ -20,6 +20,9 @@   -- a given time. If simultaneous call is made from another thread, it   -- will block until currently running 'runQuery' finishes.   runQuery :: IsSQL sql => sql -> m Int+  -- | Similar to 'runQuery', but it prepares and executes a statement under a+  -- given name.+  runPreparedQuery :: IsSQL sql => QueryName -> sql -> m Int   -- | Get last SQL query that was executed.   getLastQuery :: m SomeSQL   -- | Subsequent queries in the callback do not alter the result of@@ -66,15 +69,16 @@   -- the parent one.   withNewConnection :: m a -> m a --- | Generic, overlapping instance.-instance (-    Applicative (t m)+-- | Generic, overlappable instance.+instance {-# OVERLAPPABLE #-}+  ( Applicative (t m)   , Monad (t m)   , MonadTrans t   , MonadTransControl t   , MonadDB m   ) => MonadDB (t m) where     runQuery = lift . runQuery+    runPreparedQuery name = lift . runPreparedQuery name     getLastQuery = lift getLastQuery     withFrozenLastQuery m = controlT $ \run -> withFrozenLastQuery (run m)     getConnectionStats = lift getConnectionStats@@ -85,6 +89,7 @@     getNotification = lift . getNotification     withNewConnection m = controlT $ \run -> withNewConnection (run m)     {-# INLINE runQuery #-}+    {-# INLINE runPreparedQuery #-}     {-# INLINE getLastQuery #-}     {-# INLINE withFrozenLastQuery #-}     {-# INLINE getConnectionStats #-}

@@ -19,12 +19,13 @@   , c_PQcancel   , c_PQconnectStart   , c_PQconnectPoll-  , c_PQfinishPtr-  , c_ptr_PQfinishPtr+  , c_PQfinish   -- * libpqtypes imports   , c_PQinitTypes   , c_PQregisterTypes   , c_PQparamExec+  , c_PQparamPrepare+  , c_PQparamExecPrepared   , c_PQparamCreate   , c_PQparamClear   , c_PQparamCount@@ -41,7 +42,8 @@  import Database.PostgreSQL.PQTypes.Internal.C.Types --- libpq imports+----------------------------------------+-- PGconn  foreign import ccall unsafe "PQfreemem"   c_PQfreemem :: Ptr a -> IO ()@@ -52,15 +54,32 @@ foreign import ccall unsafe "PQerrorMessage"   c_PQerrorMessage :: Ptr PGconn -> IO CString -foreign import ccall unsafe "PQsetClientEncoding"-  c_PQsetClientEncoding :: Ptr PGconn -> CString -> IO CInt- foreign import ccall unsafe "PQsocket"   c_PQsocket :: Ptr PGconn -> IO Fd -foreign import ccall unsafe "PQconsumeInput"+-- | Safe as it sends a query to the server.+foreign import ccall safe "PQsetClientEncoding"+  c_PQsetClientEncoding :: Ptr PGconn -> CString -> IO CInt++-- | Safe as it reads data from a socket.+foreign import ccall safe "PQconsumeInput"   c_PQconsumeInput :: Ptr PGconn -> IO CInt +-- | Safe as it might make a DNS lookup.+foreign import ccall safe "PQconnectStart"+  c_PQconnectStart :: CString -> IO (Ptr PGconn)++-- | Safe as it reads data from a socket.+foreign import ccall safe "PQconnectPoll"+  c_PQconnectPoll :: Ptr PGconn -> IO PostgresPollingStatusType++-- | Safe as it sends a terminate command to the server.+foreign import ccall safe "PQfinish"+  c_PQfinish :: Ptr PGconn -> IO ()++----------------------------------------+-- PGresult+ foreign import ccall unsafe "PQresultStatus"   c_PQresultStatus :: Ptr PGresult -> IO ExecStatusType @@ -85,10 +104,16 @@ foreign import ccall unsafe "PQfname"   c_PQfname :: Ptr PGresult -> CInt -> IO CString -foreign import ccall unsafe "PQclear"+-- | Safe as it performs multiple actions when clearing the result.+foreign import ccall safe "PQclear"   c_PQclear :: Ptr PGresult -> IO () +-- | Safe as it performs multiple actions when clearing the result.+foreign import ccall safe "&PQclear"+  c_ptr_PQclear :: FunPtr (Ptr PGresult -> IO ())+ ----------------------------------------+-- PGcancel  foreign import ccall unsafe "PQgetCancel"   c_PQgetCancel :: Ptr PGconn -> IO (Ptr PGcancel)@@ -96,7 +121,9 @@ foreign import ccall unsafe "PQfreeCancel"   c_PQfreeCancel :: Ptr PGcancel -> IO () -foreign import ccall unsafe "PQcancel"+-- | Safe as it establishes a separate connection to PostgreSQL to send the+-- cancellation request.+foreign import ccall safe "PQcancel"   c_rawPQcancel :: Ptr PGcancel -> CString -> CInt -> IO CInt  -- | Attempt to cancel currently running query. If the request is successfully@@ -115,26 +142,7 @@     errbufsize = 256  ------------------------------------------foreign import ccall unsafe "PQconnectStart"-  c_PQconnectStart :: CString -> IO (Ptr PGconn)--foreign import ccall unsafe "PQconnectPoll"-  c_PQconnectPoll :: Ptr PGconn -> IO PostgresPollingStatusType--foreign import ccall unsafe "PQfinishPtr"-  c_PQfinishPtr :: Ptr (Ptr PGconn) -> IO ()--foreign import ccall unsafe "&PQfinishPtr"-  c_ptr_PQfinishPtr :: FunPtr (Ptr (Ptr PGconn) -> IO ())---- libpqtypes imports--foreign import ccall unsafe "PQinitTypes"-  c_PQinitTypes :: Ptr PGconn -> IO ()--foreign import ccall unsafe "PQregisterTypes"-  c_PQregisterTypes :: Ptr PGconn -> Ptr PGerror -> TypeClass -> Ptr PGregisterType -> CInt -> CInt -> IO CInt+-- libpqtypes / PGparam  foreign import ccall unsafe "PQparamCreate"   c_PQparamCreate :: Ptr PGconn -> Ptr PGerror -> IO (Ptr PGparam)@@ -145,26 +153,67 @@ foreign import ccall unsafe "PQparamCount"   c_PQparamCount :: Ptr PGparam -> IO CInt --- misc--foreign import ccall unsafe "&pqt_hs_null_string_ptr"-  nullStringPtr :: Ptr CChar--nullStringCStringLen :: CStringLen-nullStringCStringLen = (nullStringPtr, 0)+-- | Safe as it calls PQregisterEventProc with a nontrivial callback.+foreign import ccall safe "PQinitTypes"+  c_PQinitTypes :: Ptr PGconn -> IO () -----------------------------------------+-- | Safe as it sends a query to the server.+foreign import ccall safe "PQregisterTypes"+  c_PQregisterTypes :: Ptr PGconn -> Ptr PGerror -> TypeClass -> Ptr PGregisterType -> CInt -> CInt -> IO CInt --- | May run for a long time, hence marked 'safe'.+-- | Safe as query execution might run for a long time. foreign import ccall safe "PQparamExec"   c_rawPQparamExec :: Ptr PGconn -> Ptr PGerror -> Ptr PGparam -> CString -> ResultFormat -> IO (Ptr PGresult) -foreign import ccall unsafe "&PQclear"-  c_ptr_PQclear :: FunPtr (Ptr PGresult -> IO ())+-- | Safe as it contacts the server.+foreign import ccall safe "PQparamPrepare"+  c_rawPQparamPrepare :: Ptr PGconn -> Ptr PGerror -> Ptr PGparam -> CString -> CString -> IO (Ptr PGresult) +-- | Safe as query execution might run for a long time.+foreign import ccall safe "PQparamExecPrepared"+  c_rawPQparamExecPrepared :: Ptr PGconn -> Ptr PGerror -> Ptr PGparam -> CString -> ResultFormat -> IO (Ptr PGresult)+ -- | Safe wrapper for 'c_rawPQparamExec'. Wraps result returned by--- 'c_rawPQparamExec' in 'ForeignPtr' with asynchronous exceptions--- masked to prevent memory leaks.+-- 'c_rawPQparamExec' in 'ForeignPtr' with asynchronous exceptions masked to+-- prevent memory leaks. c_PQparamExec :: Ptr PGconn -> Ptr PGerror -> Ptr PGparam -> CString -> ResultFormat -> IO (ForeignPtr PGresult)-c_PQparamExec conn err param fmt mode = E.mask_ $ newForeignPtr c_ptr_PQclear-  =<< c_rawPQparamExec conn err param fmt mode+c_PQparamExec conn err param fmt mode = do+  E.mask_ $ newForeignPtr c_ptr_PQclear+    =<< c_rawPQparamExec conn err param fmt mode++-- | Safe wrapper for 'c_rawPQprepare'. Wraps result returned by+-- 'c_rawPQprepare' in 'ForeignPtr' with asynchronous exceptions masked to+-- prevent memory leaks.+c_PQparamPrepare+  :: Ptr PGconn+  -> Ptr PGerror+  -> Ptr PGparam+  -> CString+  -> CString+  -> IO (ForeignPtr PGresult)+c_PQparamPrepare conn err param queryName query = do+  E.mask_ $ newForeignPtr c_ptr_PQclear+    =<< c_rawPQparamPrepare conn err param queryName query++-- | Safe wrapper for 'c_rawPQparamExecPrepared'. Wraps result returned by+-- 'c_rawPQparamExecPrepared' in 'ForeignPtr' with asynchronous exceptions+-- masked to prevent memory leaks.+c_PQparamExecPrepared+  :: Ptr PGconn+  -> Ptr PGerror+  -> Ptr PGparam+  -> CString+  -> ResultFormat+  -> IO (ForeignPtr PGresult)+c_PQparamExecPrepared conn err param queryName mode = do+  E.mask_ $ newForeignPtr c_ptr_PQclear+    =<< c_rawPQparamExecPrepared conn err param queryName mode++----------------------------------------+-- Miscellaneous++foreign import ccall unsafe "&pqt_hs_null_string_ptr"+  nullStringPtr :: Ptr CChar++nullStringCStringLen :: CStringLen+nullStringCStringLen = (nullStringPtr, 0)

@@ -20,17 +20,17 @@ import Control.Monad.Base import Control.Monad.Catch import Data.Function-import Data.Kind (Type)+import Data.IORef+import Data.Kind import Data.Pool import Data.Time.Clock import Foreign.C.String-import Foreign.ForeignPtr import Foreign.Ptr-import Foreign.Storable-import GHC.Exts+import GHC.Conc (closeFdWith) import qualified Control.Exception as E import qualified Data.ByteString as BS import qualified Data.Foldable as F+import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -85,14 +85,21 @@ }  -- | Representation of a connection object.-data ConnectionData = ConnectionData {-  -- | Foreign pointer to pointer to connection object.-  cdFrgnPtr  :: !(ForeignPtr (Ptr PGconn))-  -- | Pointer to connection object (the same as in 'cdFrgnPtr').-, cdPtr      :: !(Ptr PGconn)-  -- | Statistics associated with the connection.-, cdStats    :: !ConnectionStats-}+--+-- /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+  { cdPtr      :: !(Ptr PGconn)+  -- ^ Pointer to connection object.+  , cdStats    :: !ConnectionStats+  -- ^ Statistics associated with the connection.+  , 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 {@@ -169,13 +176,15 @@  ---------------------------------------- --- | Low-level function for connecting to the database.--- Useful if one wants to implement custom connection source.+-- | 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{..} = do-  fconn <- BS.useAsCString (T.encodeUtf8 csConnInfo) openConnection-  withForeignPtr fconn $ \connPtr -> do-    conn <- peek connPtr+connect ConnectionSettings{..} = mask $ \unmask -> do+  conn <- BS.useAsCString (T.encodeUtf8 csConnInfo) (openConnection unmask)+  (`onException` c_PQfinish conn) . unmask $ do     status <- c_PQstatus conn     when (status /= c_CONNECTION_OK) $       throwLibPQError conn fname@@ -185,38 +194,29 @@         throwLibPQError conn fname     c_PQinitTypes conn     registerComposites conn csComposites-    Connection <$> newMVar (Just ConnectionData {-      cdFrgnPtr = fconn-    , cdPtr     = conn-    , cdStats   = initialStats-    })+    preparedQueries <- newIORef S.empty+    fmap Connection . newMVar $ Just ConnectionData+      { cdPtr = conn+      , cdStats = initialStats+      , cdPreparedQueries = preparedQueries+      }   where     fname = "connect" -    openConnection :: CString -> IO (ForeignPtr (Ptr PGconn))-    openConnection conninfo = E.mask $ \restore -> do-      -- We want to use non-blocking C functions to be able to observe-      -- incoming asynchronous exceptions, hence we don't use-      -- PQconnectdb here.+    openConnection :: (forall r. IO r -> IO r) -> CString -> IO (Ptr PGconn)+    openConnection unmask 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.       conn <- c_PQconnectStart conninfo       when (conn == nullPtr) $         throwError "PQconnectStart returned a null pointer"-      -- Work around a bug in GHC that causes foreign pointer finalizers to be-      -- run multiple times under random circumstances (see-      -- https://ghc.haskell.org/trac/ghc/ticket/7170 for more details; note-      -- that the bug was fixed in GHC 8.0.1, but we still want to support-      -- previous versions) by providing another level of indirection and a-      -- wrapper for PQfinish that can be safely called multiple times.-      connPtr <- mallocForeignPtr-      withForeignPtr connPtr (`poke` conn)-      addForeignPtrFinalizer c_ptr_PQfinishPtr connPtr-      -- Wait until connection status is resolved (to either-      -- established or failed state).-      restore $ fix $ \loop -> do+      fd <- getFd conn+      (`onException` c_PQfinish conn) . unmask $ fix $ \loop -> do         ps <- c_PQconnectPoll conn-        if | ps == c_PGRES_POLLING_READING -> (threadWaitRead  =<< getFd conn) >> loop-           | ps == c_PGRES_POLLING_WRITING -> (threadWaitWrite =<< getFd conn) >> loop-           | otherwise                     -> return connPtr+        if | ps == c_PGRES_POLLING_READING -> threadWaitRead  fd >> loop+           | ps == c_PGRES_POLLING_WRITING -> threadWaitWrite fd >> loop+           | ps == c_PGRES_POLLING_OK      -> return conn+           | otherwise                     -> throwError "openConnection failed"       where         getFd conn = do           fd <- c_PQsocket conn@@ -224,13 +224,25 @@             throwError "invalid file descriptor"           return fd +        throwError :: String -> IO a         throwError = hpqTypesError . (fname ++) . (": " ++) --- | Low-level function for disconnecting from the database.--- Useful if one wants to implement custom connection source.+-- | Low-level function for disconnecting from the database. Useful if one wants+-- to implement custom connection source. disconnect :: Connection -> IO () disconnect (Connection mvconn) = modifyMVar_ mvconn $ \mconn -> do   case mconn of-    Just cd -> withForeignPtr (cdFrgnPtr cd) c_PQfinishPtr+    Just cd -> do+      let conn = cdPtr 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.+      c_PQsocket conn >>= \case+        -1 -> c_PQfinish conn -- can happen if the connection is bad/lost+        fd -> closeFdWith (\_ -> c_PQfinish conn) fd+     Nothing -> E.throwIO (HPQTypesError "disconnect: no connection (shouldn't happen)")   return Nothing

@@ -75,6 +75,8 @@  instance (m ~ n, MonadBase IO m, MonadMask m) => MonadDB (DBT_ m n) where   runQuery sql = DBT . StateT $ liftBase . runQueryIO sql+  runPreparedQuery name sql = DBT . StateT $ liftBase . runPreparedQueryIO name sql+   getLastQuery = DBT . gets $ dbLastQuery    withFrozenLastQuery callback = DBT . StateT $ \st -> do

@@ -1,12 +1,20 @@-module Database.PostgreSQL.PQTypes.Internal.Query (-    runQueryIO+module Database.PostgreSQL.PQTypes.Internal.Query+  ( runQueryIO+  , QueryName(..)+  , runPreparedQueryIO   ) where  import Control.Concurrent.Async+import Control.Monad+import Data.IORef+import Data.String import Foreign.ForeignPtr import Foreign.Ptr import qualified Control.Exception as E import qualified Data.ByteString.Char8 as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Set as S  import Database.PostgreSQL.PQTypes.Internal.C.Interface import Database.PostgreSQL.PQTypes.Internal.C.Types@@ -20,9 +28,62 @@ import Database.PostgreSQL.PQTypes.SQL.Class import Database.PostgreSQL.PQTypes.ToSQL --- | Low-level function for running SQL query.-runQueryIO :: IsSQL sql => sql -> DBState m -> IO (Int, DBState m)-runQueryIO sql st = do+-- | Low-level function for running an SQL query.+runQueryIO+  :: IsSQL sql+  => sql+  -> DBState m+  -> IO (Int, DBState m)+runQueryIO sql = runQueryImpl "runQueryIO" sql $ \ConnectionData{..} -> do+  let allocParam = ParamAllocator $ withPGparam cdPtr+  withSQL sql allocParam $ \param query -> (,)+    <$> (fromIntegral <$> c_PQparamCount param)+    <*> c_PQparamExec cdPtr nullPtr param query c_RESULT_BINARY++-- | Name of a prepared query.+newtype QueryName = QueryName T.Text+  deriving (Eq, Ord, Show, IsString)++-- | Low-level function for running a prepared SQL query.+runPreparedQueryIO+  :: IsSQL sql+  => QueryName+  -> sql+  -> DBState m+  -> IO (Int, DBState m)+runPreparedQueryIO (QueryName queryName) sql = do+  runQueryImpl "runPreparedQueryIO" sql $ \ConnectionData{..} -> do+    when (T.null queryName) $ do+      E.throwIO DBException+        { dbeQueryContext = sql+        , dbeError = HPQTypesError "runPreparedQueryIO: unnamed prepared query is not supported"+        }+    let allocParam = ParamAllocator $ withPGparam cdPtr+    withSQL sql allocParam $ \param query -> do+      preparedQueries <- readIORef cdPreparedQueries+      BS.useAsCString (T.encodeUtf8 queryName) $ \cname -> do+        when (queryName `S.notMember` preparedQueries) . E.mask_ $ 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.+          res <- c_PQparamPrepare cdPtr nullPtr param cname query+          void . withForeignPtr res $ verifyResult sql cdPtr+          modifyIORef' cdPreparedQueries $ S.insert queryName+        (,) <$> (fromIntegral <$> c_PQparamCount param)+            <*> c_PQparamExecPrepared cdPtr nullPtr param cname c_RESULT_BINARY++----------------------------------------+-- Helpers++-- | Shared implementation of 'runQueryIO' and 'runPreparedQueryIO'.+runQueryImpl+  :: IsSQL sql+  => String+  -> sql+  -> (ConnectionData -> IO (Int, ForeignPtr PGresult))+  -> DBState m+  -> IO (Int, DBState m)+runQueryImpl fname sql execSql st = do   (affected, res) <- withConnDo $ \cd@ConnectionData{..} -> E.mask $ \restore -> do     -- While the query runs, the current thread will not be able to receive     -- asynchronous exceptions. This prevents clients of the library from@@ -31,11 +92,8 @@     -- are able to receive asynchronous exceptions (assuming that threaded GHC     -- runtime system is used) and react appropriately.     queryRunner <- async . restore $ do-      let allocParam = ParamAllocator $ withPGparam cdPtr-      (paramCount, res) <- withSQL sql allocParam $ \param query -> (,)-        <$> (fromIntegral <$> c_PQparamCount param)-        <*> c_PQparamExec cdPtr nullPtr param query c_RESULT_BINARY-      affected <- withForeignPtr res $ verifyResult cdPtr+      (paramCount, res) <- execSql cd+      affected <- withForeignPtr res $ verifyResult sql cdPtr       stats' <- case affected of         Left _ -> return cdStats {           statsQueries = statsQueries cdStats + 1@@ -62,16 +120,16 @@         -- nothing else to do apart from waiting for the runner to terminate.         Nothing -> cancel queryRunner         -- Otherwise we check what happened with the runner. If it already-        -- finished we're fine, just ignore the result. If it didn't, there is-        -- something wrong - cancellation request didn't go through, yet the-        -- query is still running? It's not clear how this might happen, but in-        -- such case we must wait for its completion anyway.-        Just err -> poll queryRunner >>= \case+        -- 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 _ -> poll queryRunner >>= \case           Just _  -> return ()           Nothing -> do+            void $ c_PQcancel cdPtr             cancel queryRunner-            rethrowWithContext sql . E.toException $-              HPQTypesError ("PQcancel failed: " ++ err)+   return (affected, st {     dbLastQuery = if dbRecordLastQuery st then SomeSQL sql else dbLastQuery st   , dbQueryResult = Just QueryResult {@@ -81,48 +139,48 @@     }   })   where-    withConnDo = withConnectionData (dbConnection st) "runQueryIO"+    withConnDo = withConnectionData (dbConnection st) fname -    verifyResult :: Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)-    verifyResult conn res = do-      -- works even if res is NULL-      rst <- c_PQresultStatus res-      case rst of-        _ | rst == c_PGRES_COMMAND_OK -> do-          sn <- c_PQcmdTuples res >>= BS.packCString-          case BS.readInt sn of-            Nothing-              | BS.null sn -> return . Left $ 0-              | otherwise  -> throwParseError sn-            Just (n, rest)-              | rest /= BS.empty -> throwParseError sn-              | otherwise        -> return . Left $ n-        _ | rst == c_PGRES_TUPLES_OK    -> Right . fromIntegral <$> c_PQntuples res-        _ | rst == c_PGRES_FATAL_ERROR  -> throwSQLError-        _ | rst == c_PGRES_BAD_RESPONSE -> throwSQLError-        _ | otherwise                  -> return . Left $ 0+verifyResult :: IsSQL sql => sql -> Ptr PGconn -> Ptr PGresult -> IO (Either Int Int)+verifyResult sql conn res = do+  -- works even if res is NULL+  rst <- c_PQresultStatus res+  case rst of+    _ | rst == c_PGRES_COMMAND_OK -> do+      sn <- c_PQcmdTuples res >>= BS.packCString+      case BS.readInt sn of+        Nothing+          | BS.null sn -> return . Left $ 0+          | otherwise  -> throwParseError sn+        Just (n, rest)+          | rest /= BS.empty -> throwParseError sn+          | otherwise        -> return . Left $ n+    _ | rst == c_PGRES_TUPLES_OK    -> Right . fromIntegral <$> c_PQntuples res+    _ | rst == c_PGRES_FATAL_ERROR  -> throwSQLError+    _ | rst == c_PGRES_BAD_RESPONSE -> throwSQLError+    _ | otherwise                  -> return . Left $ 0+    where+      throwSQLError = rethrowWithContext sql =<< if res == nullPtr+        then return . E.toException . QueryError+          =<< safePeekCString' =<< c_PQerrorMessage conn+        else E.toException <$> (DetailedQueryError+          <$> field c_PG_DIAG_SEVERITY+          <*> (stringToErrorCode <$> field c_PG_DIAG_SQLSTATE)+          <*> field c_PG_DIAG_MESSAGE_PRIMARY+          <*> mfield c_PG_DIAG_MESSAGE_DETAIL+          <*> mfield c_PG_DIAG_MESSAGE_HINT+          <*> ((mread =<<) <$> mfield c_PG_DIAG_STATEMENT_POSITION)+          <*> ((mread =<<) <$> mfield c_PG_DIAG_INTERNAL_POSITION)+          <*> mfield c_PG_DIAG_INTERNAL_QUERY+          <*> mfield c_PG_DIAG_CONTEXT+          <*> mfield c_PG_DIAG_SOURCE_FILE+          <*> ((mread =<<) <$> mfield c_PG_DIAG_SOURCE_LINE)+          <*> mfield c_PG_DIAG_SOURCE_FUNCTION)         where-          throwSQLError = rethrowWithContext sql =<< if res == nullPtr-            then return . E.toException . QueryError-              =<< safePeekCString' =<< c_PQerrorMessage conn-            else E.toException <$> (DetailedQueryError-              <$> field c_PG_DIAG_SEVERITY-              <*> (stringToErrorCode <$> field c_PG_DIAG_SQLSTATE)-              <*> field c_PG_DIAG_MESSAGE_PRIMARY-              <*> mfield c_PG_DIAG_MESSAGE_DETAIL-              <*> mfield c_PG_DIAG_MESSAGE_HINT-              <*> ((mread =<<) <$> mfield c_PG_DIAG_STATEMENT_POSITION)-              <*> ((mread =<<) <$> mfield c_PG_DIAG_INTERNAL_POSITION)-              <*> mfield c_PG_DIAG_INTERNAL_QUERY-              <*> mfield c_PG_DIAG_CONTEXT-              <*> mfield c_PG_DIAG_SOURCE_FILE-              <*> ((mread =<<) <$> mfield c_PG_DIAG_SOURCE_LINE)-              <*> mfield c_PG_DIAG_SOURCE_FUNCTION)-            where-              field f = maybe "" id <$> mfield f-              mfield f = safePeekCString =<< c_PQresultErrorField res f+          field f = maybe "" id <$> mfield f+          mfield f = safePeekCString =<< c_PQresultErrorField res f -          throwParseError sn = E.throwIO DBException {-            dbeQueryContext = sql-          , dbeError = HPQTypesError ("runQuery.verifyResult: string returned by PQcmdTuples is not a valid number: " ++ show sn)-          }+      throwParseError sn = E.throwIO DBException {+        dbeQueryContext = sql+      , dbeError = HPQTypesError ("verifyResult: string returned by PQcmdTuples is not a valid number: " ++ show sn)+      }

@@ -8,6 +8,13 @@   , runSQL_   , runSQL01   , runSQL01_+  , runPreparedQuery_+  , runPreparedQuery01+  , runPreparedQuery01_+  , runPreparedSQL+  , runPreparedSQL_+  , runPreparedSQL01+  , runPreparedSQL01_   -- Internal.Utils   , hpqTypesError   ) where@@ -88,3 +95,50 @@ {-# INLINABLE runSQL01_ #-} runSQL01_ :: (MonadDB m, MonadThrow m) => SQL -> m () runSQL01_ = runQuery01_++----------------------------------------++-- | Specialization of 'runPreparedQuery' that discards the result.+{-# INLINABLE runPreparedQuery_ #-}+runPreparedQuery_ :: (IsSQL sql, MonadDB m) => QueryName -> sql -> m ()+runPreparedQuery_ name = void . runPreparedQuery name++-- | Specialization of 'runPreparedQuery' that checks whether affected/returned+-- number of rows is in range [0, 1] and returns appropriate 'Bool' value.+-- Otherwise, 'AffectedRowsMismatch' exception is thrown.+{-# INLINABLE runPreparedQuery01 #-}+runPreparedQuery01 :: (IsSQL sql, MonadDB m, MonadThrow m) => QueryName -> sql -> m Bool+runPreparedQuery01 name sql = do+  n <- runPreparedQuery name sql+  when (n > 1) $ throwDB AffectedRowsMismatch {+    rowsExpected = [(0, 1)]+  , rowsDelivered = n+  }+  return $ n == 1++-- | Specialization of 'runPreparedQuery01' that discards the result.+{-# INLINABLE runPreparedQuery01_ #-}+runPreparedQuery01_ :: (IsSQL sql, MonadDB m, MonadThrow m) => QueryName -> sql -> m ()+runPreparedQuery01_ name = void . runPreparedQuery01 name++----------------------------------------++-- | Specialization of 'runPreparedQuery' to 'SQL' type.+{-# INLINABLE runPreparedSQL #-}+runPreparedSQL :: MonadDB m => QueryName -> SQL -> m Int+runPreparedSQL = runPreparedQuery++-- | Specialization of 'runPreparedQuery_' to 'SQL' type.+{-# INLINABLE runPreparedSQL_ #-}+runPreparedSQL_ :: MonadDB m => QueryName -> SQL -> m ()+runPreparedSQL_ = runPreparedQuery_++-- | Specialization of 'runPreparedQuery01' to 'SQL' type.+{-# INLINABLE runPreparedSQL01 #-}+runPreparedSQL01 :: (MonadDB m, MonadThrow m) => QueryName -> SQL -> m Bool+runPreparedSQL01 = runPreparedQuery01++-- | Specialization of 'runPreparedQuery01_' to 'SQL' type.+{-# INLINABLE runPreparedSQL01_ #-}+runPreparedSQL01_ :: (MonadDB m, MonadThrow m) => QueryName -> SQL -> m ()+runPreparedSQL01_ = runPreparedQuery01_

@@ -316,6 +316,34 @@     assertEqualEq "Other connection sees autocommited data" 1 n   runQuery_ $ rawSQL "DELETE FROM test1_ WHERE a = $1" sint +preparedStatementTest :: TestData -> Test+preparedStatementTest td = testCase "Execution of prepared statements works" .+                           runTestEnv td defaultTransactionSettings $ do+  let name = "select1"++  checkPrepared name "Statement is not prepared" 0+  execPrepared name 42+  checkPrepared name "Statement is prepared" 1+  execPrepared name 89++  let i3 = "lalala" :: String+  -- Changing parameter type in an already prepared statement shouldn't work.+  o3 <- try $ runPreparedQuery_ name $ "SELECT" <?> i3+  case o3 of+    Left DBException{} -> pure ()+    Right r3 -> liftBase . assertFailure $ "Expected DBException, but got" <+> show r3+  where+    checkPrepared :: QueryName -> String -> Int -> TestEnv ()+    checkPrepared (QueryName name) assertTitle expected = do+      n <- runSQL $ "SELECT TRUE FROM pg_prepared_statements WHERE name =" <?> name+      assertEqualEq assertTitle expected n++    execPrepared :: QueryName -> Int32 -> TestEnv ()+    execPrepared name input = do+      runPreparedQuery_ name $ "SELECT" <?> input+      output <- fetchOne runIdentity+      assertEqualEq "Results match" input output+ readOnlyTest :: TestData -> Test readOnlyTest td = testCase "Read only transaction mode works" .                   runTestEnv td@@ -466,8 +494,9 @@   return res  tests :: TestData -> [Test]-tests td = [-    autocommitTest td+tests td =+  [ autocommitTest td+  , preparedStatementTest td   , xmlTest td   , readOnlyTest td   , savepointTest td