diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -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 diff --git a/src/Database/MySQL/Base.hs b/src/Database/MySQL/Base.hs --- a/src/Database/MySQL/Base.hs +++ b/src/Database/MySQL/Base.hs @@ -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. -- diff --git a/src/Database/MySQL/Connection.hs b/src/Database/MySQL/Connection.hs --- a/src/Database/MySQL/Connection.hs +++ b/src/Database/MySQL/Connection.hs @@ -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." diff --git a/test/Integration.hs b/test/Integration.hs --- a/test/Integration.hs +++ b/test/Integration.hs @@ -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. diff --git a/test/MultipleResults.hs b/test/MultipleResults.hs new file mode 100644 --- /dev/null +++ b/test/MultipleResults.hs @@ -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 diff --git a/test/QueryWithoutResultSet.hs b/test/QueryWithoutResultSet.hs new file mode 100644 --- /dev/null +++ b/test/QueryWithoutResultSet.hs @@ -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