mysql-haskell 1.3.1 → 1.3.2

raw patch · 7 files changed

+404/−82 lines, 7 filesdep −memorydep ~cryptonPVP ok

version bump matches the API change (PVP)

Dependencies removed: memory

Dependency ranges changed: crypton

API changes (from Hackage documentation)

Files

• ChangeLog.md +27/−0
• mysql-haskell.cabal +11/−14
• src/Database/MySQL/Base.hs +179/−60
• src/Database/MySQL/Connection.hs +16/−8
• test/Integration.hs +4/−0
• test/MultipleResults.hs +107/−0
• test/QueryWithoutResultSet.hs +60/−0

@@ -1,5 +1,32 @@ # Revision history for mysql-haskell +## 1.3.2 -- 2026.10.07++Requires crypton 2.0 or newer, the first crypton with the timing side-channel+fixes that TLS connections reach; a project held to crypton 1.x keeps+resolving to 1.3.1. The only API addition is the `ExtraResultSets` exception.+The query functions now return an empty result for an INSERT, UPDATE or DELETE+instead of hanging. `execute_`, `executeStmt` and the query functions read the+whole reply of a CALL or a multi-statement query, so they no longer leave+results behind for the next command; `executeMany` and `executeMany_` are+unchanged (#93).++Errors change only for statements that produce several results, or rows where+`execute_` and `executeStmt` expect none. Those two raise `ExtraResultSets` for+a result set (1.3.1 threw `UnexpectedPacket` when it came first and returned the+`OK` when it came later); the query functions raise it after the first result+set's rows when a second one follows, which 1.3.1 left on the connection. A+later statement that fails raises its `ERRException` from that call or its row+stream, also ahead of `ExtraResultSets`. Stack users who set the removed+`crypton-1-1` flag must delete it from `stack.yaml`, since Stack rejects flags a+package does not define.+++ Query functions no longer hang on statements without a result set,+  multi-result replies are read to the end, and crypton 2 is required+  [#91](https://github.com/winterland1989/mysql-haskell/pull/91)++ CI: the cabal job builds and runs the test suite+  [#90](https://github.com/winterland1989/mysql-haskell/pull/90)+ ## 1.3.1 -- 2026.10.06 + Allow crypton 2.0 and 2.1 (commercialhaskell/stackage#8128). The library   code needed no change; CI now builds and tests against every crypton

@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               mysql-haskell-version:            1.3.1+version:            1.3.2 synopsis:           pure haskell MySQL driver description:        pure haskell MySQL driver. license:            BSD-3-Clause@@ -42,11 +42,6 @@   type:     git   location: https://github.com/winterland1989/mysql-haskell -flag crypton-1-1-  description: Build with crypton >= 1.1.0, including the 2.x series (uses ram instead of memory for ByteArrayAccess)-  default: True-  manual: False- common common-options   ghc-options:     -Wall -Wincomplete-uni-patterns@@ -113,14 +108,14 @@     vector >=0.8 && <0.13 || ^>=0.13.0,     word-compat >=0.0 && <0.1 -  if flag(crypton-1-1)-    build-depends:-      crypton ^>=1.1.0 || ^>=2.0.0 || ^>=2.1.0,-      ram >=0.20 && <0.23-  else-    build-depends:-      crypton >=0.31 && <0.40 || ^>=1.0.0,-      memory >=0.14.4 && <0.19+  -- Decision: require crypton 2.0, the first release with its side-channel+  -- fixes (none backported to 1.x). Before it, P-384/P-521 point multiplication+  -- and DH exponentiation took time that followed the secret, and tls runs them+  -- on the client's ephemeral key whenever the server picks such a group. 2.0+  -- rather than 2.1.x, as 2.0 has every fix we reach.+  build-depends:+    crypton ^>=2.0.0 || ^>=2.1.0,+    ram >=0.20 && <0.23    default-extensions:     DeriveDataTypeable@@ -188,7 +183,9 @@     BinLogNew     CachingSha2     ExecuteMany+    MultipleResults     MysqlTests+    QueryWithoutResultSet     RoundtripBit     RoundtripYear     SelectOne

@@ -20,6 +20,8 @@     * 'UnexpectedPacket':  you receive a unexpected packet when you shouldn't.     * 'DecodePacketException': there's a packet we can't decode.     * 'WrongParamsCount': you're giving wrong number of params to 'renderParams'.+    * 'ExtraResultSets': a statement produced a result-set the function running it+      could not return.  Both 'UnexpectedPacket' and 'DecodePacketException' may indicate a bug of this library rather your code, so please report! @@ -68,6 +70,7 @@     , UnexpectedPacket(..)     , DecodePacketException(..)     , WrongParamsCount(..)+    , ExtraResultSets(..)       -- * MySQL protocol     , module  Database.MySQL.Protocol.Auth     , module  Database.MySQL.Protocol.Command@@ -78,8 +81,10 @@  import           Control.Exception                  (mask, onException, throwIO) import           Control.Monad+import           Data.Binary                        (Get)+import           Data.Bits                          ((.&.)) import qualified Data.ByteString.Lazy               as L-import           Data.IORef                         (writeIORef)+import           Data.IORef                         (IORef, newIORef, readIORef, writeIORef) import           Database.MySQL.Connection import           Database.MySQL.Protocol.Auth import           Database.MySQL.Protocol.ColumnDef@@ -139,8 +144,11 @@  -- | Execute a MySQL query which don't return a result-set. --+-- For a multi-statement query this is the first statement's 'OK'; the later+-- ones are read and discarded ('executeMany_' returns them all).+-- execute_ :: MySQLConn -> Query -> IO OK-execute_ conn (Query qry) = command conn (COM_QUERY qry)+execute_ conn (Query qry) = executeCommand conn (COM_QUERY qry)  -- | Execute a MySQL query which return a result-set with parameters. --@@ -166,24 +174,22 @@  -- | Execute a MySQL query which return a result-set. --+-- A statement without a result-set, such as an INSERT, gives no columns and no+-- rows; use 'execute_' to get its 'OK'.+-- query_ :: MySQLConn -> Query -> IO ([ColumnDef], InputStream [MySQLValue]) query_ conn@(MySQLConn is os _ consumed) (Query qry) = do     guardUnconsumed conn     writeCommand (COM_QUERY qry) os-    p <- readPacket is-    if isERR p-    then decodeFromPacket p >>= throwIO . ERRException-    else do-        len <- getFromPacket getLenEncInt p-        fields <- replicateM len $ (decodeFromPacket <=< readPacket) is-        _ <- readPacket is -- eof packet, we don't verify this though-        writeIORef consumed False-        rows <- Stream.makeInputStream $ do-            q <- readPacket is-            if  | isEOF q  -> writeIORef consumed True >> return Nothing-                | isERR q  -> decodeFromPacket q >>= throwIO . ERRException-                | otherwise -> Just <$> getFromPacket (getTextRow fields) q-        return (fields, rows)+    reply <- readQueryReply is+    case reply of+        WithoutResultSet -> (,) [] <$> Stream.nullInput+        ResultSetColumns len -> do+            fields <- replicateM len $ (decodeFromPacket <=< readPacket) is+            _ <- readPacket is -- eof packet, we don't verify this though+            writeIORef consumed False+            rows <- resultSetRows is consumed (getFromPacket (getTextRow fields))+            return (fields, rows)  -- | 'V.Vector' version of 'query_'. --@@ -193,21 +199,126 @@ queryVector_ conn@(MySQLConn is os _ consumed) (Query qry) = do     guardUnconsumed conn     writeCommand (COM_QUERY qry) os+    reply <- readQueryReply is+    case reply of+        WithoutResultSet -> (,) V.empty <$> Stream.nullInput+        ResultSetColumns len -> do+            fields <- V.replicateM len $ (decodeFromPacket <=< readPacket) is+            _ <- readPacket is -- eof packet, we don't verify this though+            writeIORef consumed False+            rows <- resultSetRows is consumed (getFromPacket (getTextRowVector fields))+            return (fields, rows)++-- | How the server answered a statement sent through a query function.+data QueryReply+    = WithoutResultSet      -- ^ only OK packets, e.g. for an INSERT+    | ResultSetColumns Int  -- ^ a result-set with this many columns follows++-- | Read the reply to a query function's statement up to its first result-set.+--+-- An OK packet must be told apart here: its leading 0x00 also decodes as a+-- column count of zero, which used to leave the caller waiting forever for an+-- EOF packet the server never sends (issue #47). OKs flagged with more results+-- are skipped, so @SET \@x := 1; SELECT \@x@ gives the SELECT's rows.+--+-- Decision: answer such a statement with an empty result-set rather than an+-- exception, so code that worked around the hang keeps working and the fix is+-- not a breaking change. The OK's affected-rows count is dropped; 'execute_'+-- returns it.+readQueryReply :: InputStream Packet -> IO QueryReply+readQueryReply is = do     p <- readPacket is-    if isERR p-    then decodeFromPacket p >>= throwIO . ERRException-    else do-        len <- getFromPacket getLenEncInt p-        fields <- V.replicateM len $ (decodeFromPacket <=< readPacket) is-        _ <- readPacket is -- eof packet, we don't verify this though-        writeIORef consumed False-        rows <- Stream.makeInputStream $ do+    if  | isERR p -> decodeFromPacket p >>= throwIO . ERRException+        | isOK  p -> do+            ok <- decodeFromPacket p+            if isThereMore ok then readQueryReply is else pure WithoutResultSet+        | otherwise -> ResultSetColumns <$> getFromPacket getLenEncInt p++-- | The rows of a result-set, read as they are asked for, up to its EOF packet.+--+-- Once finished, also when 'finishAfterEOF' throws, further reads answer+-- Nothing rather than wait on the socket for packets that will never come.+resultSetRows :: InputStream Packet -> IORef Bool -> (Packet -> IO row) -> IO (InputStream row)+resultSetRows is consumed decodeRow = do+    finished <- newIORef False+    Stream.makeInputStream $ do+        alreadyFinished <- readIORef finished+        if alreadyFinished then pure Nothing else do             q <- readPacket is-            if  | isEOF q  -> writeIORef consumed True >> return Nothing-                | isERR q  -> decodeFromPacket q >>= throwIO . ERRException-                | otherwise -> Just <$> getFromPacket (getTextRowVector fields) q-        return (fields, rows)+            if  | isEOF q -> do+                    writeIORef finished True+                    writeIORef consumed True+                    finishAfterEOF is q+                    pure Nothing+                | isERR q -> decodeFromPacket q >>= throwIO . ERRException+                | otherwise -> Just <$> decodeRow q +-- | A binary-protocol row, whose packets start with 0x00 like an OK packet.+decodeBinaryRow :: Get row -> Packet -> IO row+decodeBinaryRow getRow q =+    if isOK q then getFromPacket getRow q else throwIO (UnexpectedPacket q)++-- | What followed a reply flagged SERVER_MORE_RESULTS_EXISTS.+data FurtherResults+    = OnlyOKs        -- ^ e.g. the closing OK of a CALL, or more INSERTs' OKs+    | SomeResultSet  -- ^ at least one result-set, which was discarded++-- | Finish a reply that ended in this 'OK', see 'skipFurtherResults'.+finishAfterOK :: InputStream Packet -> OK -> IO ()+finishAfterOK is ok =+    when (isThereMore ok) (skipFurtherResults OnlyOKs is >>= throwOnResultSet)++-- | Finish a result-set at its EOF packet, see 'skipFurtherResults'.+finishAfterEOF :: InputStream Packet -> Packet -> IO ()+finishAfterEOF is eofPacket = do+    eof <- decodeFromPacket eofPacket+    when (isThereMoreAfterEOF eof) (skipFurtherResults OnlyOKs is >>= throwOnResultSet)++-- | SERVER_MORE_RESULTS_EXISTS on a result-set's closing EOF packet.+isThereMoreAfterEOF :: EOF -> Bool+isThereMoreAfterEOF eof = eofStatus eof .&. 0x08 /= 0++-- | Read every result that follows a reply flagged SERVER_MORE_RESULTS_EXISTS.+--+-- The client asks for multi-statements and multi-results, so a CALL or a query+-- holding several statements gets one result per statement. Any left unread+-- would be taken by the next command as its own reply, shifting every later+-- query's results by one.+skipFurtherResults :: FurtherResults -> InputStream Packet -> IO FurtherResults+skipFurtherResults seen is = do+    p <- readPacket is+    if  | isERR p -> decodeFromPacket p >>= throwIO . ERRException+        | isOK  p -> do+            ok <- decodeFromPacket p+            if isThereMore ok then skipFurtherResults seen is else pure seen+        | otherwise -> do+            eof <- skipResultSet is p+            if isThereMoreAfterEOF eof+            then skipFurtherResults SomeResultSet is+            else pure SomeResultSet++-- | Read the result-set this column-count packet starts, returning its closing+-- EOF packet.+skipResultSet :: InputStream Packet -> Packet -> IO EOF+skipResultSet is columnCountPacket = do+    columnCount <- getFromPacket getLenEncInt columnCountPacket+    replicateM_ columnCount (readPacket is)+    _ <- readPacket is -- eof packet after the column definitions+    skipRows is++-- | Read a result-set's rows up to and including the EOF packet that ends them.+skipRows :: InputStream Packet -> IO EOF+skipRows is = do+    q <- readPacket is+    if  | isEOF q -> decodeFromPacket q+        | isERR q -> decodeFromPacket q >>= throwIO . ERRException+        | otherwise -> skipRows is++throwOnResultSet :: FurtherResults -> IO ()+throwOnResultSet further = case further of+    OnlyOKs -> pure ()+    SomeResultSet -> throwIO ExtraResultSets+ -- | Ask MySQL to prepare a query statement. -- prepareStmt :: MySQLConn -> Query -> IO StmtID@@ -265,31 +376,45 @@ -- executeStmt :: MySQLConn -> StmtID -> [MySQLValue] -> IO OK executeStmt conn stid params =-  command conn (COM_STMT_EXECUTE stid params (makeNullMap params))+  executeCommand conn (COM_STMT_EXECUTE stid params (makeNullMap params)) +-- | Send a statement that should answer with an 'OK' and read its whole reply,+-- see 'skipFurtherResults'. A result-set, also as the first reply (a SELECT or+-- a CALL running one), is read off the connection and raises 'ExtraResultSets',+-- unless a later statement fails: its 'ERRException' is raised instead.+executeCommand :: MySQLConn -> Command -> IO OK+executeCommand conn@(MySQLConn is os _ _) cmd = do+    guardUnconsumed conn+    writeCommand cmd os+    p <- readPacket is+    if  | isERR p -> decodeFromPacket p >>= throwIO . ERRException+        | isOK  p -> do+            ok <- decodeFromPacket p+            finishAfterOK is ok+            pure ok+        | otherwise -> do+            eof <- skipResultSet is p+            when (isThereMoreAfterEOF eof) (void (skipFurtherResults SomeResultSet is))+            throwIO ExtraResultSets+ -- | Execute prepared query statement with parameters, expecting resultset. ----- Rules about 'UnconsumedResultSet' applied here too.+-- Rules about 'UnconsumedResultSet' applied here too. A statement without a+-- result-set gives no columns and no rows; use 'executeStmt' to get its 'OK'. -- queryStmt :: MySQLConn -> StmtID -> [MySQLValue] -> IO ([ColumnDef], InputStream [MySQLValue]) queryStmt conn@(MySQLConn is os _ consumed) stid params = do     guardUnconsumed conn     writeCommand (COM_STMT_EXECUTE stid params (makeNullMap params)) os-    p <- readPacket is-    if isERR p-    then decodeFromPacket p >>= throwIO . ERRException-    else do-        len <- getFromPacket getLenEncInt p-        fields <- replicateM len $ (decodeFromPacket <=< readPacket) is-        _ <- readPacket is -- eof packet, we don't verify this though-        writeIORef consumed False-        rows <- Stream.makeInputStream $ do-            q <- readPacket is-            if  | isOK  q  -> Just <$> getFromPacket (getBinaryRow fields len) q-                | isEOF q  -> writeIORef consumed True >> return Nothing-                | isERR q  -> decodeFromPacket q >>= throwIO . ERRException-                | otherwise -> throwIO (UnexpectedPacket q)-        return (fields, rows)+    reply <- readQueryReply is+    case reply of+        WithoutResultSet -> (,) [] <$> Stream.nullInput+        ResultSetColumns len -> do+            fields <- replicateM len $ (decodeFromPacket <=< readPacket) is+            _ <- readPacket is -- eof packet, we don't verify this though+            writeIORef consumed False+            rows <- resultSetRows is consumed (decodeBinaryRow (getBinaryRow fields len))+            return (fields, rows)  -- | 'V.Vector' version of 'queryStmt' --@@ -299,21 +424,15 @@ queryStmtVector conn@(MySQLConn is os _ consumed) stid params = do     guardUnconsumed conn     writeCommand (COM_STMT_EXECUTE stid params (makeNullMap params)) os-    p <- readPacket is-    if isERR p-    then decodeFromPacket p >>= throwIO . ERRException-    else do-        len <- getFromPacket getLenEncInt p-        fields <- V.replicateM len $ (decodeFromPacket <=< readPacket) is-        _ <- readPacket is -- eof packet, we don't verify this though-        writeIORef consumed False-        rows <- Stream.makeInputStream $ do-            q <- readPacket is-            if  | isOK  q  -> Just <$> getFromPacket (getBinaryRowVector fields len) q-                | isEOF q  -> writeIORef consumed True >> return Nothing-                | isERR q  -> decodeFromPacket q >>= throwIO . ERRException-                | otherwise -> throwIO (UnexpectedPacket q)-        return (fields, rows)+    reply <- readQueryReply is+    case reply of+        WithoutResultSet -> (,) V.empty <$> Stream.nullInput+        ResultSetColumns len -> do+            fields <- V.replicateM len $ (decodeFromPacket <=< readPacket) is+            _ <- readPacket is -- eof packet, we don't verify this though+            writeIORef consumed False+            rows <- resultSetRows is consumed (decodeBinaryRow (getBinaryRowVector fields len))+            return (fields, rows)  -- | Run querys inside a transaction, querys will be rolled back if exception arise. --

@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE PackageImports #-}  {-| Module      : Database.MySQL.Connection@@ -18,7 +16,8 @@     ( module Database.MySQL.Connection     ) where -import           Control.Exception               (Exception, bracketOnError,+import           Control.Exception               (Exception (displayException),+                                                  bracketOnError,                                                   throwIO, catch, SomeException) import           Control.Monad import qualified Crypto.Hash                     as Crypto@@ -33,11 +32,7 @@ import qualified Data.Binary                     as Binary import qualified Data.Binary.Put                 as Binary import           Data.Bits-#if MIN_VERSION_crypton(1,1,0)-import qualified "ram" Data.ByteArray             as BA-#else-import qualified "memory" Data.ByteArray          as BA-#endif+import qualified Data.ByteArray                  as BA import           Data.ByteString                 (ByteString) import qualified Data.ByteString                 as B import qualified Data.ByteString.Lazy            as L@@ -468,4 +463,17 @@  data UnexpectedPacket = UnexpectedPacket Packet deriving (Typeable, Show) instance Exception UnexpectedPacket++-- | A statement produced a result set the function running it could not+-- return: @execute@ and @executeStmt@ return none, the query functions only the+-- first. It was read and discarded, so the connection is still usable.+--+-- @since 1.3.2+data ExtraResultSets = ExtraResultSets deriving (Typeable, Show)+instance Exception ExtraResultSets where+    displayException ExtraResultSets =+        "mysql-haskell: the statement produced a result set this function could not "+        ++ "return (execute_ and executeStmt return none, query_ and queryStmt only the "+        ++ "first). It was read and discarded, so the connection is still usable. Run "+        ++ "statements that return rows through a query function, one result set per call." 

@@ -5,7 +5,9 @@ import           System.Environment (lookupEnv) import           Test.Tasty (defaultMain, testGroup) import qualified CachingSha2+import qualified MultipleResults import qualified MysqlTests+import qualified QueryWithoutResultSet import qualified RoundtripBit import qualified RoundtripYear import qualified SelectOne@@ -32,6 +34,8 @@         , RoundtripBit.tests         , RoundtripYear.tests         , MysqlTests.tests+        , QueryWithoutResultSet.tests+        , MultipleResults.tests         ]         -- caching_sha2_password is MySQL 8.0+ only (MariaDB does not support it).         -- The sha2 test users are created by the nix CI config for the MySQL 8.0 VM.

@@ -0,0 +1,107 @@+-- | Statements whose reply holds several results: multi-statement strings and+-- CALLs. Whatever a function cannot hand back must still be read off the+-- connection, or the next query receives the previous one's leftovers.+module MultipleResults (tests) where++import           Control.Exception (try)+import           Data.Int          (Int64)+import           Database.MySQL.Base+import qualified System.IO.Streams as Stream+import           System.Timeout    (timeout)+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "statements with several results"+    [ testCase "query_ with two INSERTs" $ withTable $ \c -> do+        (_, rows) <- query_ c+            "INSERT INTO several_results VALUES (1); INSERT INTO several_results VALUES (2)"+        Stream.skipToEof rows+        assertRowCount c 2+    , testCase "execute_ with two INSERTs" $ withTable $ \c -> do+        _ <- execute_ c+            "INSERT INTO several_results VALUES (1); INSERT INTO several_results VALUES (2)"+        assertRowCount c 2+    , testCase "execute_ with a SELECT" $ withTable $ \c ->+        assertExtraResultSets c (execute_ c "SELECT COUNT(*) FROM several_results")+    , testCase "executeStmt with a SELECT" $ withTable $ \c -> do+        stmt <- prepareStmt c "SELECT COUNT(*) FROM several_results"+        assertExtraResultSets c (executeStmt c stmt [])+    , testCase "execute_ with a CALL returning one result set" $ withTable $ \c -> do+        _ <- execute_ c "DROP PROCEDURE IF EXISTS one_result_set"+        _ <- execute_ c "CREATE PROCEDURE one_result_set() SELECT COUNT(*) FROM several_results"+        assertExtraResultSets c (execute_ c "CALL one_result_set()")+    , testCase "query_ with a CALL returning one result set" $ withTable $ \c -> do+        _ <- execute_ c "DROP PROCEDURE IF EXISTS one_result_set"+        _ <- execute_ c "CREATE PROCEDURE one_result_set() SELECT COUNT(*) FROM several_results"+        (_, rows) <- query_ c "CALL one_result_set()"+        counts <- Stream.toList rows+        assertEqual "rows of the procedure's SELECT" [[MySQLInt64 0]] counts+        assertRowCount c 0+    , testCase "query_ with an INSERT before a SELECT" $ withTable $ \c -> do+        (_, rows) <- query_ c+            "INSERT INTO several_results VALUES (1); SELECT COUNT(*) FROM several_results"+        counts <- Stream.toList rows+        assertEqual "rows of the SELECT" [[MySQLInt64 1]] counts+        assertRowCount c 1+    , testCase "query_ with two SELECTs" $ withTable $ \c -> do+        (_, rows) <- query_ c+            "SELECT COUNT(*) FROM several_results; SELECT COUNT(*) FROM several_results"+        outcome <- try (Stream.toList rows)+        case outcome of+            Left ExtraResultSets -> pure ()+            Right _ -> assertFailure "the second SELECT's result set went unreported"+        again <- Stream.read rows+        assertEqual "reading the finished rows again" Nothing again+        assertRowCount c 0+    , testCase "query_ with a failing statement after a SELECT" $ withTable $ \c -> do+        (_, rows) <- query_ c+            "SELECT COUNT(*) FROM several_results; SELECT * FROM no_such_table"+        assertERRException c (Stream.toList rows)+    , testCase "execute_ with a failing statement after a SELECT" $ withTable $ \c ->+        assertERRException c+            (execute_ c "SELECT COUNT(*) FROM several_results; SELECT * FROM no_such_table")+    ]++-- | Generous for a few statements on an empty temporary table, and short enough+-- that a hang fails the suite instead of stalling CI.+replyTimeLimitMicroseconds :: Int+replyTimeLimitMicroseconds = 10000000++-- | Runs a case on a fresh connection with an empty temporary table.+withTable :: (MySQLConn -> Assertion) -> Assertion+withTable body = do+    (_, c) <- connectDetail defaultConnectInfo+        { ciUser = "testMySQLHaskell"+        , ciDatabase = "testMySQLHaskell"+        }+    _ <- execute_ c "CREATE TEMPORARY TABLE several_results (__id INT)"+    finished <- timeout replyTimeLimitMicroseconds (body c)+    case finished of+        Nothing -> assertFailure "blocked for 10 s waiting for a reply"+        Just () -> close c++-- | The statement must raise 'ExtraResultSets' and leave the connection in step.+assertExtraResultSets :: MySQLConn -> IO OK -> Assertion+assertExtraResultSets c runStatement = do+    outcome <- try runStatement+    case outcome of+        Left ExtraResultSets -> pure ()+        Right _ -> assertFailure "the result set went unreported"+    assertRowCount c 0++-- | The failing statement's error must come from this call, not the next one.+assertERRException :: MySQLConn -> IO a -> Assertion+assertERRException c runStatement = do+    outcome <- try runStatement+    case outcome of+        Left (ERRException _) -> pure ()+        Right _ -> assertFailure "the failing statement's error went unreported"+    assertRowCount c 0++-- | The connection must be back in step: a fresh query gets its own rows.+assertRowCount :: MySQLConn -> Int64 -> Assertion+assertRowCount c expected = do+    (_, rows) <- query_ c "SELECT COUNT(*) FROM several_results"+    counts <- Stream.toList rows+    assertEqual "rows of the next query" [[MySQLInt64 expected]] counts

@@ -0,0 +1,60 @@+-- | Statements without a result set (INSERT, UPDATE, DELETE) sent through the+-- functions that expect one. The server answers with a lone OK packet, which+-- used to leave these functions blocked forever waiting for column+-- definitions that never come (issue #47).+module QueryWithoutResultSet (tests) where++import           Database.MySQL.Base+import qualified Data.Vector       as V+import qualified System.IO.Streams as Stream+import           System.Timeout    (timeout)+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "query functions given an INSERT"+    [ testCase "query_" $ assertEmptyResultSet $ \c -> do+        (columns, rows) <- query_ c "INSERT INTO without_result_set VALUES (1)"+        rowList <- Stream.toList rows+        pure (length columns, length rowList)+    , testCase "queryVector_" $ assertEmptyResultSet $ \c -> do+        (columns, rows) <- queryVector_ c "INSERT INTO without_result_set VALUES (1)"+        rowList <- Stream.toList rows+        pure (V.length columns, length rowList)+    , testCase "queryStmt" $ assertEmptyResultSet $ \c -> do+        stmt <- prepareStmt c "INSERT INTO without_result_set VALUES (?)"+        (columns, rows) <- queryStmt c stmt [MySQLInt32 1]+        rowList <- Stream.toList rows+        pure (length columns, length rowList)+    , testCase "queryStmtVector" $ assertEmptyResultSet $ \c -> do+        stmt <- prepareStmt c "INSERT INTO without_result_set VALUES (?)"+        (columns, rows) <- queryStmtVector c stmt [MySQLInt32 1]+        rowList <- Stream.toList rows+        pure (V.length columns, length rowList)+    ]++-- | Generous for one INSERT into an empty temporary table, and short enough+-- that a hang fails the suite instead of stalling CI.+replyTimeLimitMicroseconds :: Int+replyTimeLimitMicroseconds = 10000000++-- | Runs the insert on a fresh connection; it reports the column and row counts+-- of the result set it got back. Both must be zero, the row must be inserted+-- exactly once, and the connection must stay usable afterwards.+assertEmptyResultSet :: (MySQLConn -> IO (Int, Int)) -> Assertion+assertEmptyResultSet runInsert = do+    (_, c) <- connectDetail defaultConnectInfo+        { ciUser = "testMySQLHaskell"+        , ciDatabase = "testMySQLHaskell"+        }+    _ <- execute_ c "CREATE TEMPORARY TABLE without_result_set (__id INT)"+    outcome <- timeout replyTimeLimitMicroseconds (runInsert c)+    case outcome of+        Nothing -> assertFailure+            "blocked for 10 s waiting for a result set the server never sends"+        Just columnsAndRows -> do+            assertEqual "columns and rows returned" (0, 0) columnsAndRows+            (_, rows) <- query_ c "SELECT COUNT(*) FROM without_result_set"+            counts <- Stream.toList rows+            assertEqual "the row was inserted once" [[MySQLInt64 1]] counts+    close c