mysql-haskell 1.3.2 → 1.4.0

raw patch · 62 files changed

+6029/−499 lines, 62 filesdep +unwitchdep ~basedep ~bytestringdep ~cryptonPVP ok

version bump matches the API change (PVP)

Dependencies added: unwitch

Dependency ranges changed: base, bytestring, crypton, io-streams, scientific, text, tls, vector

API changes (from Hackage documentation)

Files

• ChangeLog.md +84/−0
• README.md +33/−7
• mysql-haskell.cabal +74/−5
• src/Database/MariaDB.hs +354/−0
• src/Database/MySQL/Base.hs +372/−55
• src/Database/MySQL/BinLog.hs +139/−38
• src/Database/MySQL/BinLogProtocol/BinLogEvent.hs +100/−3
• src/Database/MySQL/Connection.hs +247/−79
• src/Database/MySQL/Decoder.hs +843/−0
• src/Database/MySQL/Field.hs +11/−2
• src/Database/MySQL/Protocol/Auth.hs +105/−8
• src/Database/MySQL/Protocol/ColumnDef.hs +54/−11
• src/Database/MySQL/Protocol/FloatingPoint.hs +185/−0
• src/Database/MySQL/Protocol/MySQLValue.hs +549/−83
• src/Database/MySQL/Protocol/Packet.hs +58/−9
• src/Database/MySQL/Protocol/RawRow.hs +231/−0
• src/Database/MySQL/Query.hs +97/−2
• src/Database/MySQL/TLS.hs +44/−44
• test/AbandonedReplies.hs +51/−0
• test/BinLogEventCodes.hs +59/−0
• test/BinLogRowEvents.hs +119/−0
• test/BinaryRow.hs +17/−12
• test/BinaryRowNew.hs +12/−7
• test/BoundsCheck.hs +52/−17
• test/CABundle.hs +14/−0
• test/CachingSha2.hs +5/−4
• test/DecoderRoundtrip.hs +179/−0
• test/DirectDecoding.hs +323/−0
• test/FloatingPoint.hs +40/−0
• test/FloatingPointText.hs +59/−0
• test/HandshakeGolden.hs +95/−0
• test/Integration.hs +48/−13
• test/IntegrationMariaDB.hs +19/−0
• test/LargeRows.hs +28/−0
• test/Latin1Results.hs +36/−0
• test/Main.hs +20/−0
• test/MariaDBBulk.hs +82/−0
• test/MariaDBExtendedMetadata.hs +96/−0
• test/MariaDBNegotiation.hs +92/−0
• test/MultipleResults.hs +70/−15
• test/MysqlTests.hs +15/−12
• test/PacketClassification.hs +36/−0
• test/PlaceholderLiterals.hs +18/−0
• test/Placeholders.hs +38/−0
• test/QueryApi.hs +136/−0
• test/QueryWithoutResultSet.hs +11/−6
• test/ResultCharsets.hs +46/−0
• test/RoundtripBit.hs +6/−5
• test/RoundtripYear.hs +7/−6
• test/RowDecoderQueries.hs +144/−0
• test/SelectOne.hs +4/−3
• test/TLSConnection.hs +6/−5
• test/TestUser.hs +12/−0
• test/TextRow.hs +16/−11
• test/TextRowDecoding.hs +203/−0
• test/TextRowNew.hs +13/−8
• test/TypedValue.hs +38/−0
• test/UnixSocket.hs +6/−5
• test/UnsignedInsertId.hs +29/−0
• test/Word24.hs +29/−24
• test/ZeroDateRoundtrip.hs +73/−0
• test/ZeroDates.hs +47/−0

@@ -1,5 +1,89 @@ # Revision history for mysql-haskell +## 1.4.0 -- 2026.11.11++Fixes for MySQL and MariaDB alike, found comparing mysql-haskell with the+mariadb-haskell fork, and faster row decoding. A text query no longer loses a+row whose first value is 16 MiB or longer; insert IDs above 2^63 come back+intact; a `?` inside a quoted string or a comment is no longer taken for a+placeholder; dates such as `0000-00-00` round-trip instead of turning into+`0000-01-01`; latin1 results decode; FLOAT and DOUBLE values in exponent form+no longer lose their exponent through `query_` (`1e20` came back as 1); the+binlog row decoder no longer drops a statement's rows events after its first;+and the Mozilla CA bundle is installed with the library. `query_` and+`queryStmt` resolve each column's type once per result set, and the new+`Database.MySQL.Decoder` decodes rows straight into Haskell values with typed+errors through `queryRows_`, `queryRows` and `queryStmtRows`, or by column+number through `queryRawRows_` and `queryStmtRawRows`.++New in `Database.MariaDB`, for MariaDB servers only: connections that ask for+capabilities only MariaDB has. Extended column metadata names JSON, UUID, INET6+and geometry columns through `prepareStmtMetadata`, and `executeBulk` runs a+prepared statement for many parameter rows in one round trip, several times+faster than `executeMany`. Its connect functions refuse a MySQL server with+`NotMariaDB`; `mysqlConnection` gives the underlying connection for everything+in `Database.MySQL.Base`. Connections made with `Database.MySQL.Base` send the+same handshake as before.++Upgrading can break code. `okLastInsertID` is a `Word64`. `MySQLValue` gains+`MySQLDateRaw`, `MySQLDateTimeRaw` and `MySQLTimeStampRaw` for dates a `Day`+cannot hold, `DecodeError` gains `DecodeUnrepresentableDate`, and+`BinLogEventType` gains `BINLOG_UNRECOGNIZED_EVENT` and loses its `Enum`+instance (use `binLogEventTypeCode`). A connection whose reply was interrupted,+for example by a timeout, now refuses further commands with `AbandonedReply`+instead of handing the rest of that reply to the next query (#10); discard it+and reconnect. `resetStmt` with rows still unread raises `UnconsumedResultSet`,+`withTransaction` rethrows the procedure's own exception, and+`decodeRowBinLogEvent` raises `RowEventDecodeException` on an event that may+hold rows it cannot decode, such as MySQL's compressed transactions, where it+used to crash or skip it. `Database.MySQL.Base` now also exports the five new+query functions and re-exports `Database.MySQL.Protocol.RawRow`, which can clash+with same-named definitions under an unqualified import.++It needs GHC 9.6 or newer, for the new `unwitch` dependency, and bytestring+0.11.2; projects on older compilers keep resolving to 1.3.3.++* Fix eight defects for MySQL and MariaDB, each with a reproducer+  [#102](https://github.com/winterland1989/mysql-haskell/pull/102)+* Faster row decoding, decoders straight into Haskell values, and FLOAT and+  DOUBLE in exponent form read correctly+  [#98](https://github.com/winterland1989/mysql-haskell/pull/98)+* A MariaDB module with capability negotiation and extended column metadata+  [#100](https://github.com/winterland1989/mysql-haskell/pull/100)+* MariaDB bulk execution with NULL, DEFAULT and IGNORE parameters+  [#101](https://github.com/winterland1989/mysql-haskell/pull/101)+* `Database.MariaDB` for MariaDB servers only, with `mysqlConnection` for the+  MySQL functions [#104](https://github.com/winterland1989/mysql-haskell/pull/104)+* Allow crypton 2.2 and tls 2.5+  [#105](https://github.com/winterland1989/mysql-haskell/pull/105)+* Examples for `executeBulk` and the functions that decode rows without+  `MySQLValue` [#106](https://github.com/winterland1989/mysql-haskell/pull/106)+* A comparison with the mariadb-haskell fork and a plan to adopt its+  features, in `docs/`+  [#99](https://github.com/winterland1989/mysql-haskell/pull/99)+* Benchmark figures re-measured on current hardware+  [#95](https://github.com/winterland1989/mysql-haskell/pull/95)+* A profile of where the CPU time goes, in `benchmark/`+  [#96](https://github.com/winterland1989/mysql-haskell/pull/96)++## 1.3.3 -- 2026.10.07++New functions, and fixes to `executeMany` and `executeMany_` for inputs that+left 1.3.2's connection out of step. `queryMulti_` and `queryMulti` return every+result of a CALL or a multi-statement query in order: each result set with its+columns and rows, and each statement's `OK`.++`executeMany` and `executeMany_` now read the whole reply. A statement that+returns rows raises `ExtraResultSets`, where 1.3.2 threw `UnexpectedPacket` or+left the rows for the next command. A query with several statements per+parameter set gives one `OK` per statement, where 1.3.2 returned one per+parameter set and left the rest. `executeMany` with no parameter sets returns+`[]` without contacting the server, where 1.3.2 sent an empty query whose error+reached the next command.+++ Every result set of a CALL or multi-statement query through `queryMulti_`+  [#94](https://github.com/winterland1989/mysql-haskell/pull/94)+ ## 1.3.2 -- 2026.10.07  Requires crypton 2.0 or newer, the first crypton with the timing side-channel

@@ -10,16 +10,26 @@ Is it fast? ---------- -In short, `select`(decode) is about 1.5 times slower than pure c/c++ but 5 times faster than `mysql-simple`, `insert` (encode) is about 1.5 times slower than pure c/c++, there're many factors involved(tls, prepared statment, batch using multiple statement):+In short, reading is as fast as the C client (`libmysqlclient`) on one connection and up to 1.7 times slower with ten connections in parallel, and 5 to 8 times faster than `mysql-simple`. Writing one statement at a time is 1.2 to 1.4 times slower than C, and on par with C through `executeMany`. -<img src="https://github.com/jappeace/mysql-pure/blob/master/benchmark/result.png?raw=true" width="100%">+Median wall time in milliseconds over 10 runs, for 1 to 10 threads that each use their own connection: -Above figures showed the time to:+| threads                                   |   1 |   2 |   3 |   4 |   10 |+|-------------------------------------------|----:|----:|----:|----:|-----:|+| libmysqlclient select                     |  76 |  80 |  88 | 108 |  178 |+| mysql-haskell select                      |  80 |  95 | 106 | 130 |  309 |+| mysql-haskell select over TLS (`tls`)     | 120 | 130 | 148 | 172 |  436 |+| libmysqlclient select, prepared           |  82 |  86 |  94 | 120 |  179 |+| mysql-haskell select, prepared            |  77 |  88 | 102 | 124 |  275 |+| mysql-simple select                       | 462 | 504 | 578 | 698 | 2399 |+| libmysqlclient insert                     |  29 |  30 |  36 |  38 |   62 |+| mysql-haskell insert                      |  40 |  40 |  45 |  46 |   76 |+| mysql-haskell insert, `executeMany`       |  27 |  29 |  36 |  37 |   63 |+| mysql-haskell insert, prepared            |  38 |  38 |  45 |  46 |   82 | -* perform a "select * from employees" from a [sample table](https://github.com/datacharmer/test_db)-* insert 1000 rows into a 29-columns table per thread with auto-commit off.+Each thread either reads all 300,024 rows of the [sample employees table](https://github.com/datacharmer/test_db) with `select * from employees`, or inserts 1000 rows into a 29-column table with auto-commit off. The programs are the ones in `benchmark/`. They ran on mysql-haskell 1.3.3 with GHC 9.10.3 and `+RTS -N4`, against MySQL 8.0.45 and its own client library (mysql-simple goes through MariaDB Connector/C 3.3.5), with TLS off unless stated, on an AMD Ryzen AI 7 350 (October 2026). The server kept its data in RAM, so the inserts measure the clients rather than the disk. -The benchmarks are run by my MacBook Pro 13' 2015.+Leave the allocation area (`-A`) at its default when running with several capabilities: `-A128M` with `-N4` makes the runtime fault in a 128 MB allocation area for each capability it touches, which costs 35 to 280 ms per run in these benchmarks on every GHC version tried. Since GHC 8.2 it touches all four even when one thread does the work, where GHC 8.0, used for the 2016 figures this README showed until 2026, touched one or two. Without the flag, mysql-haskell 0.6.0.0 and 1.3.3 run plain and prepared selects equally fast, and 1.3.3 is 1.4 to 1.6 times faster over TLS.  Motivation ----------@@ -69,6 +79,20 @@  If you want to do batch inserting/deleting/updating, you can use `executeMany` to save considerable time. +To decode rows straight into your own types, skipping `MySQLValue`, give `queryRows_`, `queryRows` or `queryStmtRows` a decoder from `Database.MySQL.Decoder`. Each column is checked against its decoder once, before the first row:++```haskell+import qualified Database.MySQL.Decoder as Decode++data Person = Person { name :: Text, age :: Word32 }++person :: Decode.RowDecoder Person+person = Person <$> Decode.field Decode.text <*> Decode.field Decode.word32++    ...+    (defs, people) <- queryRows_ person conn "SELECT name, person_age FROM some_table"+```+ The `Database.MySQL.BinLog` module provides binlog listenning functions and row-based event decoder, following program will automatically get last binlog position, and print every row event it receives:  ```haskell@@ -135,9 +159,11 @@ + Modify `bench.sh`(change the include path) to get c++ version compiled. + Modify `mysql-pure-bench.cabal`(change the openssl's lib path) to get haskell version compiled. + Setup MySQL's TLS support, modify `MySQLHaskellOpenSSL.hs/MySQLHaskellTLS.hs` to change the CA file's path, and certificate's subject name.-+ Adjust rts options `-N` to get best results.++ Adjust rts options `-N` to get best results, and leave `-A` at its default (see "Is it fast?").  With `-N10` on my company's 24-core machine, binary protocol performs almost identical to c version!++The `.cabal` files in `benchmark/` date from 2016 and no longer build; the figures in "Is it fast?" came from the same programs compiled against the current library.  Reference ---------

@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               mysql-haskell-version:            1.3.2+version:            1.4.0 synopsis:           pure haskell MySQL driver description:        pure haskell MySQL driver. license:            BSD-3-Clause@@ -11,8 +11,10 @@ category:           Database build-type:         Simple extra-doc-files:    ChangeLog.md+-- mozillaCAStorePath reads the bundle through getDataFileName, which only+-- finds files cabal installs: data-files, not extra-source-files.+data-files:         mozillaCAStore.pem extra-source-files:-  mozillaCAStore.pem   README.md   test/cert/ca-key.pem   test/cert/ca.pem@@ -64,19 +66,23 @@     Data.Int.Int24     Data.TLSSetting     Data.Word.Word24+    Database.MariaDB     Database.MySQL.Base     Database.MySQL.BinLog     Database.MySQL.BinLogProtocol.BinLogEvent     Database.MySQL.BinLogProtocol.BinLogMeta     Database.MySQL.BinLogProtocol.BinLogValue     Database.MySQL.Connection+    Database.MySQL.Decoder     Database.MySQL.Field     Database.MySQL.Protocol.Auth     Database.MySQL.Protocol.ColumnDef     Database.MySQL.Protocol.Command     Database.MySQL.Protocol.Escape+    Database.MySQL.Protocol.FloatingPoint     Database.MySQL.Protocol.MySQLValue     Database.MySQL.Protocol.Packet+    Database.MySQL.Protocol.RawRow     Database.MySQL.TLS     System.IO.Streams.TCP     System.IO.Streams.TLS@@ -90,7 +96,8 @@     asn1-types >=0.3 && <0.4,     binary >=0.8.3 && <0.9,     blaze-textual >=0.2 && <0.3,-    bytestring >=0.10.2.0 && <0.12 || ^>=0.12.0,+    -- 0.11.2 added isValidUtf8, which checks a string column's bytes.+    bytestring >=0.11.2 && <0.12 || ^>=0.12.0,     bytestring-lexing >=0.5 && <0.6,     crypton-x509 >=1.5 && <2.0,     crypton-x509-store >=1.5 && <2.0,@@ -104,17 +111,24 @@     scientific >=0.3 && <0.4,     text >=1.1 && <2.1 || ^>=2.1,     time >=1.5.0 && <1.12 || ^>=1.12.2 || ^>=1.14,-    tls >=1.7.0 && <1.8 || ^>=1.8.0 || ^>=1.9.0 || ^>=2.0.0 || ^>=2.1.0 || ^>=2.2.0 || ^>=2.3.0 || ^>=2.4.0,+    tls >=1.7.0 && <1.8 || ^>=1.8.0 || ^>=1.9.0 || ^>=2.0.0 || ^>=2.1.0 || ^>=2.2.0 || ^>=2.3.0 || ^>=2.4.0 || ^>=2.5.0,     vector >=0.8 && <0.13 || ^>=0.13.0,     word-compat >=0.0 && <0.1 +  -- Decision: numeric conversions go through unwitch's named functions, which+  -- return Maybe where a conversion can lose information, instead of+  -- fromIntegral, which wraps silently. Its base >=4.18 matches the CI matrix+  -- (GHC 9.6 and up).+  build-depends:+    unwitch ^>=3.1+   -- 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,+    crypton ^>=2.0.0 || ^>=2.1.0 || ^>=2.2.0,     ram >=0.20 && <0.23    default-extensions:@@ -131,17 +145,28 @@   other-modules:     Aeson     AesonBP+    BinLogEventCodes     BoundsCheck+    DecoderRoundtrip+    DirectDecoding     FieldRoundtrip+    FloatingPointText+    HandshakeGolden     JSON+    PacketClassification+    Placeholders     QC.ByteString     QC.Combinator     QC.Common     Orphans+    ResultCharsets     Sha1Scramble     Sha256Scramble     TCPStreams+    TextRowDecoding+    TypedValue     Word24+    ZeroDates    hs-source-dirs:     test   build-depends:@@ -177,22 +202,36 @@   type:               exitcode-stdio-1.0   main-is:            Integration.hs   other-modules:+    AbandonedReplies     BinaryRow     BinaryRowNew     BinLog     BinLogNew+    BinLogRowEvents+    CABundle     CachingSha2     ExecuteMany+    FloatingPoint+    LargeRows+    Latin1Results+    MariaDBNegotiation     MultipleResults     MysqlTests+    PlaceholderLiterals+    QueryApi     QueryWithoutResultSet     RoundtripBit+    RowDecoderQueries     RoundtripYear     SelectOne+    TestUser     TextRow     TLSConnection     TextRowNew+    TypedValue     UnixSocket+    UnsignedInsertId+    ZeroDateRoundtrip    hs-source-dirs:     test   build-depends:@@ -201,10 +240,40 @@     directory,     io-streams,     mysql-haskell,+    scientific,     tasty >=0.11 && <2.0,     tasty-hunit < 1.0,     text,     time,+    vector++  default-extensions:+    MultiWayIf+    OverloadedStrings++  ghc-options:        -threaded+  default-language:   Haskell2010++test-suite integration-mariadb+  type:               exitcode-stdio-1.0+  main-is:            IntegrationMariaDB.hs+  other-modules:+    MariaDBBulk+    MariaDBExtendedMetadata+    QueryApi+    TypedValue+    UnixSocket++  hs-source-dirs:     test+  build-depends:+    base,+    bytestring >=0.10,+    directory,+    io-streams,+    mysql-haskell,+    tasty >=0.11 && <2.0,+    tasty-hunit < 1.0,+    text,     vector    default-extensions:

@@ -0,0 +1,354 @@+{-|+Module      : Database.MariaDB+Description : MariaDB-only protocol features+License     : BSD+Stability   : experimental+Portability : PORTABLE++Features only MariaDB servers have, such as extended column metadata and bulk+execution. They rely on MariaDB's own protocol extensions, so this module+works with MariaDB servers only: its connect functions refuse a server that+does not speak them, MySQL or MariaDB before 10.2, with 'NotMariaDB'.++The functions here take a 'MariaDBConn', so they cannot be given a connection+to MySQL. A 'MariaDBConn' wraps an ordinary 'MySQLConn': use+'mysqlConnection' for everything in "Database.MySQL.Base".++A MariaDB server that does not offer a requested capability is not an error.+The connection is made without it, 'mariadbCapabilities' says what was agreed,+and a function that needs the missing capability raises+'CapabilityNotNegotiated'.++@since 1.4.0+-}+module Database.MariaDB+    ( -- * Capabilities+      MariaDBCapability(..)+      -- * Connections+    , MariaDBConn+    , mysqlConnection+    , mariadbGreeting+    , mariadbCapabilities+    , connectMariaDB+    , connectMariaDBUnixSocket+    , connectMariaDBTLS+      -- * Extended column metadata+    , ColumnMetadata(..)+    , ExtendedMetadata(..)+    , prepareStmtMetadata+      -- * Bulk execution+    , BulkParam(..)+    , executeBulk+    , BulkExecuteError(..)+      -- * Exceptions+    , NotMariaDB(..)+    , CapabilityNotNegotiated(..)+    ) where++import           Control.Exception              (Exception (displayException), throwIO)+import           Control.Monad                  (forM_, replicateM, unless, void)+import           Data.Binary.Get                (Get, getWord8, isEmpty)+import           Data.Binary.Put                (Put, putLazyByteString, putWord16le, putWord32le,+                                                 putWord8, runPut)+import           Data.Binary.Parser             (parseOnly)+import           Data.Bits                      ((.&.), (.|.))+import           Data.ByteString                (ByteString)+import qualified Data.ByteString.Lazy           as L+import           Data.List                      (nub, transpose)+import           Data.List.NonEmpty             (NonEmpty ((:|)))+import qualified Data.List.NonEmpty             as NonEmpty+import           Data.Word                      (Word32, Word8)+import           Database.MySQL.Base+import qualified Database.MySQL.Connection      as Connection+import qualified Database.MySQL.TLS             as TLS+import qualified Network.TLS                    as Network.TLS++-- | A capability only MariaDB servers offer. Only capabilities whose replies+-- this library can read are listed, since asking for one changes what the+-- server sends.+data MariaDBCapability+    = MariaDBExtendedMetadata+      -- ^ MARIADB_CLIENT_EXTENDED_METADATA: column definitions name types+      -- such as JSON or UUID, see 'prepareStmtMetadata'.+    | MariaDBBulkOperations+      -- ^ MARIADB_CLIENT_STMT_BULK_OPERATIONS: 'executeBulk'.+    deriving (Show, Eq, Ord, Enum, Bounded)++-- | Bits 32 to 63 of the capability flags, see+-- Note [MariaDB extended capabilities] in "Database.MySQL.Protocol.Auth".+capabilityBit :: MariaDBCapability -> Word32+capabilityBit MariaDBExtendedMetadata = 0x08  -- 1 << (35 - 32)+capabilityBit MariaDBBulkOperations   = 0x04  -- 1 << (34 - 32)++capabilityBits :: [MariaDBCapability] -> ExtendedCapabilities+capabilityBits = ExtendedCapabilities . foldr ((.|.) . capabilityBit) 0++negotiatedCapabilities :: ExtendedCapabilities -> [MariaDBCapability]+negotiatedCapabilities (ExtendedCapabilities bits) =+    filter (\capability -> bits .&. capabilityBit capability /= 0) [minBound .. maxBound]++-- | A connection together with the MariaDB capabilities it negotiated.+data MariaDBConn = MariaDBConn+    { mysqlConnection     :: !MySQLConn+      -- ^ The underlying connection, for everything in "Database.MySQL.Base";+      -- closing it closes the 'MariaDBConn'.+    , mariadbGreeting     :: !Greeting+    , mariadbCapabilities :: ![MariaDBCapability]+      -- ^ Those asked for that the server offered.+    }++hasCapability :: MariaDBCapability -> MariaDBConn -> Bool+hasCapability capability conn = capability `elem` mariadbCapabilities conn++-- | 'Database.MySQL.Base.connect' asking for these capabilities. Raises+-- 'NotMariaDB', after closing the connection, when the server does not speak+-- MariaDB's protocol extensions (MySQL, or MariaDB before 10.2).+connectMariaDB :: [MariaDBCapability] -> ConnectInfo -> IO MariaDBConn+connectMariaDB requested ci =+    Connection.connectDetailExtended (capabilityBits requested) ci >>= mariadbConn++-- | 'Database.MySQL.Base.connectUnixSocket' asking for these capabilities, and+-- refusing a MySQL server as 'connectMariaDB' does.+connectMariaDBUnixSocket :: [MariaDBCapability] -> FilePath -> ConnectInfo -> IO MariaDBConn+connectMariaDBUnixSocket requested socketPath ci =+    Connection.connectUnixSocketDetailExtended (capabilityBits requested) socketPath ci >>= mariadbConn++-- | 'Database.MySQL.TLS.connect' asking for these capabilities, and refusing a+-- MySQL server as 'connectMariaDB' does.+connectMariaDBTLS :: [MariaDBCapability] -> ConnectInfo -> (Network.TLS.ClientParams, String) -> IO MariaDBConn+connectMariaDBTLS requested ci tlsParams =+    TLS.connectDetailExtended (capabilityBits requested) ci tlsParams >>= mariadbConn++-- | Refuses a server whose greeting does not announce MariaDB's protocol+-- extensions, after closing the connection. The greeting's capabilities decide+-- this, not its version string, which @mariadbd --version@ can set to anything.+mariadbConn :: (Greeting, ExtendedCapabilities, MySQLConn) -> IO MariaDBConn+mariadbConn (greeting, negotiated, conn) =+    if offersExtendedCapabilities greeting+    then pure (MariaDBConn conn greeting (negotiatedCapabilities negotiated))+    else do+        close conn+        throwIO (NotMariaDB (greetingVersion greeting))++-- | A column definition with the MariaDB extended metadata the server sent+-- for it.+data ColumnMetadata = ColumnMetadata+    { columnDefinition :: !ColumnDef+    , columnExtended   :: ![ExtendedMetadata]+      -- ^ Empty for columns of ordinary types.+    } deriving (Show, Eq)++-- | One entry of a column's extended metadata.+data ExtendedMetadata+    = ExtendedTypeName !ByteString+      -- ^ The SQL type behind a generic wire type, e.g. @uuid@ or @inet6@.+    | ExtendedFormat !ByteString+      -- ^ How a value is formatted, e.g. @json@ for a JSON column sent as a+      -- string.+    | ExtendedUnrecognised !Word8 !ByteString+      -- ^ An entry kind newer than this library, kept as sent.+    deriving (Show, Eq)++-- | Parse a column definition from a connection with+-- 'MariaDBExtendedMetadata', or without it, giving no extended metadata.+getColumnMetadata :: Get ColumnMetadata+getColumnMetadata = do+    (column, block) <- getFieldExtended+    case parseOnly getExtendedEntries block of+        Left err      -> fail ("MariaDB extended column metadata: " ++ err)+        Right entries -> pure (ColumnMetadata column entries)++getExtendedEntries :: Get [ExtendedMetadata]+getExtendedEntries = do+    done <- isEmpty+    if done then pure [] else (:) <$> getExtendedEntry <*> getExtendedEntries++getExtendedEntry :: Get ExtendedMetadata+getExtendedEntry = extendedEntry <$> getWord8 <*> getLenEncBytes++extendedEntry :: Word8 -> ByteString -> ExtendedMetadata+extendedEntry kind = if+    | kind == 0 -> ExtendedTypeName+    | kind == 1 -> ExtendedFormat+    | otherwise -> ExtendedUnrecognised kind++-- | 'Database.MySQL.Base.prepareStmtDetail' with the extended metadata of+-- every parameter and result column. Use the returned statement with the+-- usual functions of "Database.MySQL.Base".+--+-- Raises 'CapabilityNotNegotiated' without 'MariaDBExtendedMetadata', as the+-- server then sends no extended metadata to return.+--+-- Decision: offered for prepared statements only. A text query variant needs+-- the result-set reader that "Database.MySQL.Base" keeps internal, and+-- preparing a query is how a caller learns its column types up front anyway.+prepareStmtMetadata :: MariaDBConn -> Query -> IO (StmtPrepareOK, [ColumnMetadata], [ColumnMetadata])+prepareStmtMetadata conn (Query stmt) = do+    requireCapability MariaDBExtendedMetadata conn+    let mysqlConn = mysqlConnection conn+        is = Connection.mysqlRead mysqlConn+    Connection.guardUnconsumed mysqlConn+    Connection.writeCommand (COM_STMT_PREPARE stmt) (Connection.mysqlWrite mysqlConn)+    p <- Connection.readPacket is+    if isERR p+    then decodeFromPacket p >>= throwIO . ERRException+    else do+        prepared@(StmtPrepareOK _ columnCount paramCount _) <- getFromPacket getStmtPrepareOK p+        params <- replicateM paramCount (Connection.readPacket is >>= getFromPacket getColumnMetadata)+        unless (paramCount == 0) (void (Connection.readPacket is))  -- EOF+        columns <- replicateM columnCount (Connection.readPacket is >>= getFromPacket getColumnMetadata)+        unless (columnCount == 0) (void (Connection.readPacket is))  -- EOF+        pure (prepared, params, columns)++-- | One parameter of one row given to 'executeBulk'.+data BulkParam+    = BulkValue !MySQLValue+      -- ^ 'MySQLNull' sends SQL NULL.+    | BulkDefault+      -- ^ The column's default, for INSERT and UPDATE.+    | BulkIgnore+      -- ^ The column's default for INSERT; UPDATE leaves the column as it is.+    deriving (Show, Eq)++-- | Rows 'executeBulk' refuses before sending anything, so the connection+-- stays usable.+data BulkExecuteError+    = BulkNoParameters+      -- ^ The rows have no parameters; a bulk command sends parameter rows.+    | BulkRowWidth !Int !Int !Int+      -- ^ Row number (counting from 0), the first row's width, this row's width.+    | BulkMixedTypes !Int ![MySQLValue]+      -- ^ Parameter number (counting from 0) and one value of each type found+      -- there. The command declares one type per parameter for every row.+    deriving (Show, Eq)++instance Exception BulkExecuteError where+    displayException err = "mysql-haskell: executeBulk: " ++ case err of+        BulkNoParameters -> "the rows have no parameters"+        BulkRowWidth row expected found ->+            "row " ++ show row ++ " has " ++ show found ++ " parameters, the first row has " ++ show expected+        BulkMixedTypes param examples ->+            "parameter " ++ show param ++ " mixes value types " ++ show examples+            ++ "; give every row the same MySQLValue constructor there"++-- | Execute a prepared statement once per row in a single round trip+-- (COM_STMT_BULK_EXECUTE). The 'OK' sums the affected rows of every+-- execution. A statement that returns rows is refused by the server with an+-- 'ERRException'.+--+-- Every row must have the same number of parameters, and each parameter the+-- same 'MySQLValue' constructor in every row where it is a 'BulkValue' other+-- than 'MySQLNull', or 'BulkExecuteError' is raised. Raises+-- 'CapabilityNotNegotiated' without 'MariaDBBulkOperations'; MySQL has no+-- bulk command.+--+-- The rows travel in one command, which the server's @max_allowed_packet@+-- limits; split larger inputs over several calls.+--+-- > import Data.List.NonEmpty (NonEmpty ((:|)))+-- >+-- > conn <- connectMariaDB [MariaDBBulkOperations] defaultConnectInfo+-- > let mysqlConn = mysqlConnection conn+-- > _ <- execute_ mysqlConn "CREATE TABLE people (name VARCHAR(20), age INT DEFAULT 18)"+-- > insert <- prepareStmt mysqlConn "INSERT INTO people (name, age) VALUES (?, ?)"+-- > ok <- executeBulk conn insert+-- >     (  [BulkValue (MySQLText "Ada"),   BulkValue (MySQLInt32 36)]+-- >     :| [ [BulkValue (MySQLText "Alan"),  BulkValue MySQLNull]  -- age NULL+-- >        , [BulkValue (MySQLText "Grace"), BulkDefault]          -- age 18+-- >        ])+-- > okAffectedRows ok  -- 3+executeBulk :: MariaDBConn -> StmtID -> NonEmpty [BulkParam] -> IO OK+executeBulk conn stid rows = do+    requireCapability MariaDBBulkOperations conn+    types <- either throwIO pure (bulkParamTypes rows)+    let mysqlConn = mysqlConnection conn+        is = Connection.mysqlRead mysqlConn+    Connection.guardUnconsumed mysqlConn+    Connection.writePayload (runPut (putBulkExecute stid types rows)) (Connection.mysqlWrite mysqlConn)+    p <- Connection.readPacket is+    if  | isERR p -> decodeFromPacket p >>= throwIO . ERRException+        | isOK  p -> decodeFromPacket p+        | otherwise -> throwIO (UnexpectedPacket p)++-- | The type each parameter is declared with: that of its values, or NULL's+-- when every row sends NULL, DEFAULT or IGNORE there.+bulkParamTypes :: NonEmpty [BulkParam] -> Either BulkExecuteError [L.ByteString]+bulkParamTypes rows@(firstRow :| _) =+    if null firstRow+    then Left BulkNoParameters+    else do+        mapM_ (checkRowWidth (length firstRow)) (zip [0 ..] (NonEmpty.toList rows))+        mapM paramType (zip [0 ..] (transpose (NonEmpty.toList rows)))++checkRowWidth :: Int -> (Int, [BulkParam]) -> Either BulkExecuteError ()+checkRowWidth expected (row, params) =+    if length params == expected then Right () else Left (BulkRowWidth row expected (length params))++paramType :: (Int, [BulkParam]) -> Either BulkExecuteError L.ByteString+paramType (param, column) =+    let values = concatMap typedValue column+        typed = nubOn (runPut . putParamMySQLType) values+    in case typed of+        []      -> Right (runPut (putParamMySQLType MySQLNull))+        [value] -> Right (runPut (putParamMySQLType value))+        (_ : _ : _) -> Left (BulkMixedTypes param typed)++typedValue :: BulkParam -> [MySQLValue]+typedValue (BulkValue MySQLNull) = []+typedValue (BulkValue value)     = [value]+typedValue BulkDefault           = []+typedValue BulkIgnore            = []++-- | One value per distinct key, in order of first appearance.+nubOn :: Eq key => (value -> key) -> [value] -> [value]+nubOn key values =+    let keys = nub (map key values)+    in concatMap (\k -> take 1 (filter ((== k) . key) values)) keys++-- Decision: always send the parameter types (SEND_TYPES_TO_SERVER, 128), as+-- mariadb-connector-c does. The server keeps no types from an earlier+-- COM_STMT_EXECUTE that a bulk command could rely on. Per-row results+-- (SEND_UNIT_RESULTS) need MARIADB_CLIENT_BULK_UNIT_RESULTS, which MariaDB+-- 11.4, the version CI runs, does not offer.+putBulkExecute :: StmtID -> [L.ByteString] -> NonEmpty [BulkParam] -> Put+putBulkExecute stid types rows = do+    putWord8 0xfa+    putWord32le stid+    putWord16le 128+    mapM_ putLazyByteString types+    forM_ rows (mapM_ putBulkParam)++putBulkParam :: BulkParam -> Put+putBulkParam (BulkValue MySQLNull) = putWord8 1+putBulkParam (BulkValue value)     = putWord8 0 >> putBinaryField value+putBulkParam BulkDefault           = putWord8 2+putBulkParam BulkIgnore            = putWord8 3++requireCapability :: MariaDBCapability -> MariaDBConn -> IO ()+requireCapability capability conn =+    unless (hasCapability capability conn) (throwIO (CapabilityNotNegotiated capability))++-- | A function needed a capability the connection did not negotiate, because+-- it was not asked for in 'connectMariaDB' or the server's MariaDB version+-- does not offer it.+newtype CapabilityNotNegotiated = CapabilityNotNegotiated MariaDBCapability+    deriving Show++instance Exception CapabilityNotNegotiated where+    displayException (CapabilityNotNegotiated capability) =+        "mysql-haskell: this function needs the MariaDB capability " ++ show capability+        ++ ", which the connection did not negotiate. Ask for it in connectMariaDB,"+        ++ " on a MariaDB version that offers it."++-- | A connect function of this module reached a server that does not speak+-- MariaDB's protocol extensions: MySQL, or MariaDB before 10.2. Carries the+-- server's version string.+newtype NotMariaDB = NotMariaDB ByteString+    deriving Show++instance Exception NotMariaDB where+    displayException (NotMariaDB version) =+        "mysql-haskell: Database.MariaDB needs a server speaking MariaDB's protocol"+        ++ " extensions, but server " ++ show version ++ " set CLIENT_MYSQL in its"+        ++ " greeting, as MySQL servers and MariaDB before 10.2 do. Connect with"+        ++ " Database.MySQL.Base for those servers, or upgrade to MariaDB 10.2 or later."

@@ -16,6 +16,8 @@      * 'NetworkException':  underline network is broken.     * 'UnconsumedResultSet':  you should consume previous resultset before sending new command.+    * 'AbandonedReply': reading an earlier reply stopped part-way, e.g. on a timeout;+      connect again.     * 'ERRException':  you receive a 'ERR' packet when you shouldn't.     * 'UnexpectedPacket':  you receive a unexpected packet when you shouldn't.     * 'DecodePacketException': there's a packet we can't decode.@@ -47,6 +49,9 @@     , queryVector_     , query     , queryVector+    , queryMulti_+    , queryMulti+    , StatementResult(..)       -- * Prepared query statement     , prepareStmt     , prepareStmtDetail@@ -55,6 +60,15 @@     , queryStmtVector     , closeStmt     , resetStmt+      -- * Decoding rows without 'MySQLValue'+      -- | Rows decoded straight into Haskell values with the decoders of+      -- "Database.MySQL.Decoder", or handed over raw for libraries that decode+      -- by column number.+    , queryRows_+    , queryRows+    , queryStmtRows+    , queryRawRows_+    , queryStmtRawRows       -- * Helpers     , withTransaction     , QueryParam(..)@@ -66,6 +80,7 @@       -- * Exceptions     , NetworkException(..)     , UnconsumedResultSet(..)+    , AbandonedReply(..)     , ERRException(..)     , UnexpectedPacket(..)     , DecodePacketException(..)@@ -77,25 +92,33 @@     , module  Database.MySQL.Protocol.ColumnDef     , module  Database.MySQL.Protocol.Packet     , module  Database.MySQL.Protocol.MySQLValue+    , module  Database.MySQL.Protocol.RawRow     ) where -import           Control.Exception                  (mask, onException, throwIO)+import           Control.Exception                  (SomeException, catch, fromException,+                                                     mask, onException, throwIO) import           Control.Monad-import           Data.Binary                        (Get) import           Data.Bits                          ((.&.))+import           Data.ByteString                    (ByteString)+import qualified Data.ByteString                    as B import qualified Data.ByteString.Lazy               as L import           Data.IORef                         (IORef, newIORef, readIORef, writeIORef)+import           Data.Maybe                         (isJust)+import           Data.Proxy                         (Proxy (..)) import           Database.MySQL.Connection+import qualified Database.MySQL.Decoder             as Decoder import           Database.MySQL.Protocol.Auth import           Database.MySQL.Protocol.ColumnDef import           Database.MySQL.Protocol.Command import           Database.MySQL.Protocol.MySQLValue import           Database.MySQL.Protocol.Packet+import           Database.MySQL.Protocol.RawRow  import           Database.MySQL.Query import           System.IO.Streams                  (InputStream) import qualified System.IO.Streams                  as Stream import qualified Data.Vector                        as V+import qualified Unwitch.Convert.Int                as Int  -------------------------------------------------------------------------------- @@ -117,14 +140,22 @@ -- you may want to use 'withTransaction' to make sure it's atomic, and -- use @sum . map okAffectedRows@ to get all affected rows count. --+-- The result holds one 'OK' per statement, so a query with several statements+-- gives several per parameter set. A statement that returns rows raises+-- 'ExtraResultSets' once the whole reply has been read; 'queryMulti' returns+-- those. No parameter sets gives @[]@ without contacting the server.+-- -- @since 0.2.0.0 -- executeMany :: QueryParam p => MySQLConn -> Query -> [[p]] -> IO [OK]-executeMany conn@(MySQLConn is os _ _) qry paramsList = do-    guardUnconsumed conn-    let qry' = L.intercalate ";" $ map (fromQuery . renderParams qry) paramsList-    writeCommand (COM_QUERY qry') os-    mapM (\ _ -> waitCommandReply is) paramsList+executeMany conn@(MySQLConn is os _ _) qry paramsList =+    case paramsList of+        -- Joining no statements would send an empty query, which the server refuses.+        [] -> guardUnconsumed conn >> pure []+        _ : _ -> runCommand conn $ do+            let qry' = L.intercalate ";" $ map (fromQuery . renderParams qry) paramsList+            writeCommand (COM_QUERY qry') os+            readStatementResults is >>= onlyOKs  {-# SPECIALIZE executeMany :: MySQLConn -> Query -> [[MySQLValue]] -> IO [OK] #-} {-# SPECIALIZE executeMany :: MySQLConn -> Query -> [[Param]]      -> IO [OK] #-}@@ -134,13 +165,15 @@ -- This's useful when your want to execute multiple SQLs without params, e.g. from a -- SQL dump, or a table migration plan. --+-- A statement that returns rows raises 'ExtraResultSets' once the whole reply+-- has been read; 'queryMulti_' returns those.+-- -- @since 0.8.4.0 -- executeMany_ :: MySQLConn -> Query -> IO [OK]-executeMany_ conn@(MySQLConn is os _ _) qry = do-    guardUnconsumed conn+executeMany_ conn@(MySQLConn is os _ _) qry = runCommand conn $ do     writeCommand (COM_QUERY (fromQuery qry)) os-    waitCommandReplys is+    readStatementResults is >>= onlyOKs  -- | Execute a MySQL query which don't return a result-set. --@@ -178,8 +211,7 @@ -- 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+query_ conn@(MySQLConn is os _ state) (Query qry) = runCommand conn $ do     writeCommand (COM_QUERY qry) os     reply <- readQueryReply is     case reply of@@ -187,8 +219,8 @@         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))+            writeIORef state RowsUnread+            rows <- resultSetRows is state (decodeTextRowPacket (map columnKind fields))             return (fields, rows)  -- | 'V.Vector' version of 'query_'.@@ -196,8 +228,7 @@ -- @since 0.5.1.0 -- queryVector_ :: MySQLConn -> Query -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue))-queryVector_ conn@(MySQLConn is os _ consumed) (Query qry) = do-    guardUnconsumed conn+queryVector_ conn@(MySQLConn is os _ state) (Query qry) = runCommand conn $ do     writeCommand (COM_QUERY qry) os     reply <- readQueryReply is     case reply of@@ -205,10 +236,241 @@         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))+            writeIORef state RowsUnread+            rows <- resultSetRows is state (decodeTextRowVectorPacket (V.map columnKind fields))             return (fields, rows) +-- | 'query_' with each row decoded by a 'Decoder.RowDecoder' instead of into+-- 'MySQLValue's. The decoder is checked against the column definitions before+-- any row is read: a result set it does not fit raises 'Decoder.ColumnMismatch'.+-- A field that does not decode raises 'Decoder.FieldError' when its row is read.+-- Either way the remaining rows are skipped first, so the connection stays+-- usable.+--+-- A statement without a result-set, such as an INSERT, gives no columns and no+-- rows, as with 'query_'.+--+-- > import qualified Database.MySQL.Decoder as Decode+-- > import qualified System.IO.Streams as Streams+-- >+-- > data Employee = Employee { number :: Int32, born :: Day, name :: Text }+-- >+-- > employee :: Decode.RowDecoder Employee+-- > employee = Employee+-- >     <$> Decode.field Decode.int32+-- >     <*> Decode.field Decode.day+-- >     <*> Decode.field Decode.text+-- >+-- > (_, rows) <- queryRows_ employee conn "SELECT emp_no, birth_date, first_name FROM employees"+-- > employees <- Streams.toList rows+--+-- @since 1.4.0+queryRows_ :: Decoder.RowDecoder a -> MySQLConn -> Query -> IO ([ColumnDef], InputStream a)+queryRows_ decoder conn qry =+    queryRowBodies_ conn qry >>= decodeRowBodies (Proxy :: Proxy TextProtocol) decoder++-- | 'queryRows_' with parameters, filled in as 'query' does. With the+-- @employee@ decoder from 'queryRows_':+--+-- > (_, rows) <- queryRows employee conn+-- >     "SELECT emp_no, birth_date, first_name FROM employees WHERE first_name = ?"+-- >     [MySQLText "Georgi"]+-- > georgis <- Streams.toList rows+--+-- @since 1.4.0+queryRows :: QueryParam p => Decoder.RowDecoder a -> MySQLConn -> Query -> [p] -> IO ([ColumnDef], InputStream a)+queryRows decoder conn qry params = queryRows_ decoder conn (renderParams qry params)++{-# SPECIALIZE queryRows :: Decoder.RowDecoder a -> MySQLConn -> Query -> [MySQLValue] -> IO ([ColumnDef], InputStream a) #-}+{-# SPECIALIZE queryRows :: Decoder.RowDecoder a -> MySQLConn -> Query -> [Param]      -> IO ([ColumnDef], InputStream a) #-}++-- | 'queryStmt' with each row decoded by a 'Decoder.RowDecoder', as+-- 'queryRows_' does. With the @employee@ decoder from 'queryRows_':+--+-- > statement <- prepareStmt conn+-- >     "SELECT emp_no, birth_date, first_name FROM employees WHERE emp_no > ?"+-- > (_, rows) <- queryStmtRows employee conn statement [MySQLInt32 10001]+-- > later <- Streams.toList rows+--+-- @since 1.4.0+queryStmtRows :: Decoder.RowDecoder a -> MySQLConn -> StmtID -> [MySQLValue] -> IO ([ColumnDef], InputStream a)+queryStmtRows decoder conn stid params =+    queryStmtRowBodies conn stid params >>= decodeRowBodies (Proxy :: Proxy BinaryProtocol) decoder++decodeRowBodies :: forall protocol a. Decoder.RowProtocol protocol+                => Proxy protocol -> Decoder.RowDecoder a -> ([ColumnDef], InputStream ByteString)+                -> IO ([ColumnDef], InputStream a)+decodeRowBodies _ decoder (fields, bodies) = case fields of+    [] -> (,) [] <$> Stream.nullInput+    _  -> case Decoder.prepareRowDecoder @protocol decoder (V.fromList fields) of+        Left mismatch  -> Stream.skipToEof bodies >> throwIO mismatch+        Right prepared -> (,) fields <$> Stream.mapM (decodeRowBody prepared bodies) bodies++-- | A row that does not decode skips the rest first, so the connection stays+-- usable.+decodeRowBody :: Decoder.PreparedRow protocol a -> InputStream ByteString -> ByteString -> IO a+decodeRowBody prepared bodies row = case Decoder.runPreparedRow prepared row of+    Left fieldError -> Stream.skipToEof bodies >> throwIO fieldError+    Right value     -> pure value++-- | 'query_' handing each row over as a 'RawRow', with the bounds of its+-- fields, for libraries that decode by column number with+-- 'Decoder.prepareFieldParser' and 'Decoder.runFieldParser'. A parser is+-- prepared once per column from its definition, then run on every row; it+-- passes the field to a continuation instead of returning an 'Either':+--+-- > import qualified Database.MySQL.Decoder as Decode+-- > import qualified System.IO.Streams as Streams+-- >+-- > (columns, rows) <- queryRawRows_ conn "SELECT emp_no, first_name FROM employees"+-- > numberColumn : nameColumn : _ <- pure columns+-- > numbers <- either throwIO pure (Decode.prepareFieldParser Decode.int32 (ColumnNumber 0) numberColumn)+-- > names <- either throwIO pure (Decode.prepareFieldParser Decode.text (ColumnNumber 1) nameColumn)+-- > rawRows <- Streams.toList rows+-- > forM_ rawRows $ \row ->+-- >     Decode.runFieldParser numbers row (ColumnNumber 0) throwIO $ \number ->+-- >     Decode.runFieldParser names row (ColumnNumber 1) throwIO $ \name ->+-- >     print (number, name)+--+-- @since 1.4.0+queryRawRows_ :: MySQLConn -> Query -> IO ([ColumnDef], InputStream (RawRow TextProtocol))+queryRawRows_ conn qry = do+    (fields, bodies) <- queryRowBodies_ conn qry+    (,) fields <$> Stream.mapM (rawRowOrThrow (textRawRow (length fields))) bodies++-- | 'queryStmt' handing each row over as a 'RawRow', as 'queryRawRows_' does.+-- The parsers are prepared and run the same way; they read the binary+-- protocol's fields because the rows are 'RawRow' 'BinaryProtocol':+--+-- > statement <- prepareStmt conn "SELECT emp_no, first_name FROM employees WHERE emp_no > ?"+-- > (columns, rows) <- queryStmtRawRows conn statement [MySQLInt32 10001]+-- > numberColumn : nameColumn : _ <- pure columns+-- > numbers <- either throwIO pure (Decode.prepareFieldParser Decode.int32 (ColumnNumber 0) numberColumn)+-- > names <- either throwIO pure (Decode.prepareFieldParser Decode.text (ColumnNumber 1) nameColumn)+-- > rawRows <- Streams.toList rows+-- > forM_ rawRows $ \row ->+-- >     Decode.runFieldParser numbers row (ColumnNumber 0) throwIO $ \number ->+-- >     Decode.runFieldParser names row (ColumnNumber 1) throwIO $ \name ->+-- >     print (number, name)+--+-- @since 1.4.0+queryStmtRawRows :: MySQLConn -> StmtID -> [MySQLValue] -> IO ([ColumnDef], InputStream (RawRow BinaryProtocol))+queryStmtRawRows conn stid params = do+    (fields, bodies) <- queryStmtRowBodies conn stid params+    (,) fields <$> Stream.mapM (rawRowOrThrow (binaryRawRow (V.fromList (map binaryWidth fields)))) bodies++rawRowOrThrow :: (ByteString -> Either RowError (RawRow protocol)) -> ByteString -> IO (RawRow protocol)+rawRowOrThrow toRawRow row = either (throwRowError row) pure (toRawRow row)++-- | The bodies of a text-protocol result set's row packets.+queryRowBodies_ :: MySQLConn -> Query -> IO ([ColumnDef], InputStream ByteString)+queryRowBodies_ conn@(MySQLConn is os _ state) (Query qry) = runCommand conn $ do+    writeCommand (COM_QUERY qry) os+    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 state RowsUnread+            rows <- resultSetRows is state (pure . L.toStrict . pBody)+            return (fields, rows)++-- | The bodies of a prepared statement's row packets.+queryStmtRowBodies :: MySQLConn -> StmtID -> [MySQLValue] -> IO ([ColumnDef], InputStream ByteString)+queryStmtRowBodies conn@(MySQLConn is os _ state) stid params = runCommand conn $ do+    writeCommand (COM_STMT_EXECUTE stid params (makeNullMap params)) os+    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 state RowsUnread+            rows <- resultSetRows is state binaryRowBody+            return (fields, rows)++-- | A binary-protocol row, whose packets start with 0x00 like an OK packet.+binaryRowBody :: Packet -> IO ByteString+binaryRowBody packet =+    if isOK packet then pure (L.toStrict (pBody packet)) else throwIO (UnexpectedPacket packet)++-- | One result of a statement run through 'queryMulti_'.+--+-- @since 1.3.3+data StatementResult+    = StatementOK OK                            -- ^ a statement without rows, e.g. an INSERT+    | StatementRows [ColumnDef] [[MySQLValue]]  -- ^ a result-set+    deriving (Show, Eq)++-- | Execute a MySQL query and return every result it produces, in order: one per+-- statement of a multi-statement query, and for a CALL one per result-set the+-- procedure returns followed by the CALL's own 'OK'.+--+-- Unlike 'query_' the rows are read up front, as each result-set has to be read+-- off the connection before the next one arrives. A failing statement raises its+-- 'ERRException'; the server runs no statement after it.+--+-- @since 1.3.3+queryMulti_ :: MySQLConn -> Query -> IO [StatementResult]+queryMulti_ conn@(MySQLConn is os _ _) (Query qry) = runCommand conn $ do+    writeCommand (COM_QUERY qry) os+    readStatementResults is++-- | 'queryMulti_' with parameters, filled in as 'query' does.+--+-- @since 1.3.3+queryMulti :: QueryParam p => MySQLConn -> Query -> [p] -> IO [StatementResult]+queryMulti conn qry params = queryMulti_ conn (renderParams qry params)++{-# SPECIALIZE queryMulti :: MySQLConn -> Query -> [MySQLValue] -> IO [StatementResult] #-}+{-# SPECIALIZE queryMulti :: MySQLConn -> Query -> [Param]      -> IO [StatementResult] #-}++-- | Read a reply's results until one comes without SERVER_MORE_RESULTS_EXISTS.+readStatementResults :: InputStream Packet -> IO [StatementResult]+readStatementResults is = do+    p <- readPacket is+    if  | isERR p -> decodeFromPacket p >>= throwIO . ERRException+        | isOK  p -> do+            ok <- decodeFromPacket p+            if isThereMore ok+            then (StatementOK ok :) <$> readStatementResults is+            else pure [StatementOK ok]+        | otherwise -> do+            (result, eof) <- readResultSet is p+            if isThereMoreAfterEOF eof+            then (result :) <$> readStatementResults is+            else pure [result]++-- | Read the text-protocol result-set this column-count packet starts, with the+-- EOF packet that closes it.+readResultSet :: InputStream Packet -> Packet -> IO (StatementResult, EOF)+readResultSet is columnCountPacket = do+    columnCount <- getFromPacket getLenEncInt columnCountPacket+    fields <- replicateM columnCount ((decodeFromPacket <=< readPacket) is)+    _ <- readPacket is -- eof packet after the column definitions+    (rows, eof) <- readTextRows (map columnKind fields) [] is+    pure (StatementRows fields rows, eof)++-- | Read text-protocol rows up to the EOF packet that ends them; the rows read+-- so far are kept in reverse.+readTextRows :: [ColumnKind] -> [[MySQLValue]] -> InputStream Packet -> IO ([[MySQLValue]], EOF)+readTextRows columns earlierRows is = do+    q <- readPacket is+    if  | isEOF q -> (,) (reverse earlierRows) <$> decodeFromPacket q+        | isERR q -> decodeFromPacket q >>= throwIO . ERRException+        | otherwise -> do+            row <- decodeTextRowPacket columns q+            readTextRows columns (row : earlierRows) is++-- | The 'OK's of a reply that should hold nothing else; a result-set among them+-- raises 'ExtraResultSets', after the whole reply has been read.+onlyOKs :: [StatementResult] -> IO [OK]+onlyOKs results = case results of+    [] -> pure []+    StatementOK ok : rest -> (ok :) <$> onlyOKs rest+    StatementRows _ _ : _ -> throwIO ExtraResultSets+ -- | How the server answered a statement sent through a query function. data QueryReply     = WithoutResultSet      -- ^ only OK packets, e.g. for an INSERT@@ -234,30 +496,73 @@             if isThereMore ok then readQueryReply is else pure WithoutResultSet         | otherwise -> ResultSetColumns <$> getFromPacket getLenEncInt p +-- | A text-protocol row packet decoded with 'decodeTextRow', raising+-- 'DecodePacketFailed' as 'getFromPacket' does.+decodeTextRowPacket :: [ColumnKind] -> Packet -> IO [MySQLValue]+decodeTextRowPacket columns packet = do+    let row = L.toStrict (pBody packet)+    either (throwRowError row) pure (decodeTextRow columns row)++-- | 'V.Vector' version of 'decodeTextRowPacket'.+decodeTextRowVectorPacket :: V.Vector ColumnKind -> Packet -> IO (V.Vector MySQLValue)+decodeTextRowVectorPacket columns packet = do+    let row = L.toStrict (pBody packet)+    either (throwRowError row) pure (decodeTextRowVector columns row)++throwRowError :: ByteString -> RowError -> IO a+throwRowError row rowError =+    throwIO (DecodePacketFailed (B.drop offset row) (Int.toInt64 offset)+                                (describeRowError rowError))+  where+    offset = rowErrorOffset rowError+ -- | 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+-- A read stopped part-way leaves the connection at 'ReplyAbandoned', see+-- Note [Abandoned replies].+resultSetRows :: InputStream Packet -> IORef ReplyState -> (Packet -> IO row) -> IO (InputStream row)+resultSetRows is state decodeRow = do     finished <- newIORef False-    Stream.makeInputStream $ do+    Stream.makeInputStream $ mask $ \restore -> do         alreadyFinished <- readIORef finished-        if alreadyFinished then pure Nothing else do-            q <- readPacket is-            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+        current <- readIORef state+        if  | alreadyFinished -> pure Nothing+            | current == ReplyAbandoned -> throwIO AbandonedReply+            | otherwise -> restore (nextRow is state finished decodeRow)+                `catch` settleFailedRowRead state finished --- | 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)+nextRow :: InputStream Packet -> IORef ReplyState -> IORef Bool -> (Packet -> IO row) -> IO (Maybe row)+nextRow is state finished decodeRow = do+    q <- readPacket is+    if  | isEOF q -> do+            writeIORef finished True+            finishAfterEOF is q+            writeIORef state RepliesRead+            pure Nothing+        | isERR q -> decodeFromPacket q >>= throwIO . ERRException+        | otherwise -> Just <$> decodeRow q +-- | Like 'settleFailedExchange', and a row that failed to decode was still+-- read in full, so the rest of the rows can be read or skipped.+settleFailedRowRead :: IORef ReplyState -> IORef Bool -> SomeException -> IO a+settleFailedRowRead state finished failure = do+    if  | endsReply failure -> writeIORef finished True >> writeIORef state RepliesRead+        | isJust (fromException failure :: Maybe DecodePacketException) -> pure ()+        | otherwise -> writeIORef state ReplyAbandoned+    throwIO failure++-- | A binary-protocol row, whose packets start with 0x00 like an OK packet. A+-- row that does not decode raises 'DecodePacketFailed', as it did when rows+-- were decoded with 'getBinaryRow'.+binaryValuesPacket :: Decoder.BinaryValueColumns -> Packet -> IO [MySQLValue]+binaryValuesPacket columns packet = do+    row <- binaryRowBody packet+    case Decoder.decodeBinaryValues columns row of+        Left fieldError -> throwIO (DecodePacketFailed row 0 (show fieldError))+        Right values    -> pure values+ -- | What followed a reply flagged SERVER_MORE_RESULTS_EXISTS. data FurtherResults     = OnlyOKs        -- ^ e.g. the closing OK of a CALL, or more INSERTs' OKs@@ -322,8 +627,7 @@ -- | Ask MySQL to prepare a query statement. -- prepareStmt :: MySQLConn -> Query -> IO StmtID-prepareStmt conn@(MySQLConn is os _ _) (Query stmt) = do-    guardUnconsumed conn+prepareStmt conn@(MySQLConn is os _ _) (Query stmt) = runCommand conn $ do     writeCommand (COM_STMT_PREPARE stmt) os     p <- readPacket is     if isERR p@@ -342,8 +646,7 @@ -- params's 'ColumnDef', result's 'ColumnDef'. -- prepareStmtDetail :: MySQLConn -> Query -> IO (StmtPrepareOK, [ColumnDef], [ColumnDef])-prepareStmtDetail conn@(MySQLConn is os _ _) (Query stmt) = do-    guardUnconsumed conn+prepareStmtDetail conn@(MySQLConn is os _ _) (Query stmt) = runCommand conn $ do     writeCommand (COM_STMT_PREPARE stmt) os     p <- readPacket is     if isERR p@@ -362,15 +665,18 @@ closeStmt (MySQLConn _ os _ _) stid = do     writeCommand (COM_STMT_CLOSE stid) os --- | Ask MySQL to reset a query statement, all previous resultset will be cleared.+-- | Ask MySQL to reset a query statement: discard the data sent for its+-- parameters and close its cursor. --+-- It does not discard a result-set the statement returned: the server has+-- already sent its rows, so they must be read or skipped first, or this throws+-- 'UnconsumedResultSet'.+-- resetStmt :: MySQLConn -> StmtID -> IO ()-resetStmt (MySQLConn is os _ consumed) stid = do-    writeCommand (COM_STMT_RESET stid) os  -- previous result-set may still be unconsumed+resetStmt conn@(MySQLConn is os _ _) stid = runCommand conn $ do+    writeCommand (COM_STMT_RESET stid) os     p <- readPacket is-    if isERR p-    then decodeFromPacket p >>= throwIO . ERRException-    else writeIORef consumed True+    when (isERR p) (decodeFromPacket p >>= throwIO . ERRException)  -- | Execute prepared query statement with parameters, expecting no resultset. --@@ -383,8 +689,7 @@ -- 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+executeCommand conn@(MySQLConn is os _ _) cmd = runCommand conn $ do     writeCommand cmd os     p <- readPacket is     if  | isERR p -> decodeFromPacket p >>= throwIO . ERRException@@ -403,8 +708,7 @@ -- 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+queryStmt conn@(MySQLConn is os _ state) stid params = runCommand conn $ do     writeCommand (COM_STMT_EXECUTE stid params (makeNullMap params)) os     reply <- readQueryReply is     case reply of@@ -412,8 +716,8 @@         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))+            writeIORef state RowsUnread+            rows <- resultSetRows is state (binaryValuesPacket (Decoder.binaryValueColumns fields))             return (fields, rows)  -- | 'V.Vector' version of 'queryStmt'@@ -421,8 +725,7 @@ -- @since 0.5.1.0 -- queryStmtVector :: MySQLConn -> StmtID -> [MySQLValue] -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue))-queryStmtVector conn@(MySQLConn is os _ consumed) stid params = do-    guardUnconsumed conn+queryStmtVector conn@(MySQLConn is os _ state) stid params = runCommand conn $ do     writeCommand (COM_STMT_EXECUTE stid params (makeNullMap params)) os     reply <- readQueryReply is     case reply of@@ -430,17 +733,31 @@         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))+            writeIORef state RowsUnread+            rows <- resultSetRows is state+                (fmap V.fromList . binaryValuesPacket (Decoder.binaryValueColumns (V.toList fields)))             return (fields, rows)  -- | Run querys inside a transaction, querys will be rolled back if exception arise. --+-- The procedure's exception is the one rethrown. When the connection cannot+-- take the ROLLBACK, because the procedure left a result-set unread or was+-- interrupted mid-reply, it is left at 'AbandonedReply' instead, and the server+-- rolls the transaction back when the connection closes.+-- -- @since 0.2.0.0 -- withTransaction :: MySQLConn -> IO a -> IO a withTransaction conn procedure = mask $ \restore -> do   _ <- execute_ conn "BEGIN"-  r <- restore procedure `onException` (execute_ conn "ROLLBACK")+  r <- restore procedure `onException` rollbackOrAbandon conn   _ <- execute_ conn "COMMIT"   pure r++rollbackOrAbandon :: MySQLConn -> IO ()+rollbackOrAbandon conn@(MySQLConn _ _ _ state) = do+  current <- readIORef state+  case current of+    RepliesRead -> void (execute_ conn "ROLLBACK")+    RowsUnread -> writeIORef state ReplyAbandoned+    ReplyAbandoned -> pure ()

@@ -18,6 +18,7 @@     , dumpBinLog     , RowBinLogEvent(..)     , decodeRowBinLogEvent+    , RowEventDecodeException(..)     -- * helpers     , getLastBinLogTracker     , isCheckSumEnabled@@ -28,13 +29,15 @@     , module Database.MySQL.BinLogProtocol.BinLogMeta     ) where -import           Control.Exception                         (throwIO)+import           Control.Exception                         (Exception (..),+                                                            throwIO) import           Control.Monad import           Data.Binary.Put import           Data.ByteString                           (ByteString) import           Data.IORef                                (IORef, newIORef,                                                             readIORef,                                                             writeIORef)+import           Data.Bits                                 ((.&.)) import           Data.Text.Encoding                        (encodeUtf8) import           Data.Word import           Database.MySQL.Base@@ -71,7 +74,7 @@                                       -- if master doesn't support, this parameter will be ignored.            -> IO (FormatDescription, IORef ByteString, InputStream BinLogPacket)                 -- ^ 'FormatDescription', 'IORef' contains current binlog filename, 'BinLogPacket' stream.-dumpBinLog conn@(MySQLConn is wp _ consumed) sid (BinLogTracker initfn initpos) wantAck = do+dumpBinLog conn@(MySQLConn is wp _ state) sid (BinLogTracker initfn initpos) wantAck = do     guardUnconsumed conn     checksum <- isCheckSumEnabled conn     when checksum $ void $ execute_ conn "SET @master_binlog_checksum = @@global.binlog_checksum"@@ -79,7 +82,7 @@     let needAck = semiAck && wantAck     when needAck . void $ execute_ conn "SET @rpl_semi_sync_slave = 1"     writeCommand (COM_BINLOG_DUMP initpos 0x00 sid initfn) wp-    writeIORef consumed False+    writeIORef state RowsUnread      rp <- skipToPacketT (readBinLogPacket checksum needAck is) BINLOG_ROTATE_EVENT     re <- getFromBinLogPacket getRotateEvent rp@@ -92,7 +95,7 @@     es <- Stream.makeInputStream $ do         q <- readBinLogPacket checksum needAck is         case q of-            Nothing   -> writeIORef consumed True >> return Nothing+            Nothing   -> writeIORef state RepliesRead >> return Nothing             Just q' -> do when (blEventType q' == BINLOG_ROTATE_EVENT) $ do                                 e <- getFromBinLogPacket getRotateEvent q'                                 writeIORef' fref (rFileName e)@@ -142,43 +145,141 @@   deriving (Show, Eq, Generic)  -- | decode row based event from 'BinLogPacket' stream.+--+-- Throws 'RowEventDecodeException' on an event it cannot decode that may+-- carry row changes, rather than skip it and lose them. decodeRowBinLogEvent :: (FormatDescription, IORef ByteString, InputStream BinLogPacket)                      -> IO (InputStream RowBinLogEvent)-decodeRowBinLogEvent (fd', fref', is') = Stream.makeInputStream (loop fd' fref' is')-  where-    loop fd fref is = do-        p <- Stream.read is-        case p of-            Nothing -> return Nothing-            Just p' -> do-                let t = blEventType p'-                if  | t == BINLOG_ROWS_QUERY_EVENT -> do-                        tr <- track p' fref-                        e <- getFromBinLogPacket getQueryEvent' p'-                        pure (Just (RowQueryEvent (blTimestamp p') tr e))-                    | t == BINLOG_TABLE_MAP_EVENT -> do-                        tme <- getFromBinLogPacket (getTableMapEvent fd) p'-                        q <- Stream.read is-                        case q of-                            Nothing -> return Nothing-                            Just q' -> do-                                let u = blEventType q'-                                if  | u == BINLOG_WRITE_ROWS_EVENTv1 || u == BINLOG_WRITE_ROWS_EVENTv2 -> do-                                        tr <- track q' fref-                                        e <- getFromBinLogPacket' (getWriteRowEvent fd tme) q'-                                        pure (Just (RowWriteEvent (blTimestamp q') tr tme e))-                                    | u == BINLOG_DELETE_ROWS_EVENTv1 || u == BINLOG_DELETE_ROWS_EVENTv2 -> do-                                        tr <- track q' fref-                                        e <- getFromBinLogPacket' (getDeleteRowEvent fd tme) q'-                                        pure (Just (RowDeleteEvent (blTimestamp q') tr tme e))-                                    | u == BINLOG_UPDATE_ROWS_EVENTv1 || u == BINLOG_UPDATE_ROWS_EVENTv2 -> do-                                        tr <- track q' fref-                                        e <- getFromBinLogPacket' (getUpdateRowEvent fd tme) q'-                                        pure (Just (RowUpdateEvent (blTimestamp q') tr tme e))-                                    | otherwise -> loop fd fref is-                    | otherwise -> loop fd fref is+decodeRowBinLogEvent (fd, fref, is) = do+    tableMaps <- newIORef []+    Stream.makeInputStream (nextRowEvent fd fref tableMaps is) -    track p fref = BinLogTracker <$> readIORef fref <*> (pure . fromIntegral . blLogPos) p+-- | The table maps of the statement being read, by table ID. A statement maps+-- every table it changes before its rows events, which then name the table by+-- ID; a long statement splits its rows over several events.+type TableMaps = IORef [(Word64, TableMapEvent)]++nextRowEvent :: FormatDescription -> IORef ByteString -> TableMaps -> InputStream BinLogPacket+             -> IO (Maybe RowBinLogEvent)+nextRowEvent fd fref tableMaps is = do+    p <- Stream.read is+    case p of+        Nothing -> return Nothing+        Just packet -> case blEventType packet of+            BINLOG_ROWS_QUERY_EVENT -> do+                tr <- track packet fref+                e <- getFromBinLogPacket getQueryEvent' packet+                pure (Just (RowQueryEvent (blTimestamp packet) tr e))+            BINLOG_TABLE_MAP_EVENT -> do+                tme <- getFromBinLogPacket (getTableMapEvent fd) packet+                maps <- readIORef tableMaps+                writeIORef tableMaps ((tmTableId tme, tme) : maps)+                nextRowEvent fd fref tableMaps is+            BINLOG_WRITE_ROWS_EVENTv1 -> writeRows fd fref tableMaps packet+            BINLOG_WRITE_ROWS_EVENTv2 -> writeRows fd fref tableMaps packet+            BINLOG_DELETE_ROWS_EVENTv1 -> deleteRows fd fref tableMaps packet+            BINLOG_DELETE_ROWS_EVENTv2 -> deleteRows fd fref tableMaps packet+            BINLOG_UPDATE_ROWS_EVENTv1 -> updateRows fd fref tableMaps packet+            BINLOG_UPDATE_ROWS_EVENTv2 -> updateRows fd fref tableMaps packet+            BINLOG_UNRECOGNIZED_EVENT _ -> if isIgnorableEvent packet+                then nextRowEvent fd fref tableMaps is+                else unsupported packet fref+            -- The rows events of MySQL 5.1.0 to 5.1.15, which this decoder never read.+            BINLOG_WRITE_ROWS_EVENTv0 -> unsupported packet fref+            BINLOG_UPDATE_ROWS_EVENTv0 -> unsupported packet fref+            BINLOG_DELETE_ROWS_EVENTv0 -> unsupported packet fref+            -- Events without row changes.+            BINLOG_UNKNOWN_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_START_EVENT_V3 -> nextRowEvent fd fref tableMaps is+            BINLOG_QUERY_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_STOP_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_ROTATE_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_INTVAR_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_LOAD_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_SLAVE_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_CREATE_FILE_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_APPEND_BLOCK_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_EXEC_LOAD_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_DELETE_FILE_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_NEW_LOAD_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_RAND_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_USER_VAR_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_FORMAT_DESCRIPTION_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_XID_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_BEGIN_LOAD_QUERY_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_EXECUTE_LOAD_QUERY_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_INCIDENT_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_HEARTBEAT_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_IGNORABLE_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_GTID_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_ANONYMOUS_GTID_EVENT -> nextRowEvent fd fref tableMaps is+            BINLOG_PREVIOUS_GTIDS_EVENT -> nextRowEvent fd fref tableMaps is++unsupported :: BinLogPacket -> IORef ByteString -> IO a+unsupported packet fref = do+    tr <- track packet fref+    throwIO (UnsupportedEventType (binLogEventTypeCode (blEventType packet)) tr)++writeRows, deleteRows, updateRows+    :: FormatDescription -> IORef ByteString -> TableMaps -> BinLogPacket -> IO (Maybe RowBinLogEvent)+writeRows fd fref tableMaps packet = do+    (tr, tme) <- rowsEventContext fd fref tableMaps packet+    e <- getFromBinLogPacket' (getWriteRowEvent fd tme) packet+    endStatement tableMaps (writeFlags e)+    pure (Just (RowWriteEvent (blTimestamp packet) tr tme e))+deleteRows fd fref tableMaps packet = do+    (tr, tme) <- rowsEventContext fd fref tableMaps packet+    e <- getFromBinLogPacket' (getDeleteRowEvent fd tme) packet+    endStatement tableMaps (deleteFlags e)+    pure (Just (RowDeleteEvent (blTimestamp packet) tr tme e))+updateRows fd fref tableMaps packet = do+    (tr, tme) <- rowsEventContext fd fref tableMaps packet+    e <- getFromBinLogPacket' (getUpdateRowEvent fd tme) packet+    endStatement tableMaps (updateFlags e)+    pure (Just (RowUpdateEvent (blTimestamp packet) tr tme e))++-- | The position of a rows event and the table map its table ID refers to.+rowsEventContext :: FormatDescription -> IORef ByteString -> TableMaps -> BinLogPacket+                 -> IO (BinLogTracker, TableMapEvent)+rowsEventContext fd fref tableMaps packet = do+    tr <- track packet fref+    tableId <- getFromBinLogPacket (getRowsEventTableId fd (blEventType packet)) packet+    maps <- readIORef tableMaps+    case lookup tableId maps of+        Just tme -> pure (tr, tme)+        Nothing -> throwIO (MissingTableMap tableId tr)++-- | @STMT_END_F@ marks a statement's last rows event; its table maps are not+-- used after it, and table IDs may be reused for other tables later.+endStatement :: TableMaps -> Word16 -> IO ()+endStatement tableMaps rowsFlags =+    when (rowsFlags .&. 0x0001 /= 0) (writeIORef tableMaps [])++track :: BinLogPacket -> IORef ByteString -> IO BinLogTracker+track p fref = BinLogTracker <$> readIORef fref <*> (pure . fromIntegral . blLogPos) p++-- | Why 'decodeRowBinLogEvent' stopped.+data RowEventDecodeException+    = UnsupportedEventType !Word8 !BinLogTracker+      -- ^ An event type mysql-haskell cannot decode that the server did not+      -- mark ignorable, such as MySQL's compressed @TRANSACTION_PAYLOAD_EVENT@+      -- (40), so it may carry row changes.+    | MissingTableMap !Word64 !BinLogTracker+      -- ^ A rows event for a table ID whose table map was not read, as when+      -- the dump started in the middle of a statement.+    deriving (Show, Eq)++instance Exception RowEventDecodeException where+    displayException failure = case failure of+        UnsupportedEventType code tracker ->+            "mysql-haskell: binlog event type " ++ show code ++ " at " ++ show tracker+            ++ " cannot be decoded and is not marked ignorable, so it may hold row"+            ++ " changes. For MySQL's TRANSACTION_PAYLOAD_EVENT (40), turn off"+            ++ " binlog_transaction_compression."+        MissingTableMap tableId tracker ->+            "mysql-haskell: the rows event at " ++ show tracker ++ " is for table ID "+            ++ show tableId ++ ", whose table map event was not read. Start the dump"+            ++ " at a transaction boundary, such as getLastBinLogTracker's position."  -- | Get latest master's binlog filename and position. --

@@ -32,6 +32,8 @@ import           Control.Exception                         (throwIO) import           Database.MySQL.Query import           GHC.Generics                              (Generic)+import qualified Unwitch.Convert.Word32                    as Word32+import qualified Unwitch.Convert.Word8                     as Word8  -------------------------------------------------------------------------------- -- | binlog tyoe@@ -73,8 +75,93 @@     | BINLOG_GTID_EVENT     | BINLOG_ANONYMOUS_GTID_EVENT     | BINLOG_PREVIOUS_GTIDS_EVENT-  deriving (Show, Eq, Enum)+    | BINLOG_UNRECOGNIZED_EVENT !Word8+      -- ^ A type code this library has no constructor for, such as MySQL 8's+      -- @TRANSACTION_PAYLOAD_EVENT@ (40) or MariaDB's 160 and up.+  deriving (Show, Eq) +-- | The type of the event with this code in the binlog header.+binLogEventTypeFromCode :: Word8 -> BinLogEventType+binLogEventTypeFromCode code = case code of+    0 -> BINLOG_UNKNOWN_EVENT+    1 -> BINLOG_START_EVENT_V3+    2 -> BINLOG_QUERY_EVENT+    3 -> BINLOG_STOP_EVENT+    4 -> BINLOG_ROTATE_EVENT+    5 -> BINLOG_INTVAR_EVENT+    6 -> BINLOG_LOAD_EVENT+    7 -> BINLOG_SLAVE_EVENT+    8 -> BINLOG_CREATE_FILE_EVENT+    9 -> BINLOG_APPEND_BLOCK_EVENT+    10 -> BINLOG_EXEC_LOAD_EVENT+    11 -> BINLOG_DELETE_FILE_EVENT+    12 -> BINLOG_NEW_LOAD_EVENT+    13 -> BINLOG_RAND_EVENT+    14 -> BINLOG_USER_VAR_EVENT+    15 -> BINLOG_FORMAT_DESCRIPTION_EVENT+    16 -> BINLOG_XID_EVENT+    17 -> BINLOG_BEGIN_LOAD_QUERY_EVENT+    18 -> BINLOG_EXECUTE_LOAD_QUERY_EVENT+    19 -> BINLOG_TABLE_MAP_EVENT+    20 -> BINLOG_WRITE_ROWS_EVENTv0+    21 -> BINLOG_UPDATE_ROWS_EVENTv0+    22 -> BINLOG_DELETE_ROWS_EVENTv0+    23 -> BINLOG_WRITE_ROWS_EVENTv1+    24 -> BINLOG_UPDATE_ROWS_EVENTv1+    25 -> BINLOG_DELETE_ROWS_EVENTv1+    26 -> BINLOG_INCIDENT_EVENT+    27 -> BINLOG_HEARTBEAT_EVENT+    28 -> BINLOG_IGNORABLE_EVENT+    29 -> BINLOG_ROWS_QUERY_EVENT+    30 -> BINLOG_WRITE_ROWS_EVENTv2+    31 -> BINLOG_UPDATE_ROWS_EVENTv2+    32 -> BINLOG_DELETE_ROWS_EVENTv2+    33 -> BINLOG_GTID_EVENT+    34 -> BINLOG_ANONYMOUS_GTID_EVENT+    35 -> BINLOG_PREVIOUS_GTIDS_EVENT+    unrecognized -> BINLOG_UNRECOGNIZED_EVENT unrecognized++-- | The code this event type has in the binlog header.+binLogEventTypeCode :: BinLogEventType -> Word8+binLogEventTypeCode eventType = case eventType of+    BINLOG_UNKNOWN_EVENT -> 0+    BINLOG_START_EVENT_V3 -> 1+    BINLOG_QUERY_EVENT -> 2+    BINLOG_STOP_EVENT -> 3+    BINLOG_ROTATE_EVENT -> 4+    BINLOG_INTVAR_EVENT -> 5+    BINLOG_LOAD_EVENT -> 6+    BINLOG_SLAVE_EVENT -> 7+    BINLOG_CREATE_FILE_EVENT -> 8+    BINLOG_APPEND_BLOCK_EVENT -> 9+    BINLOG_EXEC_LOAD_EVENT -> 10+    BINLOG_DELETE_FILE_EVENT -> 11+    BINLOG_NEW_LOAD_EVENT -> 12+    BINLOG_RAND_EVENT -> 13+    BINLOG_USER_VAR_EVENT -> 14+    BINLOG_FORMAT_DESCRIPTION_EVENT -> 15+    BINLOG_XID_EVENT -> 16+    BINLOG_BEGIN_LOAD_QUERY_EVENT -> 17+    BINLOG_EXECUTE_LOAD_QUERY_EVENT -> 18+    BINLOG_TABLE_MAP_EVENT -> 19+    BINLOG_WRITE_ROWS_EVENTv0 -> 20+    BINLOG_UPDATE_ROWS_EVENTv0 -> 21+    BINLOG_DELETE_ROWS_EVENTv0 -> 22+    BINLOG_WRITE_ROWS_EVENTv1 -> 23+    BINLOG_UPDATE_ROWS_EVENTv1 -> 24+    BINLOG_DELETE_ROWS_EVENTv1 -> 25+    BINLOG_INCIDENT_EVENT -> 26+    BINLOG_HEARTBEAT_EVENT -> 27+    BINLOG_IGNORABLE_EVENT -> 28+    BINLOG_ROWS_QUERY_EVENT -> 29+    BINLOG_WRITE_ROWS_EVENTv2 -> 30+    BINLOG_UPDATE_ROWS_EVENTv2 -> 31+    BINLOG_DELETE_ROWS_EVENTv2 -> 32+    BINLOG_GTID_EVENT -> 33+    BINLOG_ANONYMOUS_GTID_EVENT -> 34+    BINLOG_PREVIOUS_GTIDS_EVENT -> 35+    BINLOG_UNRECOGNIZED_EVENT code -> code+ data BinLogPacket = BinLogPacket     { blTimestamp :: !Word32     , blEventType :: !BinLogEventType@@ -86,6 +173,11 @@     , blSemiAck   :: !Bool     } deriving (Show, Eq) +-- | @LOG_EVENT_IGNORABLE_F@: the server allows a reader that does not know+-- this event's type to skip it.+isIgnorableEvent :: BinLogPacket -> Bool+isIgnorableEvent packet = blFlags packet .&. 0x80 /= 0+ putSemiAckResp :: Word32 -> ByteString -> Put putSemiAckResp pos fn = put pos >> put fn @@ -96,7 +188,7 @@         then getWord8 >> (== 0x01) <$> getWord8         else return False     ts <- getWord32le-    typ <- toEnum . fromIntegral <$> getWord8+    typ <- binLogEventTypeFromCode <$> getWord8     sid <- getWord32le     size <- getWord32le     pos <- getWord32le@@ -142,7 +234,7 @@     vec :: ByteString     vec = fdEventHeaderLenVector fd     idx :: Int-    idx = fromEnum typ - 1+    idx = Word8.toInt (binLogEventTypeCode typ) - 1  data RotateEvent = RotateEvent     { rPos :: !Word64, rFileName :: !ByteString } deriving (Show, Eq)@@ -286,6 +378,11 @@     UpdateRowsEvent tid flgs colCnt (pmap, pmap') <$>         untilM ((,) <$> getBinLogRow (tmColumnMeta tme) pmap <*> getBinLogRow (tmColumnMeta tme) pmap')                isEmpty++-- | The table ID that opens the body of a rows event of this type.+getRowsEventTableId :: FormatDescription -> BinLogEventType -> Get Word64+getRowsEventTableId fd typ =+    if eventHeaderLen fd typ == 6 then Word32.toWord64 <$> getWord32le else getWord48le  getPresentMap :: Int -> Int -> Get BitMap getPresentMap plen poffset = do

@@ -13,12 +13,64 @@ -}  module Database.MySQL.Connection-    ( module Database.MySQL.Connection+    ( -- * Connections+      MySQLConn (..)+    , ReplyState (..)+    , ConnectInfo (..)+    , defaultConnectInfo+    , defaultConnectInfoMB4+    , utf8_general_ci+    , utf8mb4_unicode_ci+    , bUFSIZE+    , connect+    , connectDetail+    , connectUnixSocket+    , connectUnixSocketDetail+    , connectDetailExtended+    , connectUnixSocketDetailExtended+    , withoutNegotiated+    , authenticatedConnection+      -- * Authentication+    , mkAuth+    , handshakeResponsePacket+    , sslRequestPacket+    , scrambleForPlugin+    , scrambleSHA1+    , scrambleSHA256+    , completeAuth+    , plainFullAuth+    , parseRSAPublicKey+    , xorPasswordNonce+    , doRSAAuth+    , AuthException (..)+      -- * Commands and replies+    , decodeInputStream+    , close+    , ping+    , command+    , waitCommandReply+    , waitCommandReplys+    , readPacket+    , writeCommand+    , writePayload+    , sendPacket+    , guardUnconsumed+    , runCommand+    , settleFailedExchange+    , endsReply+    , writeIORef'+      -- * Exceptions+    , NetworkException (..)+    , UnconsumedResultSet (..)+    , AbandonedReply (..)+    , ERRException (..)+    , UnexpectedPacket (..)+    , ExtraResultSets (..)     ) where  import           Control.Exception               (Exception (displayException),-                                                  bracketOnError,-                                                  throwIO, catch, SomeException)+                                                  bracketOnError, fromException,+                                                  mask, throwIO, catch, SomeException) import           Control.Monad import qualified Crypto.Hash                     as Crypto import           Crypto.Hash.Algorithms          (SHA1(..))@@ -39,8 +91,10 @@ import qualified Data.ByteString.Unsafe          as B import           Data.IORef                      (IORef, newIORef, readIORef,                                                   writeIORef)+import           Data.Maybe                      (isJust) import qualified Data.PEM                        as PEM import           Data.Typeable+import           Data.Int                        (Int64) import           Data.Word import           Database.MySQL.Protocol.Auth import           Database.MySQL.Protocol.Command@@ -63,9 +117,39 @@         mysqlRead        :: {-# UNPACK #-} !(InputStream  Packet)     ,   mysqlWrite       :: (Packet -> IO ())     ,   mysqlCloseSocket :: IO ()-    ,   isConsumed       :: {-# UNPACK #-} !(IORef Bool)+    ,   replyState       :: {-# UNPACK #-} !(IORef ReplyState)     } +-- | How far the replies to the commands sent on a connection have been read.+-- See Note [Abandoned replies].+--+-- @since 1.4.0+data ReplyState+    = RepliesRead+      -- ^ Every reply was read, so a command may be sent.+    | RowsUnread+      -- ^ A result set's rows are still to be read from its stream.+    | ReplyAbandoned+      -- ^ Reading a reply stopped part-way; the connection refuses commands.+    deriving (Show, Eq)++-- Note [Abandoned replies]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- The server answers commands in order on one socket, so a reply left unread+-- is read as the reply to the next command. A timeout around query_ used to+-- do that: interrupted before it read the column count, it left the+-- connection looking idle, and the next SELECT returned the earlier one's+-- rows (issue #10).+--+-- Decision: a command's exchange runs with the state at ReplyAbandoned until+-- its reply is read, so an exception part-way leaves the connection refusing+-- commands with AbandonedReply, and the caller reconnects. Draining the rest+-- of the reply instead would block on the server for as long as the+-- interrupted statement runs, which defeats the timeout. ERRException and+-- ExtraResultSets are only raised after a reply was read in full, so they+-- leave the connection usable, as does a DecodePacketException on a row,+-- whose packet was read before it failed to decode.+ -- | Everything you need to establish a MySQL connection. -- -- To setup a TLS connection, use module "Database.MySQL.TLS" or "Database.MySQL.OpenSSL".@@ -119,32 +203,19 @@ -- | Establish a MySQL connection with 'Greeting' back, so you can find server's version .etc. -- connectDetail :: ConnectInfo -> IO (Greeting, MySQLConn)-connectDetail (ConnectInfo host port db user pass charset)-    = bracketOnError open TCP.close go-  where-    open  = connectWithBufferSize host port bUFSIZE-    go c  = do-        let is = TCP.source c-        is' <- decodeInputStream is-        p <- readPacket is'-        greet <- decodeFromPacket p-        let salt = greetingSalt1 greet `B.append` greetingSalt2 greet-            auth = mkAuth db user pass charset greet-        write c $ encodeToPacket 1 auth-        q <- readPacket is'-        completeAuth is' (write c) pass q (plainFullAuth salt)-        consumed <- newIORef True-        let waitNotMandatoryOK = catch-                (void (waitCommandReply is'))           -- server will either reply an OK packet-                ((\ _ -> return ()) :: SomeException -> IO ())   -- or directy close the connection-            conn = MySQLConn is'-                (write c)-                (writeCommand COM_QUIT (write c) >> waitNotMandatoryOK >> TCP.close c)-                consumed-        return (greet, conn)+connectDetail = fmap withoutNegotiated . connectDetailExtended noExtendedCapabilities -    connectWithBufferSize h p bs = TCP.connectSocket h p >>= TCP.socketToConnection bs-    write c a = TCP.send c $ Binary.runPut . Binary.put $ a+-- | 'connectDetail' asking a MariaDB server for extended capabilities, also+-- returning those the server agreed to. Asking for none gives exactly+-- 'connectDetail'. See Note [MariaDB extended capabilities].+--+-- @since 1.4.0+connectDetailExtended :: ExtendedCapabilities -> ConnectInfo -> IO (Greeting, ExtendedCapabilities, MySQLConn)+connectDetailExtended requested ci =+    bracketOnError+        (TCP.connectSocket (ciHost ci) (ciPort ci) >>= TCP.socketToConnection bUFSIZE)+        TCP.close+        (handshakePlain requested ci)  -- | Connect to MySQL via a Unix domain socket. --@@ -155,44 +226,97 @@ -- so you can find server's version .etc. -- connectUnixSocketDetail :: FilePath -> ConnectInfo -> IO (Greeting, MySQLConn)-connectUnixSocketDetail socketPath (ConnectInfo _host _port db user pass charset)-    = bracketOnError open TCP.close go-  where-    open  = bracketOnError-                (N.socket N.AF_UNIX N.Stream 0)-                N.close-                (\sock -> do-                    N.connect sock (N.SockAddrUnix socketPath)-                    TCP.socketToConnection bUFSIZE (sock, N.SockAddrUnix socketPath)-                )-    go c  = do-        let is = TCP.source c-        is' <- decodeInputStream is-        p <- readPacket is'-        greet <- decodeFromPacket p-        let salt = greetingSalt1 greet `B.append` greetingSalt2 greet-            auth = mkAuth db user pass charset greet-        write c $ encodeToPacket 1 auth-        q <- readPacket is'-        completeAuth is' (write c) pass q (plainFullAuth salt)-        consumed <- newIORef True-        let waitNotMandatoryOK = catch-                (void (waitCommandReply is'))           -- server will either reply an OK packet-                ((\_ -> return ()) :: SomeException -> IO ())   -- or directy close the connection-            conn = MySQLConn is'-                (write c)-                (writeCommand COM_QUIT (write c) >> waitNotMandatoryOK >> TCP.close c)-                consumed-        return (greet, conn)+connectUnixSocketDetail socketPath =+    fmap withoutNegotiated . connectUnixSocketDetailExtended noExtendedCapabilities socketPath -    write c a = TCP.send c $ Binary.runPut . Binary.put $ a+-- | 'connectUnixSocketDetail' asking for extended capabilities, as+-- 'connectDetailExtended' does.+--+-- @since 1.4.0+connectUnixSocketDetailExtended :: ExtendedCapabilities -> FilePath -> ConnectInfo+                                -> IO (Greeting, ExtendedCapabilities, MySQLConn)+connectUnixSocketDetailExtended requested socketPath ci =+    bracketOnError (openUnixSocket socketPath) TCP.close (handshakePlain requested ci) +openUnixSocket :: FilePath -> IO TCP.TCPConnection+openUnixSocket socketPath = bracketOnError+    (N.socket N.AF_UNIX N.Stream 0)+    N.close+    (\sock -> do+        N.connect sock (N.SockAddrUnix socketPath)+        TCP.socketToConnection bUFSIZE (sock, N.SockAddrUnix socketPath)+    )++withoutNegotiated :: (Greeting, ExtendedCapabilities, MySQLConn) -> (Greeting, MySQLConn)+withoutNegotiated (greet, _, conn) = (greet, conn)++-- | Authenticate over a connection without TLS, TCP or Unix socket alike.+handshakePlain :: ExtendedCapabilities -> ConnectInfo -> TCP.TCPConnection+               -> IO (Greeting, ExtendedCapabilities, MySQLConn)+handshakePlain requested (ConnectInfo _host _port db user pass charset) c = do+    is' <- decodeInputStream (TCP.source c)+    p <- readPacket is'+    (greet, offered) <- getFromPacket getGreetingExtended p+    let salt = greetingSalt1 greet `B.append` greetingSalt2 greet+        negotiated = negotiateExtended requested greet offered+    sendPacket c (handshakeResponsePacket 1 negotiated db user pass charset greet)+    q <- readPacket is'+    completeAuth is' (sendPacket c) pass q (plainFullAuth salt)+    conn <- authenticatedConnection is' c+    return (greet, negotiated, conn)++-- | The 'MySQLConn' over a connection whose handshake completed.+--+-- @since 1.4.0+authenticatedConnection :: InputStream Packet -> TCP.Connection a -> IO MySQLConn+authenticatedConnection is' c = do+    state <- newIORef RepliesRead+    return $ MySQLConn is'+        (sendPacket c)+        (writeCommand COM_QUIT (sendPacket c) >> quitReply is' >> TCP.close c)+        state++-- | After COM_QUIT the server either replies an OK packet or closes the+-- connection, so a failed read is not an error here.+quitReply :: InputStream Packet -> IO ()+quitReply is' = catch+    (void (waitCommandReply is'))+    ((\_ -> return ()) :: SomeException -> IO ())++sendPacket :: TCP.Connection a -> Packet -> IO ()+sendPacket c = TCP.send c . Binary.runPut . Binary.put++-- | The handshake response for a connection using the negotiated extended+-- capabilities, numbered @seqN@ (1 after a plain greeting, 2 after an SSL+-- request). With 'noExtendedCapabilities' it is the packet mysql-haskell sent+-- before extended capabilities existed.+--+-- @since 1.4.0+handshakeResponsePacket :: Word8 -> ExtendedCapabilities -> ByteString -> ByteString -> ByteString+                        -> Word8 -> Greeting -> Packet+handshakeResponsePacket seqN negotiated db user pass charset greet =+    putToPacket seqN (putAuthExtended negotiated (mkAuthFor negotiated db user pass charset greet))++-- | The SSL request for a connection using the negotiated extended+-- capabilities, as 'handshakeResponsePacket'.+--+-- @since 1.4.0+sslRequestPacket :: ExtendedCapabilities -> Word8 -> Packet+sslRequestPacket negotiated charset =+    putToPacket 1 (putSSLRequestExtended negotiated (sslRequestFor negotiated charset))+ mkAuth :: ByteString -> ByteString -> ByteString -> Word8 -> Greeting -> Auth-mkAuth db user pass charset greet =+mkAuth = mkAuthFor noExtendedCapabilities++-- | 'mkAuth' for a connection using these extended capabilities.+--+-- @since 1.4.0+mkAuthFor :: ExtendedCapabilities -> ByteString -> ByteString -> ByteString -> Word8 -> Greeting -> Auth+mkAuthFor negotiated db user pass charset greet =     let salt = greetingSalt1 greet `B.append` greetingSalt2 greet         plugin = greetingAuthPlugin greet         scambleBuf = scrambleForPlugin plugin salt pass-    in Auth clientCap clientMaxPacketSize charset user scambleBuf db plugin+    in Auth (clientCapFor negotiated) clientMaxPacketSize charset user scambleBuf db plugin  -- | Dispatch scramble based on the authentication plugin name. scrambleForPlugin :: ByteString -> ByteString -> ByteString -> ByteString@@ -382,8 +506,7 @@ -- | Send a 'Command' which don't return a resultSet. -- command :: MySQLConn -> Command -> IO OK-command conn@(MySQLConn is os _ _) cmd = do-    guardUnconsumed conn+command conn@(MySQLConn is os _ _) cmd = runCommand conn $ do     writeCommand cmd os     waitCommandReply is {-# INLINE command #-}@@ -424,27 +547,59 @@ {-# INLINE readPacket #-}  writeCommand :: Command -> (Packet -> IO ()) -> IO ()-writeCommand a writePacket = let bs = Binary.runPut (putCommand a) in-    go (L.length bs) 0 bs writePacket-  where-    go len seqN bs writePacket' = do-        if len < 16777215-        then writePacket (Packet len seqN bs)-        else do-            let (bs', rest) = L.splitAt 16777215 bs-                seqN' = seqN + 1-                len'  = len - 16777215--            writePacket (Packet 16777215 seqN bs')-            seqN' `seq` len' `seq` go len' seqN' rest writePacket'+writeCommand a = writePayload (Binary.runPut (putCommand a)) {-# INLINE writeCommand #-} +-- | Send one command's payload, split into packets as the protocol requires+-- for payloads of 16 MiB and more.+--+-- @since 1.4.0+writePayload :: L.ByteString -> (Packet -> IO ()) -> IO ()+writePayload bs = writePayloadFrom 0 (L.length bs) bs+{-# INLINE writePayload #-}++writePayloadFrom :: Word8 -> Int64 -> L.ByteString -> (Packet -> IO ()) -> IO ()+writePayloadFrom seqN len bs writePacket =+    if len < 16777215+    then writePacket (Packet len seqN bs)+    else do+        let (bs', rest) = L.splitAt 16777215 bs+        writePacket (Packet 16777215 seqN bs')+        writePayloadFrom (seqN + 1) (len - 16777215) rest writePacket++-- | Throws unless a command may be sent, see 'ReplyState'. guardUnconsumed :: MySQLConn -> IO ()-guardUnconsumed (MySQLConn _ _ _ consumed) = do-    c <- readIORef consumed-    unless c (throwIO UnconsumedResultSet)+guardUnconsumed (MySQLConn _ _ _ state) = do+    current <- readIORef state+    case current of+        RepliesRead -> pure ()+        RowsUnread -> throwIO UnconsumedResultSet+        ReplyAbandoned -> throwIO AbandonedReply {-# INLINE guardUnconsumed #-} +-- | Send a command and read its reply, the @exchange@, leaving the connection+-- at 'ReplyAbandoned' if an exception stops it part-way. An exchange that hands+-- out a row stream sets 'RowsUnread' itself. See Note [Abandoned replies].+runCommand :: MySQLConn -> IO a -> IO a+runCommand conn@(MySQLConn _ _ _ state) exchange = mask $ \restore -> do+    guardUnconsumed conn+    writeIORef state ReplyAbandoned+    result <- restore exchange `catch` settleFailedExchange state+    settled <- readIORef state+    when (settled == ReplyAbandoned) (writeIORef state RepliesRead)+    pure result++settleFailedExchange :: IORef ReplyState -> SomeException -> IO a+settleFailedExchange state failure = do+    when (endsReply failure) (writeIORef state RepliesRead)+    throwIO failure++-- | Raised only once the reply it came in was read to the end.+endsReply :: SomeException -> Bool+endsReply failure =+    isJust (fromException failure :: Maybe ERRException)+    || isJust (fromException failure :: Maybe ExtraResultSets)+ writeIORef' :: IORef a -> a -> IO () writeIORef' ref x = x `seq` writeIORef ref x {-# INLINE writeIORef' #-}@@ -457,6 +612,19 @@  data UnconsumedResultSet = UnconsumedResultSet deriving (Typeable, Show) instance Exception UnconsumedResultSet++-- | Reading the reply to an earlier command on this connection stopped part-way,+-- for example on a 'System.Timeout.timeout'. The rest of that reply is still+-- unread and would be taken for the reply to the next command, so the+-- connection refuses commands: close it and connect again.+--+-- @since 1.4.0+data AbandonedReply = AbandonedReply deriving (Typeable, Show)+instance Exception AbandonedReply where+    displayException AbandonedReply =+        "mysql-haskell: reading the reply to an earlier command on this connection stopped "+        ++ "part-way (for example on a timeout), so the rest of it is still unread and "+        ++ "would be taken for this command's reply. Close the connection and connect again."  data ERRException = ERRException ERR deriving (Typeable, Show) instance Exception ERRException

@@ -0,0 +1,843 @@+{-# LANGUAGE MagicHash     #-}+{-# LANGUAGE UnboxedSums   #-}+{-# LANGUAGE UnboxedTuples #-}++{-|+Module      : Database.MySQL.Decoder+Description : Decode rows straight into Haskell values, without 'MySQLValue'+Copyright   : (c) Jappie Klooster, 2026+License     : BSD3+Maintainer  : hi@jappie.me+Stability   : experimental+Portability : PORTABLE++Decoders that turn a row's fields straight into Haskell values, for+'Database.MySQL.Base.queryRows' and 'Database.MySQL.Base.queryStmtRows':++@+import qualified Database.MySQL.Decoder as Decode++data Employee = Employee { number :: Int32, born :: Day, name :: Text }++employee :: Decode.RowDecoder Employee+employee = Employee+    \<$\> Decode.field Decode.int32+    \<*\> Decode.field Decode.day+    \<*\> Decode.field Decode.text++(columns, employees) <- queryRows_ employee conn "SELECT emp_no, birth_date, first_name FROM employees"+@++A 'FieldDecoder' is checked against its column's definition once per result+set; a column it does not fit raises a 'ColumnMismatch' before any row is+read. A decoder for a Haskell type accepts exactly the columns whose+'MySQLValue' constructor "Database.MySQL.Field" decodes into that type, so+the two never disagree. Values are evaluated as they are decoded, so a field+that does not decode raises a 'FieldError' with its column while the row is+read.++Libraries that decode by column number, such as a persistent backend, can use+'prepareFieldParser' and 'runFieldParser' on the 'RawRow's of+'Database.MySQL.Base.queryRawRows_' and 'Database.MySQL.Base.queryStmtRawRows'+instead of a 'RowDecoder'. See @docs/direct-row-decoding.md@.+-}+module Database.MySQL.Decoder+  ( -- * Decoding a column+    FieldDecoder+  , int8, word8, int16, word16, int32, word32, int64, word64+  , float, double, scientific+  , text, bytes+  , day, localTime, timeOfDay+  , bool+  , mysqlValue+  , nullable+    -- * Decoding a row+  , RowDecoder+  , field+    -- * Errors+  , ColumnMismatch(..)+  , FieldError(..)+  , FieldErrorKind(..)+    -- * Running decoders on raw rows+  , RowProtocol+  , FieldParser+  , prepareFieldParser+  , runFieldParser+  , PreparedRow+  , prepareRowDecoder+  , runPreparedRow+    -- * Prepared statements' rows as 'MySQLValue's+  , BinaryValueColumns+  , binaryValueColumns+  , decodeBinaryValues+  , module Database.MySQL.Protocol.RawRow+  ) where++import           Control.Exception                  (Exception)+import           Data.Bits                          (unsafeShiftL, (.|.))+import           Data.ByteString                    (ByteString)+import qualified Data.ByteString                    as B+import qualified Data.ByteString.Unsafe             as B+import           Data.Kind                          (Type)+import           Data.Fixed                         (Fixed (MkFixed), Pico)+import           Data.Int                           (Int16, Int32, Int64, Int8)+import           Data.Scientific                    (Scientific)+import           Data.Text                          (Text)+import qualified Data.Text.Encoding                 as T+import           Data.Time.Calendar                 (Day)+import           Data.Time.LocalTime                (LocalTime (..),+                                                     TimeOfDay (..), midnight)+import qualified Data.Vector                        as V+import           Data.Word                          (Word16, Word32, Word64,+                                                     Word8)+import           Database.MySQL.Protocol.ColumnDef+import           Database.MySQL.Protocol.FloatingPoint (readDouble, readFloat)+import           Database.MySQL.Protocol.MySQLValue (ColumnKind (..),+                                                     MySQLValue (..),+                                                     RawDate (..),+                                                     RowErrorKind (..),+                                                     nextColumn,+                                                     TextFieldError (..),+                                                     ValueKind (..),+                                                     calendarDate, columnKind,+                                                     dateTimeValue, dateValue,+                                                     decodeMySQLLatin1,+                                                     decodeTextBit,+                                                     decodeTextValue,+                                                     lexDateTimeParts,+                                                     textDateParts,+                                                     timeStampValue,+                                                     lexSignedFraction,+                                                     lexSignedIntegral,+                                                     lengthEncodedInt,+                                                     lexSignedTime)+-- The internal utilities come in qualified only, so that the @module@+-- re-export in the export list does not publish them.+import           Database.MySQL.Protocol.RawRow      hiding (binaryNullMapLength,+                                                             isNullInMap)+import qualified Database.MySQL.Protocol.RawRow      as RawRow+import           GHC.Exts                           (word16ToInt16#,+                                                     word32ToInt32#,+                                                     word64ToInt64#,+                                                     word8ToInt8#)+import           GHC.Float                          (castWord32ToFloat,+                                                     castWord64ToDouble)+import           GHC.Int                            (Int16 (I16#), Int32 (I32#),+                                                     Int64 (I64#), Int8 (I8#))+import           GHC.Word                           (Word16 (W16#),+                                                     Word32 (W32#),+                                                     Word64 (W64#), Word8 (W8#))+import qualified Unwitch.Convert.Word32             as Word32+import qualified Unwitch.Convert.Word8              as Word8++-- | How the non-NULL bytes of one field become a value. An unboxed sum, so+-- that no 'Either' is allocated per field.+type ParseBytes a = ByteString -> (# FieldErrorKind | a #)++-- | Turns the fields of one column into @a@. See the module header.+--+-- @since 1.4.0+data FieldDecoder a = FieldDecoder+    { decoderTypeName :: !Text+      -- ^ the Haskell type, for 'ColumnTypeMismatch'+    , decoderNull     :: !(Maybe a)+      -- ^ the value of a NULL field; 'Nothing' makes a NULL a 'FieldUnexpectedNull'+    , decoderText     :: ColumnKind -> Maybe (ParseBytes a)+      -- ^ the parser for a column's text-protocol fields, if the column fits+    , decoderBinary   :: ColumnKind -> Maybe (ParseBytes a)+      -- ^ the parser for a column's binary-protocol fields, if the column fits+    }++instance Functor FieldDecoder where+    fmap f decoder = FieldDecoder+        { decoderTypeName = decoderTypeName decoder+        , decoderNull     = f <$> decoderNull decoder+        , decoderText     = fmap (mapParse f) . decoderText decoder+        , decoderBinary   = fmap (mapParse f) . decoderBinary decoder+        }++mapParse :: (a -> b) -> ParseBytes a -> ParseBytes b+mapParse f parse = \fieldBytes -> case parse fieldBytes of+    (# kind | #)  -> (# kind | #)+    (# | value #) -> (# | f value #)+{-# INLINE mapParse #-}++-- | NULL becomes 'Nothing'; any other field is decoded as before.+--+-- @since 1.4.0+nullable :: FieldDecoder a -> FieldDecoder (Maybe a)+nullable decoder = (Just <$> decoder)+    { decoderTypeName = "Maybe " <> decoderTypeName decoder+    , decoderNull     = Just Nothing+    }++-- | A decoder for the columns whose fields become one of @kinds@. A column of+-- type NULL fits every decoder: all its fields are NULL, which 'decoderNull'+-- answers.+kindDecoder :: Text -> [ValueKind] -> ParseBytes a -> ParseBytes a -> FieldDecoder a+kindDecoder typeName kinds textParse binaryParse = FieldDecoder+    { decoderTypeName = typeName+    , decoderNull     = Nothing+    , decoderText     = whenKindIn kinds textParse+    , decoderBinary   = whenKindIn kinds binaryParse+    }++whenKindIn :: [ValueKind] -> ParseBytes a -> ColumnKind -> Maybe (ParseBytes a)+whenKindIn kinds parse column = case column of+    NullColumn         -> Just parse+    ValueColumn _ kind -> if kind `elem` kinds then Just parse else Nothing++-- | TINYINT.+int8 :: FieldDecoder Int8+int8 = kindDecoder "Int8" [KindInt8] (lexedField lexSignedIntegral)+    (fixedField 1 (int8Bits . B.unsafeHead))++-- | TINYINT UNSIGNED.+word8 :: FieldDecoder Word8+word8 = kindDecoder "Word8" [KindInt8U] (lexedField lexSignedIntegral)+    (fixedField 1 B.unsafeHead)++-- | SMALLINT.+int16 :: FieldDecoder Int16+int16 = kindDecoder "Int16" [KindInt16] (lexedField lexSignedIntegral)+    (fixedField 2 (int16Bits . littleEndian16))++-- | SMALLINT UNSIGNED.+word16 :: FieldDecoder Word16+word16 = kindDecoder "Word16" [KindInt16U] (lexedField lexSignedIntegral)+    (fixedField 2 littleEndian16)++-- | INT and MEDIUMINT.+int32 :: FieldDecoder Int32+int32 = kindDecoder "Int32" [KindInt32] (lexedField lexSignedIntegral)+    (fixedField 4 (int32Bits . littleEndian32))++-- | INT UNSIGNED and MEDIUMINT UNSIGNED.+word32 :: FieldDecoder Word32+word32 = kindDecoder "Word32" [KindInt32U] (lexedField lexSignedIntegral)+    (fixedField 4 littleEndian32)++-- | BIGINT.+int64 :: FieldDecoder Int64+int64 = kindDecoder "Int64" [KindInt64] (lexedField lexSignedIntegral)+    (fixedField 8 (int64Bits . littleEndian64))++-- | BIGINT UNSIGNED.+word64 :: FieldDecoder Word64+word64 = kindDecoder "Word64" [KindInt64U] (lexedField lexSignedIntegral)+    (fixedField 8 littleEndian64)++-- | FLOAT.+float :: FieldDecoder Float+float = kindDecoder "Float" [KindFloat] (lexedField readFloat)+    (fixedField 4 (castWord32ToFloat . littleEndian32))++-- | DOUBLE.+double :: FieldDecoder Double+double = kindDecoder "Double" [KindDouble] (lexedField readDouble)+    (fixedField 8 (castWord64ToDouble . littleEndian64))++-- | DECIMAL; the binary protocol sends it as text too.+scientific :: FieldDecoder Scientific+scientific = kindDecoder "Scientific" [KindDecimal] (lexedField lexSignedFraction)+    (lexedField lexSignedFraction)++-- | The string columns in a character set other than binary. latin1 is read as+-- MySQL means it, as Windows-1252, and any other as UTF-8, where invalid UTF-8+-- is a 'FieldInvalidUtf8'.+text :: FieldDecoder Text+text = FieldDecoder+    { decoderTypeName = "Text"+    , decoderNull     = Nothing+    , decoderText     = stringColumnParse+    , decoderBinary   = stringColumnParse+    }++stringColumnParse :: ColumnKind -> Maybe (ParseBytes Text)+stringColumnParse column = case column of+    NullColumn -> Just utf8Field+    ValueColumn _ kind -> case kind of+        KindText _      -> Just utf8Field+        KindLatin1Text  -> Just latin1Field+        KindDecimal     -> Nothing+        KindInt8U       -> Nothing+        KindInt8        -> Nothing+        KindInt16U      -> Nothing+        KindInt16       -> Nothing+        KindInt32U      -> Nothing+        KindInt32       -> Nothing+        KindInt64U      -> Nothing+        KindInt64       -> Nothing+        KindFloat       -> Nothing+        KindDouble      -> Nothing+        KindYear        -> Nothing+        KindTimeStamp   -> Nothing+        KindDateTime    -> Nothing+        KindDate        -> Nothing+        KindTime        -> Nothing+        KindGeometry    -> Nothing+        KindBytes       -> Nothing+        KindBit         -> Nothing+        KindUnsupported -> Nothing++-- | The string columns in the binary character set: BINARY, VARBINARY, BLOB.+bytes :: FieldDecoder ByteString+bytes = kindDecoder "ByteString" [KindBytes] bytesField bytesField++-- | DATE. A date a 'Day' cannot hold, such as @0000-00-00@, is a+-- 'FieldUnrepresentableDate'.+day :: FieldDecoder Day+day = kindDecoder "Day" [KindDate] (calendarDay (lexedField textDateParts))+    (calendarDay binaryDateParts)++-- | DATETIME and TIMESTAMP. A date a 'Day' cannot hold is a+-- 'FieldUnrepresentableDate'.+localTime :: FieldDecoder LocalTime+localTime = kindDecoder "LocalTime" [KindDateTime, KindTimeStamp]+    (calendarLocalTime (lexedField lexDateTimeParts)) (calendarLocalTime binaryDateTimeParts)++-- | TIME, when not negative; a negative one is a 'FieldNegativeTime'. The+-- hours may exceed 24, as TIME spans up to 838 hours.+timeOfDay :: FieldDecoder TimeOfDay+timeOfDay = kindDecoder "TimeOfDay" [KindTime]+    (nonNegativeTime (lexedField lexSignedTime)) (nonNegativeTime binarySignedTime)++-- | TINYINT and TINYINT UNSIGNED, as MySQL stores BOOL: anything but 0 is 'True'.+bool :: FieldDecoder Bool+bool = FieldDecoder+    { decoderTypeName = "Bool"+    , decoderNull     = Nothing+    , decoderText     = boolText+    , decoderBinary   = whenKindIn [KindInt8, KindInt8U] (fixedField 1 ((/= 0) . B.unsafeHead))+    }++-- | The signed and unsigned text of a TINYINT overflow differently, so each+-- kind keeps its own type, as 'Database.MySQL.Field.decodeBool' does.+boolText :: ColumnKind -> Maybe (ParseBytes Bool)+boolText column = case column of+    NullColumn -> Just (lexedField lexNonZeroInt8)+    ValueColumn _ kind ->+        if  | kind == KindInt8  -> Just (lexedField lexNonZeroInt8)+            | kind == KindInt8U -> Just (lexedField lexNonZeroWord8)+            | otherwise         -> Nothing++lexNonZeroInt8 :: ByteString -> Maybe Bool+lexNonZeroInt8 fieldBytes = (/= (0 :: Int8)) <$> lexSignedIntegral fieldBytes++lexNonZeroWord8 :: ByteString -> Maybe Bool+lexNonZeroWord8 fieldBytes = (/= (0 :: Word8)) <$> lexSignedIntegral fieldBytes++-- | Every column, as 'Database.MySQL.Base.query_' decodes it; NULL is+-- 'MySQLNull'. The values are as lazy as 'query_' leaves them.+mysqlValue :: FieldDecoder MySQLValue+mysqlValue = FieldDecoder+    { decoderTypeName = "MySQLValue"+    , decoderNull     = Just MySQLNull+    , decoderText     = Just . textMySQLValue+    , decoderBinary   = Just . binaryMySQLValue+    }++textMySQLValue :: ColumnKind -> ParseBytes MySQLValue+textMySQLValue column fieldBytes = case column of+    NullColumn -> (# | MySQLNull #)+    ValueColumn fieldType kind -> case decodeTextValue fieldType kind fieldBytes of+        Left fieldError -> (# textFieldErrorKind fieldError | #)+        Right value     -> (# | value #)++-- | 'Database.MySQL.Protocol.MySQLValue.getBinaryField' on a field's bytes.+binaryMySQLValue :: ColumnKind -> ParseBytes MySQLValue+binaryMySQLValue column fieldBytes = case column of+    NullColumn -> (# | MySQLNull #)+    ValueColumn fieldType kind -> case kind of+        KindDecimal     -> mapParse MySQLDecimal (lexedField lexSignedFraction) fieldBytes+        KindInt8U       -> mapParse MySQLInt8U (fixedField 1 B.unsafeHead) fieldBytes+        KindInt8        -> mapParse MySQLInt8 (fixedField 1 (int8Bits . B.unsafeHead)) fieldBytes+        KindInt16U      -> mapParse MySQLInt16U (fixedField 2 littleEndian16) fieldBytes+        KindInt16       -> mapParse MySQLInt16 (fixedField 2 (int16Bits . littleEndian16)) fieldBytes+        KindInt32U      -> mapParse MySQLInt32U (fixedField 4 littleEndian32) fieldBytes+        KindInt32       -> mapParse MySQLInt32 (fixedField 4 (int32Bits . littleEndian32)) fieldBytes+        KindInt64U      -> mapParse MySQLInt64U (fixedField 8 littleEndian64) fieldBytes+        KindInt64       -> mapParse MySQLInt64 (fixedField 8 (int64Bits . littleEndian64)) fieldBytes+        KindFloat       -> mapParse MySQLFloat (fixedField 4 (castWord32ToFloat . littleEndian32)) fieldBytes+        KindDouble      -> mapParse MySQLDouble (fixedField 8 (castWord64ToDouble . littleEndian64)) fieldBytes+        KindYear        -> mapParse MySQLYear (fixedField 2 littleEndian16) fieldBytes+        KindTimeStamp   -> mapParse (uncurry timeStampValue) binaryDateTimeParts fieldBytes+        KindDateTime    -> mapParse (uncurry dateTimeValue) binaryDateTimeParts fieldBytes+        KindDate        -> mapParse dateValue binaryDateParts fieldBytes+        KindTime        -> mapParse (uncurry MySQLTime) binarySignedTime fieldBytes+        KindGeometry    -> (# | MySQLGeometry fieldBytes #)+        -- Both protocols send a string as its bytes, so 'decodeTextValue' decodes it.+        KindText _      -> textMySQLValue column fieldBytes+        KindLatin1Text  -> textMySQLValue column fieldBytes+        KindBytes       -> (# | MySQLBytes fieldBytes #)+        KindBit         -> case decodeTextBit fieldBytes of+            Left fieldError -> (# textFieldErrorKind fieldError | #)+            Right value     -> (# | value #)+        KindUnsupported -> (# FieldUnsupportedType fieldType | #)++textFieldErrorKind :: TextFieldError -> FieldErrorKind+textFieldErrorKind fieldError = case fieldError of+    TextFieldUnparsable _ fieldBytes     -> FieldUnparsable fieldBytes+    TextFieldBitTooWide width            -> FieldBitTooWide width+    TextFieldUnsupportedType fieldType   -> FieldUnsupportedType fieldType+    TextFieldInvalidUtf8 _ fieldBytes    -> FieldInvalidUtf8 fieldBytes++-- | A text field the lexer reads, evaluated.+lexedField :: (ByteString -> Maybe a) -> ParseBytes a+lexedField lexer = \fieldBytes -> case lexer fieldBytes of+    Just !value -> (# | value #)+    Nothing     -> (# FieldUnparsable fieldBytes | #)+{-# INLINE lexedField #-}++utf8Field :: ParseBytes Text+utf8Field fieldBytes = case T.decodeUtf8' fieldBytes of+    Right !decoded -> (# | decoded #)+    Left _         -> (# FieldInvalidUtf8 fieldBytes | #)++latin1Field :: ParseBytes Text+latin1Field fieldBytes = let !decoded = decodeMySQLLatin1 fieldBytes in (# | decoded #)++bytesField :: ParseBytes ByteString+bytesField fieldBytes = (# | fieldBytes #)++-- | A binary field of exactly @width@ bytes, evaluated.+fixedField :: Int -> (ByteString -> a) -> ParseBytes a+fixedField width decode = \fieldBytes ->+    if B.length fieldBytes == width+    then let !value = decode fieldBytes in (# | value #)+    else (# FieldUnparsable fieldBytes | #)+{-# INLINE fixedField #-}++-- | The binary protocol sends signed integers in two's complement, so the+-- signed value has the same bits as the unsigned one read from the wire.+int8Bits :: Word8 -> Int8+int8Bits (W8# bits) = I8# (word8ToInt8# bits)++int16Bits :: Word16 -> Int16+int16Bits (W16# bits) = I16# (word16ToInt16# bits)++int32Bits :: Word32 -> Int32+int32Bits (W32# bits) = I32# (word32ToInt32# bits)++int64Bits :: Word64 -> Int64+int64Bits (W64# bits) = I64# (word64ToInt64# bits)++littleEndian16 :: ByteString -> Word16+littleEndian16 = B.foldr' prependByte16 0++littleEndian32 :: ByteString -> Word32+littleEndian32 = B.foldr' prependByte32 0++littleEndian64 :: ByteString -> Word64+littleEndian64 = B.foldr' prependByte64 0++prependByte16 :: Word8 -> Word16 -> Word16+prependByte16 byte higherBytes = unsafeShiftL higherBytes 8 .|. Word8.toWord16 byte++prependByte32 :: Word8 -> Word32 -> Word32+prependByte32 byte higherBytes = unsafeShiftL higherBytes 8 .|. Word8.toWord32 byte++prependByte64 :: Word8 -> Word64 -> Word64+prependByte64 byte higherBytes = unsafeShiftL higherBytes 8 .|. Word8.toWord64 byte++-- | A binary DATE: no bytes for the zero date, or a 2-byte year, month and day.+binaryDateParts :: ParseBytes RawDate+binaryDateParts fieldBytes =+    if  | B.null fieldBytes        -> (# | RawDate 0 0 0 #)+        | B.length fieldBytes == 4 -> let !date = binaryDate fieldBytes in (# | date #)+        | otherwise                -> (# FieldUnparsable fieldBytes | #)++binaryDate :: ByteString -> RawDate+binaryDate fieldBytes = RawDate+    (littleEndian16 (B.unsafeTake 2 fieldBytes))+    (B.unsafeIndex fieldBytes 2)+    (B.unsafeIndex fieldBytes 3)++-- | A binary DATETIME or TIMESTAMP: its length says which parts are present,+-- 0 (the zero date), 4 (the date), 7 (and the time) or 11 (and microseconds).+binaryDateTimeParts :: ParseBytes (RawDate, TimeOfDay)+binaryDateTimeParts fieldBytes =+    if  | B.null fieldBytes ->+            (# | (RawDate 0 0 0, midnight) #)+        | B.length fieldBytes == 4 ->+            let !value = (binaryDate fieldBytes, midnight) in (# | value #)+        | B.length fieldBytes == 7 || B.length fieldBytes == 11 ->+            let !value = (binaryDate fieldBytes, binaryClock (B.unsafeDrop 4 fieldBytes))+            in (# | value #)+        | otherwise -> (# FieldUnparsable fieldBytes | #)++calendarDay :: ParseBytes RawDate -> ParseBytes Day+calendarDay parse = \fieldBytes -> case parse fieldBytes of+    (# kind | #) -> (# kind | #)+    (# | raw #) -> case calendarDate raw of+        Right !date -> (# | date #)+        Left unrepresentable -> (# FieldUnrepresentableDate unrepresentable | #)+{-# INLINE calendarDay #-}++calendarLocalTime :: ParseBytes (RawDate, TimeOfDay) -> ParseBytes LocalTime+calendarLocalTime parse = \fieldBytes -> case parse fieldBytes of+    (# kind | #) -> (# kind | #)+    (# | (raw, time) #) -> case calendarDate raw of+        Right date -> let !value = LocalTime date time in (# | value #)+        Left unrepresentable -> (# FieldUnrepresentableDate unrepresentable | #)+{-# INLINE calendarLocalTime #-}++-- | Hours, minutes and seconds, then microseconds when 7 bytes are left.+binaryClock :: ByteString -> TimeOfDay+binaryClock clock = TimeOfDay+    (Word8.toInt (B.unsafeIndex clock 0))+    (Word8.toInt (B.unsafeIndex clock 1))+    (binarySeconds (B.unsafeIndex clock 2) (B.unsafeDrop 3 clock))++-- | Whole seconds plus the 4-byte microseconds if present, exactly: a 'Pico'+-- counts 10^12 per second.+binarySeconds :: Word8 -> ByteString -> Pico+binarySeconds seconds microseconds = MkFixed+    (Word8.toInteger seconds * 1000000000000+        + (if B.length microseconds == 4+           then Word32.toInteger (littleEndian32 microseconds) * 1000000+           else 0))++-- | A binary TIME: no bytes for zero, or a sign, 4-byte days, hours, minutes,+-- seconds and, in the 12-byte form, microseconds. The sign is 1 for negative.+binarySignedTime :: ParseBytes (Word8, TimeOfDay)+binarySignedTime fieldBytes =+    if  | B.null fieldBytes -> (# | (0, midnight) #)+        | B.length fieldBytes == 8 || B.length fieldBytes == 12 ->+            case Word32.toInt (littleEndian32 (B.unsafeTake 4 (B.unsafeDrop 1 fieldBytes))) of+                Nothing -> (# FieldUnparsable fieldBytes | #)+                Just days ->+                    let !value = ( B.unsafeHead fieldBytes+                                 , TimeOfDay (days * 24 + Word8.toInt (B.unsafeIndex fieldBytes 5))+                                             (Word8.toInt (B.unsafeIndex fieldBytes 6))+                                             (binarySeconds (B.unsafeIndex fieldBytes 7)+                                                            (B.unsafeDrop 8 fieldBytes)) )+                    in (# | value #)+        | otherwise -> (# FieldUnparsable fieldBytes | #)++nonNegativeTime :: ParseBytes (Word8, TimeOfDay) -> ParseBytes TimeOfDay+nonNegativeTime parse = \fieldBytes -> case parse fieldBytes of+    (# kind | #) -> (# kind | #)+    (# | (sign, time) #) ->+        if sign == 0 then (# | time #) else (# FieldNegativeTime fieldBytes | #)+{-# INLINE nonNegativeTime #-}++-- | Decodes a row, one 'field' per column, in order. It is checked against the+-- result set's column definitions once, before the first row.+--+-- @since 1.4.0+data RowDecoder a = RowDecoder+    !Int+    -- ^ how many columns it reads+    (forall protocol. RowProtocol protocol+        => V.Vector ColumnDef -> ColumnNumber -> Either ColumnMismatch (FieldSteps protocol a))+    -- ^ fits it to the columns from the given column number on++-- Decision: the instance methods and the step combinators are inlined, so that+-- a decoder written as one expression, such as @Employee \<$\> field a \<*\>+-- field b@, compiles to one walk that applies @Employee@ to all its fields at+-- once. Left to the closures of the run-time composition, every field paid a+-- generic partial application of the constructor (about 1,400 of 9,300+-- instructions per row on the employees benchmark).+instance Functor RowDecoder where+    fmap f (RowDecoder width prepare) =+        RowDecoder width (\columns start -> mapSteps f <$> prepare columns start)+    {-# INLINE fmap #-}++instance Applicative RowDecoder where+    pure value = RowDecoder 0 (\_ _ -> Right (pureSteps value))+    {-# INLINE pure #-}+    RowDecoder functionWidth prepareFunction <*> RowDecoder argumentWidth prepareArgument =+        RowDecoder (functionWidth + argumentWidth) (\columns start ->+            apSteps <$> prepareFunction columns start+                    <*> prepareArgument columns (columnsAfter start functionWidth))+    {-# INLINE (<*>) #-}++-- | Decodes the next column with this decoder.+--+-- @since 1.4.0+field :: FieldDecoder a -> RowDecoder a+field decoder = RowDecoder 1 (\columns column@(ColumnNumber number) -> case columns V.!? number of+    Nothing -> Left (ColumnCountMismatch (number + 1) (V.length columns))+    Just definition ->+        fieldSteps column definition <$> prepareFieldParser decoder column definition)+{-# INLINE field #-}++-- | The column @count@ columns after @column@.+columnsAfter :: ColumnNumber -> Int -> ColumnNumber+columnsAfter (ColumnNumber column) count = ColumnNumber (column + count)++-- | Reads fields from a row's bytes at an offset, and returns the offset after+-- them. A row is walked once, in column order, each field parsed as it is+-- reached, so no field bounds are stored.+newtype FieldSteps (protocol :: Type) a = FieldSteps (ByteString -> Int -> (# FieldError | (# a, Int #) #))++pureSteps :: a -> FieldSteps protocol a+pureSteps value = FieldSteps (\_ offset -> (# | (# value, offset #) #))+{-# INLINE pureSteps #-}++mapSteps :: (a -> b) -> FieldSteps protocol a -> FieldSteps protocol b+mapSteps f (FieldSteps run) = FieldSteps (\row offset -> case run row offset of+    (# fieldError | #)        -> (# fieldError | #)+    (# | (# value, next #) #) -> let !mapped = f value in (# | (# mapped, next #) #))+{-# INLINE mapSteps #-}++-- | Applies as soon as both sides are decoded, so a row decodes to an evaluated+-- value instead of a chain of thunks that each later force has to update.+apSteps :: FieldSteps protocol (a -> b) -> FieldSteps protocol a -> FieldSteps protocol b+apSteps (FieldSteps runFunction) (FieldSteps runArgument) = FieldSteps (\row offset ->+    case runFunction row offset of+        (# fieldError | #) -> (# fieldError | #)+        (# | (# function, afterFunction #) #) -> case runArgument row afterFunction of+            (# fieldError | #) -> (# fieldError | #)+            (# | (# argument, afterArgument #) #) ->+                let !applied = function argument in (# | (# applied, afterArgument #) #))+{-# INLINE apSteps #-}++-- | A 'RowDecoder' fitted to a result set's columns.+--+-- @since 1.4.0+data PreparedRow (protocol :: Type) a = PreparedRow (RowStart protocol) (FieldSteps protocol a)++-- | Where a row's first field starts, or why the row is too short to have one.+newtype RowStart (protocol :: Type) = RowStart (ByteString -> (# FieldError | Int #))++-- | Fits a 'RowDecoder' to a result set's columns. It must read exactly as many+-- columns as there are, each of a type its decoder accepts.+--+-- @since 1.4.0+prepareRowDecoder :: RowProtocol protocol+                  => RowDecoder a -> V.Vector ColumnDef -> Either ColumnMismatch (PreparedRow protocol a)+prepareRowDecoder (RowDecoder width prepare) columns =+    if width /= V.length columns+    then Left (ColumnCountMismatch width (V.length columns))+    else PreparedRow (rowStart width) <$> prepare columns (ColumnNumber 0)++-- | Decodes the body of a row packet of the protocol. Bytes after the last+-- field are ignored, as 'decodeTextRow' ignores them.+--+-- @since 1.4.0+runPreparedRow :: PreparedRow protocol a -> ByteString -> Either FieldError a+runPreparedRow (PreparedRow (RowStart start) (FieldSteps run)) row = case start row of+    (# fieldError | #) -> Left fieldError+    (# | offset #) -> case run row offset of+        (# fieldError | #)     -> Left fieldError+        (# | (# value, _ #) #) -> Right value++-- | 'TextProtocol' or 'BinaryProtocol': how the rows of that protocol lay out+-- their fields, and which of a 'FieldDecoder''s parsers they need.+--+-- @since 1.4.0+class RowProtocol (protocol :: Type) where+    protocolParser :: FieldDecoder a -> ColumnKind -> Maybe (FieldParser protocol a)+    fieldSteps     :: ColumnNumber -> ColumnDef -> FieldParser protocol a -> FieldSteps protocol a+    rowStart       :: Int -> RowStart protocol++instance RowProtocol TextProtocol where+    protocolParser decoder column = FieldParser (decoderNull decoder) <$> decoderText decoder column+    fieldSteps column _ parser = FieldSteps (textFieldStep column parser)+    rowStart _ = RowStart textRowStart++instance RowProtocol BinaryProtocol where+    protocolParser decoder column = FieldParser (decoderNull decoder) <$> decoderBinary decoder column+    fieldSteps column definition parser =+        FieldSteps (binaryFieldStep column (binaryWidth definition) parser)+    rowStart columnCount = RowStart (binaryRowStart columnCount)++textRowStart :: ByteString -> (# FieldError | Int #)+textRowStart _ = (# | 0 #)++-- | A text-protocol field: the NULL marker or a length-encoded value.+textFieldStep :: ColumnNumber -> FieldParser TextProtocol a -> ByteString -> Int -> (# FieldError | (# a, Int #) #)+textFieldStep column parser = \row offset ->+    if  | offset >= B.length row -> (# FieldError column FieldRowEndsEarly | #)+        | B.unsafeIndex row offset == 0xFB -> nullStep column parser (offset + 1)+        | otherwise -> lengthEncodedStep column parser row offset+{-# INLINE textFieldStep #-}++-- | The fields of a binary-protocol row follow the 0x00 header and the NULL map.+binaryRowStart :: Int -> ByteString -> (# FieldError | Int #)+binaryRowStart columnCount row =+    let start = 1 + RawRow.binaryNullMapLength columnCount+    in if start > B.length row then (# FieldError (ColumnNumber 0) FieldRowEndsEarly | #) else (# | start #)++-- | A binary-protocol field: absent when the NULL map marks it, otherwise laid+-- out as its column's 'BinaryWidth' says.+binaryFieldStep :: ColumnNumber -> BinaryWidth -> FieldParser BinaryProtocol a -> ByteString -> Int+                -> (# FieldError | (# a, Int #) #)+binaryFieldStep column width parser = \row offset ->+    if RawRow.isNullInMap row column+    then nullStep column parser offset+    else case width of+        BinaryNoBytes       -> sliceStep column parser row offset 0+        BinaryFixed size    -> sliceStep column parser row offset size+        BinaryLengthEncoded ->+            if offset >= B.length row+            then (# FieldError column FieldRowEndsEarly | #)+            else lengthEncodedStep column parser row offset+{-# INLINE binaryFieldStep #-}++nullStep :: ColumnNumber -> FieldParser protocol a -> Int -> (# FieldError | (# a, Int #) #)+nullStep column parser next = case parserNull parser of+    Just value -> (# | (# value, next #) #)+    Nothing    -> (# FieldError column FieldUnexpectedNull | #)++-- | A length at @offset@, which must be inside the row, then that many bytes.+lengthEncodedStep :: ColumnNumber -> FieldParser protocol a -> ByteString -> Int -> (# FieldError | (# a, Int #) #)+lengthEncodedStep column parser row offset = case lengthEncodedInt row offset of+    (# kind | #) -> (# FieldError column (lengthErrorKind kind) | #)+    (# | (# fieldLength, fieldStart #) #) -> sliceStep column parser row fieldStart fieldLength++sliceStep :: ColumnNumber -> FieldParser protocol a -> ByteString -> Int -> Int -> (# FieldError | (# a, Int #) #)+sliceStep column parser row start fieldLength =+    if fieldLength > B.length row - start+    then (# FieldError column FieldRowEndsEarly | #)+    else case parserBytes parser (B.unsafeTake fieldLength (B.unsafeDrop start row)) of+        (# kind | #)  -> (# FieldError column kind | #)+        (# | value #) -> (# | (# value, start + fieldLength #) #)++lengthErrorKind :: RowErrorKind -> FieldErrorKind+lengthErrorKind kind = case kind of+    RowEndsEarly                  -> FieldRowEndsEarly+    RowInvalidLengthPrefix prefix -> FieldInvalidLengthPrefix prefix+    RowLengthOverflow             -> FieldLengthOverflow+    RowFieldError fieldError      -> textFieldErrorKind fieldError++-- | A 'FieldDecoder' fitted to one column of a result set.+--+-- @since 1.4.0+data FieldParser (protocol :: Type) a = FieldParser+    { parserNull  :: !(Maybe a)+    , parserBytes :: ParseBytes a+    }++-- | Fits a 'FieldDecoder' to column number @column@, whose definition this is.+-- Prepare once per result set, with the columns+-- 'Database.MySQL.Base.queryRawRows_' returns:+--+-- > (columns, rows) <- queryRawRows_ conn "SELECT emp_no, first_name FROM employees"+-- > numberColumn : nameColumn : _ <- pure columns+-- > numbers <- either throwIO pure (prepareFieldParser int32 (ColumnNumber 0) numberColumn)+-- > names <- either throwIO pure (prepareFieldParser text (ColumnNumber 1) nameColumn)+--+-- @since 1.4.0+prepareFieldParser :: RowProtocol protocol+                   => FieldDecoder a -> ColumnNumber -> ColumnDef -> Either ColumnMismatch (FieldParser protocol a)+prepareFieldParser decoder column definition =+    case protocolParser decoder (columnKind definition) of+        Just parser -> Right parser+        Nothing     -> Left (ColumnTypeMismatch column (columnName definition)+                                (columnType definition) (decoderTypeName decoder))++-- | Decodes field @column@ of a 'RawRow', passing the outcome to a continuation+-- so that no 'Either' is allocated, as a library decoding by column number+-- needs. With the parsers from 'prepareFieldParser', each row's fields chain+-- through the continuations:+--+-- > rawRows <- Streams.toList rows+-- > forM_ rawRows $ \row ->+-- >     runFieldParser numbers row (ColumnNumber 0) throwIO $ \number ->+-- >     runFieldParser names row (ColumnNumber 1) throwIO $ \name ->+-- >     print (number, name)+--+-- @since 1.4.0+runFieldParser :: FieldParser protocol a -> RawRow protocol -> ColumnNumber -> (FieldError -> r) -> (a -> r) -> r+runFieldParser parser row column onError onValue = case parseRawField column parser row of+    (# fieldError | #) -> onError fieldError+    (# | value #)      -> onValue value+{-# INLINE runFieldParser #-}++parseRawField :: ColumnNumber -> FieldParser protocol a -> RawRow protocol -> (# FieldError | a #)+parseRawField column parser row = case rawField row column of+    RawNull -> case parserNull parser of+        Just value -> (# | value #)+        Nothing    -> (# FieldError column FieldUnexpectedNull | #)+    RawBytes fieldBytes -> case parserBytes parser fieldBytes of+        (# kind | #)  -> (# FieldError column kind | #)+        (# | value #) -> (# | value #)+    RawAbsent -> (# FieldError column FieldAbsent | #)++-- | A prepared statement's columns, resolved once per result set for+-- 'decodeBinaryValues'.+--+-- @since 1.4.0+data BinaryValueColumns = BinaryValueColumns !Int [BinaryValueColumn]++data BinaryValueColumn = BinaryValueColumn !ColumnKind !BinaryWidth++-- | @since 1.4.0+binaryValueColumns :: [ColumnDef] -> BinaryValueColumns+binaryValueColumns definitions = BinaryValueColumns (length definitions)+    (map (\definition -> BinaryValueColumn (columnKind definition) (binaryWidth definition)) definitions)++-- | The values of a binary-protocol row, as+-- 'Database.MySQL.Protocol.MySQLValue.getBinaryRow' gives them, in one walk+-- over the row that calls the value parser directly, as 'decodeTextRow' does+-- for the text protocol. Bytes after the last field are ignored.+--+-- @since 1.4.0+decodeBinaryValues :: BinaryValueColumns -> ByteString -> Either FieldError [MySQLValue]+decodeBinaryValues (BinaryValueColumns columnCount columns) row = case binaryRowStart columnCount row of+    (# fieldError | #) -> Left fieldError+    (# | start #) -> case binaryValueFields row (ColumnNumber 0) start columns of+        (# fieldError | #) -> Left fieldError+        (# | values #)     -> Right values++binaryValueFields :: ByteString -> ColumnNumber -> Int -> [BinaryValueColumn] -> (# FieldError | [MySQLValue] #)+binaryValueFields row column offset columns = case columns of+    [] -> (# | [] #)+    BinaryValueColumn kind width : laterColumns ->+        case binaryFieldStep column width (FieldParser (Just MySQLNull) (binaryMySQLValue kind)) row offset of+            (# fieldError | #) -> (# fieldError | #)+            (# | (# value, next #) #) -> case binaryValueFields row (nextColumn column) next laterColumns of+                (# fieldError | #) -> (# fieldError | #)+                (# | values #)     -> (# | value : values #)++-- | A result set that does not fit a 'RowDecoder', raised before any row is read.+--+-- @since 1.4.0+data ColumnMismatch+    = ColumnTypeMismatch !ColumnNumber !ByteString !FieldType !Text+      -- ^ column number, column name, its type, and the Haskell type of the+      -- decoder that does not accept it+    | ColumnCountMismatch !Int !Int+      -- ^ how many columns the decoder reads, how many the result set has+    deriving (Show, Eq)++instance Exception ColumnMismatch++-- | A field that did not decode, with its column number.+--+-- @since 1.4.0+data FieldError = FieldError+    { fieldErrorColumn :: !ColumnNumber+    , fieldErrorKind   :: !FieldErrorKind+    } deriving (Show, Eq)++instance Exception FieldError++-- | @since 1.4.0+data FieldErrorKind+    = FieldUnexpectedNull+      -- ^ a NULL for a decoder that takes none; see 'nullable'+    | FieldUnparsable !ByteString+      -- ^ the bytes are not a value of the column's type+    | FieldInvalidUtf8 !ByteString+    | FieldUnrepresentableDate !RawDate+      -- ^ a date 'day' or 'localTime' cannot give as a 'Day', such as @0000-00-00@;+      -- 'mysqlValue' gives it as a 'MySQLDateRaw' instead+    | FieldNegativeTime !ByteString+      -- ^ a negative TIME for 'timeOfDay'+    | FieldBitTooWide !Int+      -- ^ a BIT field longer than the 8 bytes of a 'Word64'+    | FieldUnsupportedType !FieldType+      -- ^ a column type 'mysqlValue' has no decoder for+    | FieldAbsent+      -- ^ the 'RawRow' has no field with that column number+    | FieldRowEndsEarly+      -- ^ the row ends inside or before this field+    | FieldInvalidLengthPrefix !Word8+      -- ^ a field starting with a byte that is neither a length nor the NULL marker+    | FieldLengthOverflow+      -- ^ an 8-byte length above 'maxBound' of 'Int'+    deriving (Show, Eq)

@@ -98,6 +98,10 @@     | DecodeUnexpectedNull !ExpectedTypeName       -- ^ The value was @MySQLNull@ but the requested type is not       -- 'Maybe'; wrap the type in 'Maybe' for nullable columns.+    | DecodeUnrepresentableDate !ExpectedTypeName !MySQLValue+      -- ^ A @DATE@, @DATETIME@ or @TIMESTAMP@ whose date the requested type+      -- cannot hold, such as the zero date @0000-00-00@; see+      -- 'Database.MySQL.Protocol.MySQLValue.RawDate'.     deriving (Show, Eq)  instance Exception DecodeError@@ -335,8 +339,9 @@ encodeDay = MySQLDate  decodeDay :: MySQLValue -> Either DecodeError Day-decodeDay (MySQLDate d) = Right d-decodeDay value         = decodeFailure (ExpectedTypeName "Day") value+decodeDay (MySQLDate d)          = Right d+decodeDay value@(MySQLDateRaw _) = Left (DecodeUnrepresentableDate (ExpectedTypeName "Day") value)+decodeDay value                  = decodeFailure (ExpectedTypeName "Day") value  instance Field Day where     toField = encodeDay@@ -352,6 +357,10 @@ decodeLocalTime :: MySQLValue -> Either DecodeError LocalTime decodeLocalTime (MySQLDateTime t)  = Right t decodeLocalTime (MySQLTimeStamp t) = Right t+decodeLocalTime value@(MySQLDateTimeRaw _ _) =+    Left (DecodeUnrepresentableDate (ExpectedTypeName "LocalTime") value)+decodeLocalTime value@(MySQLTimeStampRaw _ _) =+    Left (DecodeUnrepresentableDate (ExpectedTypeName "LocalTime") value) decodeLocalTime value              = decodeFailure (ExpectedTypeName "LocalTime") value  instance Field LocalTime where

@@ -52,6 +52,62 @@ #define CLIENT_CONNECT_ATTRS                  0x00100000 #define CLIENT_PLUGIN_AUTH_LENENC_CLIENT_DATA 0x00200000 +-- MariaDB reuses the obsolete CLIENT_LONG_PASSWORD bit to mean "MySQL client+-- or server". See Note [MariaDB extended capabilities].+#define CLIENT_MYSQL                          CLIENT_LONG_PASSWORD++{- Note [MariaDB extended capabilities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+MariaDB has capabilities beyond the 32 bits of the MySQL handshake+(MARIADB_CLIENT_* in mariadb-connector-c's mariadb_com.h, bits 32 to 36). A+MariaDB server leaves CLIENT_MYSQL out of its greeting and puts the upper 32+bits in the last four of the greeting's ten reserved bytes. A client answers+with its own upper bits in the last four of the 23 reserved bytes of the SSL+request and the handshake response, and must leave CLIENT_MYSQL out as well,+or the server ignores those bytes.++mysql-haskell sets CLIENT_MYSQL by default and writes zeroes there, so a+MariaDB server treats it as a MySQL client. Only a connection that asks for an+extended capability, to a server that offers it, sends anything different:+'negotiateExtended' yields 'noExtendedCapabilities' otherwise, and every+encoder below writes exactly the bytes it wrote before extended capabilities+existed. A MySQL server always sets CLIENT_MYSQL, so it never sees the change.+-}++-- | MariaDB's capabilities above bit 31, shifted down by 32, so bit 0 here is+-- MARIADB_CLIENT_PROGRESS. See Note [MariaDB extended capabilities].+--+-- @since 1.4.0+newtype ExtendedCapabilities = ExtendedCapabilities Word32 deriving (Show, Eq)++-- | What every connection sent before extended capabilities existed.+--+-- @since 1.4.0+noExtendedCapabilities :: ExtendedCapabilities+noExtendedCapabilities = ExtendedCapabilities 0++-- | The extended capabilities a connection uses: those the client asked for+-- that the server offered, or none when the server is not a MariaDB server+-- reading them.+--+-- @since 1.4.0+negotiateExtended :: ExtendedCapabilities  -- ^ requested by the client+                  -> Greeting+                  -> ExtendedCapabilities  -- ^ offered in that greeting+                  -> ExtendedCapabilities+negotiateExtended (ExtendedCapabilities requested) greeting (ExtendedCapabilities offered) =+    if offersExtendedCapabilities greeting+    then ExtendedCapabilities (requested .&. offered)+    else noExtendedCapabilities++-- | Whether the greeting comes from a server speaking MariaDB's protocol+-- extensions: MariaDB 10.2 and later leave CLIENT_MYSQL out of it, MySQL and+-- older MariaDB set it. See Note [MariaDB extended capabilities].+--+-- @since 1.4.0+offersExtendedCapabilities :: Greeting -> Bool+offersExtendedCapabilities greeting = greetingCaps greeting .&. CLIENT_MYSQL == 0+ data Greeting = Greeting     { greetingProtocol :: !Word8     , greetingVersion  :: !B.ByteString@@ -85,7 +141,14 @@         (putByteString authPlugin)  getGreeting :: Get Greeting-getGreeting = do+getGreeting = fst <$> getGreetingExtended++-- | 'getGreeting' together with the extended capabilities a MariaDB server+-- offers; MySQL servers send zeroes there.+--+-- @since 1.4.0+getGreetingExtended :: Get (Greeting, ExtendedCapabilities)+getGreetingExtended = do     pv <- getWord8     sv <- getByteStringNul     cid <- getWord32le@@ -97,7 +160,8 @@     capH <- getWord16le     let cap = fromIntegral capH `shiftL` 16 .|. fromIntegral capL     _authPluginLen <- getWord8   -- this will issue an unused warning, see the notes below-    skipN 10 -- 10 * 0x00+    skipN 6+    extended <- ExtendedCapabilities <$> getWord32le     salt2 <- if (cap .&. CLIENT_SECURE_CONNECTION) == 0         then pure B.empty         else getByteStringNul   -- This is different with the MySQL document here@@ -109,7 +173,7 @@         then pure B.empty         else getByteStringNul -    return (Greeting pv sv cid salt1 cap charset status salt2 authPlugin)+    return (Greeting pv sv cid salt1 cap charset status salt2 authPlugin, extended)  instance Binary Greeting where     get = getGreeting@@ -135,11 +199,19 @@     return $ Auth a m c n B.empty B.empty B.empty  putAuth :: Auth -> Put-putAuth (Auth cap m c n p s plugin) = do+putAuth = putAuthExtended noExtendedCapabilities++-- | 'putAuth' carrying negotiated extended capabilities; 'authCaps' must then+-- leave CLIENT_MYSQL out, see 'clientCapFor'.+--+-- @since 1.4.0+putAuthExtended :: ExtendedCapabilities -> Auth -> Put+putAuthExtended (ExtendedCapabilities extended) (Auth cap m c n p s plugin) = do     putWord32le cap     putWord32le m     putWord8 c-    replicateM_ 23 (putWord8 0x00)+    replicateM_ 19 (putWord8 0x00)+    putWord32le extended     putByteString n >> putWord8 0x00     putWord8 $ fromIntegral (B.length p)     putByteString p@@ -162,11 +234,19 @@ getSSLRequest = SSLRequest <$> getWord32le <*> getWord32le <*> getWord8 <* skipN 23  putSSLRequest :: SSLRequest -> Put-putSSLRequest (SSLRequest cap m c) = do+putSSLRequest = putSSLRequestExtended noExtendedCapabilities++-- | 'putSSLRequest' carrying negotiated extended capabilities. MariaDB reads+-- them from the SSL request too, before the TLS handshake.+--+-- @since 1.4.0+putSSLRequestExtended :: ExtendedCapabilities -> SSLRequest -> Put+putSSLRequestExtended (ExtendedCapabilities extended) (SSLRequest cap m c) = do     putWord32le cap     putWord32le m     putWord8 c-    replicateM_ 23 (putWord8 0x00)+    replicateM_ 19 (putWord8 0x00)+    putWord32le extended  instance Binary SSLRequest where     get = getSSLRequest@@ -187,6 +267,15 @@                 .|. CLIENT_SECURE_CONNECTION                 .|. CLIENT_PLUGIN_AUTH +-- | 'clientCap' for a connection using these extended capabilities.+--+-- @since 1.4.0+clientCapFor :: ExtendedCapabilities -> Word32+clientCapFor negotiated =+    if negotiated == noExtendedCapabilities+    then clientCap+    else clientCap .&. complement CLIENT_MYSQL+ clientMaxPacketSize :: Word32 clientMaxPacketSize = 0x00ffffff :: Word32 @@ -195,4 +284,12 @@ supportTLS x = (x .&. CLIENT_SSL) /= 0  sslRequest :: Word8 -> SSLRequest-sslRequest charset = SSLRequest (clientCap .|. CLIENT_SSL) clientMaxPacketSize charset+sslRequest = sslRequestFor noExtendedCapabilities++-- | 'sslRequest' for a connection using these extended capabilities; encode+-- it with 'putSSLRequestExtended'.+--+-- @since 1.4.0+sslRequestFor :: ExtendedCapabilities -> Word8 -> SSLRequest+sslRequestFor negotiated charset =+    SSLRequest (clientCapFor negotiated .|. CLIENT_SSL) clientMaxPacketSize charset

@@ -22,6 +22,7 @@ import           Data.Binary.Put import           Data.Bits                      ((.&.)) import           Data.ByteString                (ByteString)+import qualified Data.ByteString                as B import           Database.MySQL.Protocol.Packet  --------------------------------------------------------------------------------@@ -43,21 +44,63 @@     } deriving (Show, Eq)  getField :: Get ColumnDef-getField = ColumnDef-        <$> (skipN 4                 -- const "def"-         *> getLenEncBytes)         -- db-        <*> getLenEncBytes          -- table-        <*> getLenEncBytes          -- origTable-        <*> getLenEncBytes          -- name-        <*> getLenEncBytes          -- origName-        <*  skipN 1                  -- const 0x0c-        <*> getWord16le             -- charset+getField = fst <$> getFieldExtended+{-# INLINE getField #-}++-- | 'getField' together with the raw MariaDB extended metadata, empty when the+-- server sent none. See Note [Extended column metadata].+--+-- @since 1.4.0+getFieldExtended :: Get (ColumnDef, ByteString)+getFieldExtended = do+    skipN 4                         -- const "def"+    db        <- getLenEncBytes+    table     <- getLenEncBytes+    origTable <- getLenEncBytes+    name      <- getLenEncBytes+    origName  <- getLenEncBytes+    extended  <- getExtendedMetadataBlock+    skipN 1                         -- const 0x0c+    column <- ColumnDef db table origTable name origName+        <$> getWord16le             -- charset         <*> getWord32le             -- length         <*> getFieldType            -- type         <*> getWord16le             -- flags         <*> getWord8                -- decimals-        <* skipN 2                   -- const 0x00 0x00-{-# INLINE getField #-}+    skipN 2                         -- const 0x00 0x00+    pure (column, extended)+{-# INLINE getFieldExtended #-}++{- Note [Extended column metadata]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A MariaDB connection that negotiated MARIADB_CLIENT_EXTENDED_METADATA gets a+length-encoded string between the column names and the fixed fields, holding+type names such as "json" or "uuid". The connection does not record what it+negotiated (MySQLConn's fields are public), so the parser recognises the block+from the packet instead: without it, the 0x0c that starts the fixed fields is+followed by exactly 12 bytes, which is how both MySQL and MariaDB end every+column definition of a result set or a prepared statement. A block of 12 bytes+also starts with 0x0c, but then 25 bytes follow. Column definitions from the+deprecated COM_FIELD_LIST carry default values after the fixed fields; this+library never sends that command.+-}++-- Decision: detect the block from the packet length rather than carry the+-- negotiated capabilities to every parser. Carrying them needs a new field in+-- MySQLConn, whose constructor callers pattern match on, and threads a flag+-- through each query function; the length test changes nothing for+-- connections that did not negotiate the block.+getExtendedMetadataBlock :: Get ByteString+getExtendedMetadataBlock = do+    fixedFieldsNext <- lookAhead startsFixedFields+    if fixedFieldsNext then pure B.empty else getLenEncBytes++startsFixedFields :: Get Bool+startsFixedFields = do+    marker <- getWord8+    if marker == 0x0c+    then skipN 12 *> isEmpty+    else pure False  putField :: ColumnDef -> Put putField (ColumnDef db tbl otbl name oname charset len typ flags dec) = do

@@ -0,0 +1,185 @@+{-|+Module      : Database.MySQL.Protocol.FloatingPoint+Description : FLOAT and DOUBLE text, correctly rounded+Copyright   : (c) Jappie Klooster, 2026+License     : BSD3+Maintainer  : hi@jappie.me+Stability   : experimental+Portability : PORTABLE++The text protocol sends FLOAT and DOUBLE values as decimal text, large ones in+exponent form such as @1e20@. 'readDouble' and 'readFloat' give the nearest+value, as 'read' does, and are fast for the short numbers MySQL usually writes.+See Note [Correctly rounded floating point text].+-}+module Database.MySQL.Protocol.FloatingPoint+  ( readDouble+  , readFloat+  ) where++import           Data.ByteString                (ByteString)+import qualified Data.ByteString                as B+import qualified Data.ByteString.Lex.Fractional as LexFrac+import           Data.Scientific                (Scientific, toRealFloat)+import           Data.Word                      (Word64, Word8)+import qualified Unwitch.Convert.Word64         as Word64+import qualified Unwitch.Convert.Word8          as Word8++{- Note [Correctly rounded floating point text]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Scaling decimal digits by @10 ^^ e@ in floating point rounds more than once.+bytestring-lexing's readExponential missed the nearest Double for 83% of+20,000 shown doubles, and its readDecimal, which also stops at an @e@ and so+read @1e20@ as 1, missed 2 of 243 plain decimals. Reading the text exactly as a+'Scientific' and rounding once with 'toRealFloat' missed none, but cost about+14,000 instructions per DOUBLE field.++Decision: Clinger's fast path first, then the exact way; the alternatives+above were wrong or slow. The fast path avoids the cost: when the significant+digits, read as an integer, lie in the exact integer range of a Double (below+2^53, where unwitch's 'Word64.toDouble' converts and every integer is exact)+and the power of ten is at most 22 either way, that power is exact as well, so+one multiplication or division rounds once and gives the nearest Double. A+Float takes integers below 2^24 and powers up to 10. A number with more than 19+significant digits does not fit a 'Word64' and has no significand at all, so+it never reaches the fast path. MySQL writes most values within these bounds;+the rest go the exact way.+-}++-- | The nearest 'Double' to the decimal number at the start of the bytes:+-- @-?digits(.digits)?([eE][+-]?digits)?@. Bytes after it are ignored.+readDouble :: ByteString -> Maybe Double+readDouble bytes = do+    decimal <- scanDecimal bytes+    case fastSignificand Word64.toDouble 22 decimal of+        Just exactDigits -> Just (signed decimal (scaleExactly exactDigits (decimalExponent decimal)))+        Nothing          -> exactly bytes++-- | 'readDouble' for 'Float'.+readFloat :: ByteString -> Maybe Float+readFloat bytes = do+    decimal <- scanDecimal bytes+    case fastSignificand Word64.toFloat 10 decimal of+        Just exactDigits -> Just (signed decimal (scaleExactly exactDigits (decimalExponent decimal)))+        Nothing          -> exactly bytes++-- | The significand as an exact @a@, when the fast path applies: it has at+-- most 19 digits, @toExactInteger@ converts it (unwitch's conversions fail+-- outside the exact integer range of the type), and the power of ten is+-- within @maxPower@ either way. 'Nothing' sends the number the exact way, so+-- the conversion's failure is a choice of path, not a lost error.+-- See Note [Correctly rounded floating point text].+fastSignificand :: (Word64 -> Either overflow a) -> Int -> DecimalText -> Maybe a+fastSignificand toExactInteger maxPower decimal = do+    digits <- decimalSignificand decimal+    if abs (decimalExponent decimal) <= maxPower+    then either (const Nothing) Just (toExactInteger digits)+    else Nothing++-- | The significand times @10 ^ powerOfTen@, with one rounding: the caller+-- guarantees that the significand and the power of ten are both exact.+scaleExactly :: RealFloat a => a -> Int -> a+scaleExactly exactDigits powerOfTen =+    if powerOfTen >= 0+    then exactDigits * 10 ^ powerOfTen+    else exactDigits / 10 ^ negate powerOfTen++signed :: Num a => DecimalText -> a -> a+signed decimal = signed' (decimalSign decimal)++signed' :: Num a => Sign -> a -> a+signed' sign magnitude = case sign of+    Positive -> magnitude+    Negative -> negate magnitude++-- | The text read exactly as a 'Scientific', then rounded once.+exactly :: RealFloat a => ByteString -> Maybe a+exactly bytes = toRealFloat <$> exactScientific bytes++exactScientific :: ByteString -> Maybe Scientific+exactScientific bytes = fst <$> LexFrac.readSigned LexFrac.readExponential bytes++data Sign = Positive | Negative++-- | A decimal number in text, as far as the fast path needs it.+data DecimalText = DecimalText+    { decimalSign        :: !Sign+    , decimalSignificand :: !(Maybe Word64)+      -- ^ the digits from the first non-zero one on, without the point, as one+      -- integer; 'Nothing' when there are more than 19, too many for a 'Word64'+    , decimalExponent    :: !Int+      -- ^ the power of ten the significand is scaled by; 'maxBound' when the+      -- written exponent has more digits than the fast path takes+    }++-- | The number at the start of the bytes, or 'Nothing' when they do not+-- start with one.+scanDecimal :: ByteString -> Maybe DecimalText+scanDecimal bytes =+    let (sign, afterSign) = splitSign bytes+        (integerPart, afterInteger) = B.span isDigit afterSign+        (fractionPart, afterFraction) = splitFraction afterInteger+        digits = integerPart <> fractionPart+        significant = B.dropWhile (== 48) digits  -- '0'+    in if B.null integerPart+       then Nothing+       else Just DecimalText+           { decimalSign        = sign+           , decimalSignificand =+               if B.length significant <= 19+               then Just (B.foldl' appendDigit 0 significant)+               else Nothing+           , decimalExponent    = writtenExponent afterFraction `minusDigits` B.length fractionPart+           }++-- | The exponent after @e@ or @E@, 0 when there is none; 'maxBound' when it+-- has more than 6 digits, which no FLOAT or DOUBLE needs.+writtenExponent :: ByteString -> Int+writtenExponent bytes = case B.uncons bytes of+    Just (marker, rest) ->+        if marker == 101 || marker == 69          -- 'e', 'E'+        then exponentDigits rest+        else 0+    Nothing -> 0++exponentDigits :: ByteString -> Int+exponentDigits bytes =+    let (sign, afterSign) = splitSign bytes+        digits = B.takeWhile isDigit afterSign+    in if  | B.null digits       -> 0+           | B.length digits > 6 -> maxBound+           | otherwise           -> signed' sign (B.foldl' appendDigitInt 0 digits)++-- | A leading @-@ or @+@, and the bytes after it.+splitSign :: ByteString -> (Sign, ByteString)+splitSign bytes = case B.uncons bytes of+    Nothing -> (Positive, bytes)+    Just (byte, rest) ->+        if  | byte == 45 -> (Negative, rest)  -- '-'+            | byte == 43 -> (Positive, rest)  -- '+'+            | otherwise  -> (Positive, bytes)++-- | The digits after a decimal point, and the bytes after them; a point+-- without digits after it is not part of the number.+splitFraction :: ByteString -> (ByteString, ByteString)+splitFraction bytes = case B.uncons bytes of+    Nothing -> (B.empty, bytes)+    Just (byte, rest) ->+        let (fraction, remaining) = B.span isDigit rest+        in if byte == 46 && not (B.null fraction)  -- '.'+           then (fraction, remaining)+           else (B.empty, bytes)++-- | Keeps 'maxBound', the mark of an exponent too long to read, as it is.+minusDigits :: Int -> Int -> Int+minusDigits written fractionDigits =+    if written == maxBound then maxBound else written - fractionDigits++isDigit :: Word8 -> Bool+isDigit byte = byte >= 48 && byte <= 57++appendDigit :: Word64 -> Word8 -> Word64+appendDigit accumulated digit = accumulated * 10 + Word8.toWord64 (digit - 48)++appendDigitInt :: Int -> Word8 -> Int+appendDigitInt accumulated digit = accumulated * 10 + Word8.toInt (digit - 48)

@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -funbox-strict-fields #-}+{-# LANGUAGE UnboxedSums   #-}+{-# LANGUAGE UnboxedTuples #-}  {-| Module      : Database.MySQL.Protocol.MySQLValue@@ -16,16 +18,42 @@ module Database.MySQL.Protocol.MySQLValue   ( -- * MySQLValue decoder and encoder     MySQLValue(..)+  , RawDate(..)   , putParamMySQLType   , getTextField   , putTextField   , getTextRow   , getTextRowVector+    -- * Text rows with the column types resolved once per result set+  , ColumnKind(..)+  , ValueKind(..)+  , columnKind+  , decodeTextRow+  , decodeTextRowVector+  , ColumnNumber(..)+  , nextColumn+  , RowError(..)+  , RowErrorKind(..)+  , TextFieldError(..)+  , describeRowError   , getBinaryField   , putBinaryField   , getBinaryRow   , getBinaryRowVector+  , decodeMySQLLatin1   -- * Internal utilities+  , decodeTextValue+  , decodeTextBit+  , lengthEncodedInt+  , lexSignedIntegral+  , lexSignedFraction+  , textDateParts+  , lexDateTimeParts+  , calendarDate+  , dateValue+  , dateTimeValue+  , timeStampValue+  , lexSignedTime   , getBits   , BitMap(..)   , isColumnSet@@ -53,7 +81,7 @@ import           Data.Scientific                    (Scientific) import           Data.Text                          (Text) import qualified Data.Text.Encoding                 as T-import           Data.Time.Calendar                 (Day, fromGregorian,+import           Data.Time.Calendar                 (Day, fromGregorianValid,                                                      toGregorian) import           Data.Time.Format                   (defaultTimeLocale,                                                      formatTime)@@ -62,9 +90,16 @@ import           Data.Word import           Database.MySQL.Protocol.ColumnDef import           Database.MySQL.Protocol.Escape+import           Database.MySQL.Protocol.FloatingPoint (readDouble, readFloat) import           Database.MySQL.Protocol.Packet import           GHC.Generics                       (Generic)+import           Text.Printf                        (printf)+import qualified Data.Text                          as T import qualified Data.Vector                        as V+import qualified Unwitch.Convert.Int                as Int+import qualified Unwitch.Convert.Word16             as Word16+import qualified Unwitch.Convert.Word64             as Word64+import qualified Unwitch.Convert.Word8              as Word8  -------------------------------------------------------------------------------- -- | Data type mapping between MySQL values and haskell values.@@ -84,6 +119,10 @@ -- --  So we use 'LocalTime' to present both @DATETIME@ and @TIMESTAMP@, but the local here is different. --+-- A @DATE@, @DATETIME@ or @TIMESTAMP@ whose date a 'Day' cannot hold, such as the zero+-- date @0000-00-00@, arrives as 'MySQLDateRaw', 'MySQLDateTimeRaw' or 'MySQLTimeStampRaw'+-- and is sent back unchanged, see 'RawDate'.+-- -- MySQL's @TIME@ type can present time of day, but also elapsed time or a time interval between two events. -- @TIME@ values may range from @-838:59:59@ to @838:59:59@, so 'MySQLTime' values consist of a sign and a -- 'TimeOfDay' whose hour part may exceeded 24. you can use @timeOfDayToTime@ to get the absolute time interval.@@ -107,6 +146,9 @@     | MySQLDateTime      !LocalTime    -- ^ DATETIME     | MySQLTimeStamp     !LocalTime    -- ^ TIMESTAMP     | MySQLDate          !Day              -- ^ DATE+    | MySQLDateRaw       !RawDate              -- ^ DATE that a 'Day' cannot hold+    | MySQLDateTimeRaw   !RawDate !TimeOfDay   -- ^ DATETIME whose date a 'Day' cannot hold+    | MySQLTimeStampRaw  !RawDate !TimeOfDay   -- ^ TIMESTAMP whose date a 'Day' cannot hold     | MySQLTime          !Word8 !TimeOfDay -- ^ sign(0 = non-negative, 1 = negative) hh mm ss microsecond                                            -- The sign is OPPOSITE to binlog one !!!     | MySQLGeometry      !ByteString       -- ^ todo: parsing to something meanful@@ -116,6 +158,33 @@     | MySQLNull   deriving (Show, Eq, Generic) +-- | A date as the server stores it, when a 'Day' cannot hold it: the zero date+-- @0000-00-00@, a date with a zero month or day such as @2024-05-00@ (unless+-- @NO_ZERO_DATE@ and @NO_ZERO_IN_DATE@ are set), or under @ALLOW_INVALID_DATES@+-- a day past the end of its month such as @2024-02-30@.+data RawDate = RawDate+    { rawDateYear  :: !Word16+    , rawDateMonth :: !Word8+    , rawDateDay   :: !Word8+    } deriving (Show, Eq, Generic)++-- | 'Right' when a 'Day' can hold the date.+calendarDate :: RawDate -> Either RawDate Day+calendarDate raw@(RawDate year month day) =+    maybe (Left raw) Right+        (fromGregorianValid (Word16.toInteger year) (Word8.toInt month) (Word8.toInt day))++dateValue :: RawDate -> MySQLValue+dateValue = either MySQLDateRaw MySQLDate . calendarDate++dateTimeValue :: RawDate -> TimeOfDay -> MySQLValue+dateTimeValue raw time =+    either (`MySQLDateTimeRaw` time) (\day -> MySQLDateTime (LocalTime day time)) (calendarDate raw)++timeStampValue :: RawDate -> TimeOfDay -> MySQLValue+timeStampValue raw time =+    either (`MySQLTimeStampRaw` time) (\day -> MySQLTimeStamp (LocalTime day time)) (calendarDate raw)+ -- | Put 'FieldType' and usigned bit(0x80/0x00) for 'MySQLValue's. -- putParamMySQLType :: MySQLValue -> Put@@ -134,6 +203,9 @@ putParamMySQLType (MySQLDateTime     _)  = putFieldType mySQLTypeDateTime >> putWord8 0x00 putParamMySQLType (MySQLTimeStamp    _)  = putFieldType mySQLTypeTimestamp>> putWord8 0x00 putParamMySQLType (MySQLDate         _)  = putFieldType mySQLTypeDate     >> putWord8 0x00+putParamMySQLType (MySQLDateRaw      _)  = putFieldType mySQLTypeDate     >> putWord8 0x00+putParamMySQLType (MySQLDateTimeRaw _ _) = putFieldType mySQLTypeDateTime >> putWord8 0x00+putParamMySQLType (MySQLTimeStampRaw _ _) = putFieldType mySQLTypeTimestamp >> putWord8 0x00 putParamMySQLType (MySQLTime       _ _)  = putFieldType mySQLTypeTime     >> putWord8 0x00 putParamMySQLType (MySQLBytes        _)  = putFieldType mySQLTypeBlob     >> putWord8 0x00 putParamMySQLType (MySQLGeometry     _)  = putFieldType mySQLTypeGeometry >> putWord8 0x00@@ -144,76 +216,452 @@ -------------------------------------------------------------------------------- -- | Text protocol decoder getTextField :: ColumnDef -> Get MySQLValue-getTextField f-    | t == mySQLTypeNull            = pure MySQLNull-    | t == mySQLTypeDecimal-        || t == mySQLTypeNewDecimal = feedLenEncBytes t MySQLDecimal fracLexer-    | t == mySQLTypeTiny            = if isUnsigned then feedLenEncBytes t MySQLInt8U intLexer-                                                    else feedLenEncBytes t MySQLInt8 intLexer-    | t == mySQLTypeShort           = if isUnsigned then feedLenEncBytes t MySQLInt16U intLexer-                                                    else feedLenEncBytes t MySQLInt16 intLexer-    | t == mySQLTypeLong-        || t == mySQLTypeInt24      = if isUnsigned then feedLenEncBytes t MySQLInt32U intLexer-                                                    else feedLenEncBytes t MySQLInt32 intLexer-    | t == mySQLTypeLongLong        = if isUnsigned then feedLenEncBytes t MySQLInt64U intLexer-                                                    else feedLenEncBytes t MySQLInt64 intLexer-    | t == mySQLTypeFloat           = feedLenEncBytes t MySQLFloat fracLexer-    | t == mySQLTypeDouble          = feedLenEncBytes t MySQLDouble fracLexer-    | t == mySQLTypeYear            = feedLenEncBytes t MySQLYear intLexer-    | t == mySQLTypeTimestamp-        || t == mySQLTypeTimestamp2 = feedLenEncBytes t MySQLTimeStamp $ \ bs ->-                                          guard (B.length bs >= 12) >>-                                          LocalTime <$> dateParser bs <*> timeParser (B.drop 11 bs)-    | t == mySQLTypeDateTime-        || t == mySQLTypeDateTime2  = feedLenEncBytes t MySQLDateTime $ \ bs ->-                                          guard (B.length bs >= 12) >>-                                          LocalTime <$> dateParser bs <*> timeParser (B.drop 11 bs)-    | t == mySQLTypeDate-        || t == mySQLTypeNewDate    = feedLenEncBytes t MySQLDate dateParser-    | t == mySQLTypeTime-        || t == mySQLTypeTime2      = feedLenEncBytes t id $ \ bs ->-                                          guard (not (B.null bs)) >>-                                          if B.index bs 0 == 45  -- '-'-                                               then MySQLTime 1 <$> timeParser (B.drop 1 bs)-                                               else MySQLTime 0 <$> timeParser bs+getTextField f = case columnKind f of+    NullColumn -> pure MySQLNull+    ValueColumn fieldType value -> do+        bytes <- getLenEncBytes+        case decodeTextValue fieldType value bytes of+            Left fieldError -> fail (describeTextFieldError fieldError)+            Right decoded   -> pure decoded -    | t == mySQLTypeGeometry        = MySQLGeometry <$> getLenEncBytes-    | t == mySQLTypeVarChar-        || t == mySQLTypeEnum-        || t == mySQLTypeSet-        || t == mySQLTypeTinyBlob-        || t == mySQLTypeMediumBlob-        || t == mySQLTypeLongBlob-        || t == mySQLTypeBlob-        || t == mySQLTypeVarString-        || t == mySQLTypeString     = (if isText then MySQLText . T.decodeUtf8 else MySQLBytes) <$> getLenEncBytes+{- Note [Text rows decoded once per result set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'getTextRow' runs 'getTextField' for every field of every row, which compares+the column type against two dozen constants before it reads a byte, inside+binary's continuation-based 'Get' over a lazy packet body. Decoding text rows+was 47.5% of select CPU (benchmark/cpu-profile-1.3.3.md). -    | t == mySQLTypeBit             = MySQLBit <$> (getBits =<< getLenEncInt)+The query functions in "Database.MySQL.Base" instead resolve each column to a+'ColumnKind' once, when the column definitions arrive, and decode every row+with 'decodeTextRow': a walk over the row as one strict 'ByteString' that+returns unboxed sums, so no 'Either' or tuple is allocated per field. -    | otherwise                     = fail $ "Database.MySQL.Protocol.MySQLValue: missing text decoder for " ++ show t+Decision: values stay as lazy as 'getTextField' leaves them. Evaluating every+value while decoding saved 3% of the instructions when a caller uses every+value, and cost 2.75 times the instructions when it uses none+(docs/direct-row-decoding.md). Only a string's bytes are checked at once, as+UTF-8, so bytes that are not fail the row with a 'TextFieldInvalidUtf8' rather+than raise an exception from pure code when the value is used.++'getTextField' and 'getTextRow' keep their 'Get' interface and share+'columnKind' and 'decodeTextValue', so both paths turn the same bytes into the+same values. They differ only on rows a server does not send: an 8-byte length+above 'maxBound' of 'Int', which 'decodeTextRow' rejects, and a zero-length+BIT field, which is now 0 instead of the byte after it.+-}++-- | How a column's fields decode, in either protocol, resolved once per result+-- set by 'columnKind'. See Note [Text rows decoded once per result set].+--+-- @since 1.4.0+data ColumnKind+    = NullColumn+      -- ^ a column of type NULL: every field of it is NULL, so no bytes of a+      -- text-protocol row belong to it beyond the NULL marker+    | ValueColumn !FieldType !ValueKind+      -- ^ a column with values; the column type is kept for error messages+    deriving (Show, Eq)++-- | The 'MySQLValue' constructor a column's non-NULL fields become.+--+-- @since 1.4.0+data ValueKind+    = KindDecimal+    | KindInt8U+    | KindInt8+    | KindInt16U+    | KindInt16+    | KindInt32U+    | KindInt32+    | KindInt64U+    | KindInt64+    | KindFloat+    | KindDouble+    | KindYear+    | KindTimeStamp+    | KindDateTime+    | KindDate+    | KindTime+    | KindGeometry+    | KindText !Word16+      -- ^ a string column in a character set other than binary or latin1, read+      -- as UTF-8; the character set id is kept for error messages+    | KindLatin1Text   -- ^ a string column in latin1, which MySQL means as Windows-1252+    | KindBytes        -- ^ a string column in the binary character set+    | KindBit+    | KindUnsupported  -- ^ a column type without a decoder+    deriving (Show, Eq)++-- | How a column's fields decode.+--+-- @since 1.4.0+columnKind :: ColumnDef -> ColumnKind+columnKind f =+    if  | t == mySQLTypeNull -> NullColumn+        | t == mySQLTypeDecimal || t == mySQLTypeNewDecimal -> ValueColumn t KindDecimal+        | t == mySQLTypeTiny ->+            ValueColumn t (if isUnsigned then KindInt8U else KindInt8)+        | t == mySQLTypeShort ->+            ValueColumn t (if isUnsigned then KindInt16U else KindInt16)+        | t == mySQLTypeLong || t == mySQLTypeInt24 ->+            ValueColumn t (if isUnsigned then KindInt32U else KindInt32)+        | t == mySQLTypeLongLong ->+            ValueColumn t (if isUnsigned then KindInt64U else KindInt64)+        | t == mySQLTypeFloat -> ValueColumn t KindFloat+        | t == mySQLTypeDouble -> ValueColumn t KindDouble+        | t == mySQLTypeYear -> ValueColumn t KindYear+        | t == mySQLTypeTimestamp || t == mySQLTypeTimestamp2 -> ValueColumn t KindTimeStamp+        | t == mySQLTypeDateTime || t == mySQLTypeDateTime2 -> ValueColumn t KindDateTime+        | t == mySQLTypeDate || t == mySQLTypeNewDate -> ValueColumn t KindDate+        | t == mySQLTypeTime || t == mySQLTypeTime2 -> ValueColumn t KindTime+        | t == mySQLTypeGeometry -> ValueColumn t KindGeometry+        | t == mySQLTypeVarChar+            || t == mySQLTypeEnum+            || t == mySQLTypeSet+            || t == mySQLTypeTinyBlob+            || t == mySQLTypeMediumBlob+            || t == mySQLTypeLongBlob+            || t == mySQLTypeBlob+            || t == mySQLTypeVarString+            || t == mySQLTypeString ->+            ValueColumn t (stringKind (columnCharSet f))+        | t == mySQLTypeBit -> ValueColumn t KindBit+        | otherwise -> ValueColumn t KindUnsupported   where     t = columnType f     isUnsigned = flagUnsigned (columnFlags f)-    isText = columnCharSet f /= 63-    intLexer bs = fst <$> LexInt.readSigned LexInt.readDecimal bs-    fracLexer bs = fst <$> LexFrac.readSigned LexFrac.readDecimal bs-    dateParser bs = do-        (yyyy, rest) <- LexInt.readDecimal bs-        guard (not (B.null rest))-        (mm, rest') <- LexInt.readDecimal (B.tail rest)-        guard (not (B.null rest'))-        (dd, _) <- LexInt.readDecimal (B.tail rest')-        return (fromGregorian yyyy mm dd) -    timeParser bs = do-        (hh, rest) <- LexInt.readDecimal bs-        guard (not (B.null rest))-        (mm, rest') <- LexInt.readDecimal (B.tail rest)-        guard (not (B.null rest'))-        (ss, _) <- LexFrac.readDecimal (B.tail rest')-        return (TimeOfDay hh mm ss)+-- | Why the bytes of a text-protocol field did not decode.+--+-- @since 1.4.0+data TextFieldError+    = TextFieldUnparsable !FieldType !ByteString+      -- ^ the bytes are not a value of the column's type+    | TextFieldBitTooWide !Int+      -- ^ a BIT field longer than the 8 bytes of a 'Word64'+    | TextFieldUnsupportedType !FieldType+      -- ^ a column type without a text decoder+    | TextFieldInvalidUtf8 !Word16 !ByteString+      -- ^ a string in this character set id whose bytes are not UTF-8+    deriving (Show, Eq) +-- | The message 'getTextField' fails with.+describeTextFieldError :: TextFieldError -> String+describeTextFieldError fieldError = case fieldError of+    TextFieldUnparsable fieldType bytes ->+        "Database.MySQL.Protocol.MySQLValue: parsing " ++ show fieldType+            ++ " failed, input: " ++ BC.unpack bytes+    TextFieldBitTooWide width ->+        "Database.MySQL.Protocol.MySQLValue: wrong bit length size: " ++ show width+    TextFieldUnsupportedType fieldType ->+        "Database.MySQL.Protocol.MySQLValue: missing text decoder for " ++ show fieldType+    TextFieldInvalidUtf8 charsetId _ ->+        "Database.MySQL.Protocol.MySQLValue: a string column arrived in character set id "+            ++ show charsetId ++ ", which mysql-haskell can only decode as UTF-8 or latin1,"+            ++ " and its bytes are not valid UTF-8. Use a UTF-8 connection charset such as"+            ++ " defaultConnectInfoMB4's, or select the column as BINARY to get its bytes." +-- | The value of a field's bytes. The lexer runs at once, so a malformed field+-- fails while the row is read; a lexed value and the 'Text' of a string are left lazy,+-- while a constructor around bytes already in hand is built at once, as that+-- is cheaper than a thunk. See Note [Text rows decoded once per result set].+-- Inlined so that 'decodeTextFieldAt' matches the 'Right' away instead of+-- allocating it.+decodeTextValue :: FieldType -> ValueKind -> ByteString -> Either TextFieldError MySQLValue+decodeTextValue fieldType value bytes = case value of+    KindDecimal     -> lexedValue fieldType MySQLDecimal lexSignedFraction bytes+    KindInt8U       -> lexedValue fieldType MySQLInt8U lexSignedIntegral bytes+    KindInt8        -> lexedValue fieldType MySQLInt8 lexSignedIntegral bytes+    KindInt16U      -> lexedValue fieldType MySQLInt16U lexSignedIntegral bytes+    KindInt16       -> lexedValue fieldType MySQLInt16 lexSignedIntegral bytes+    KindInt32U      -> lexedValue fieldType MySQLInt32U lexSignedIntegral bytes+    KindInt32       -> lexedValue fieldType MySQLInt32 lexSignedIntegral bytes+    KindInt64U      -> lexedValue fieldType MySQLInt64U lexSignedIntegral bytes+    KindInt64       -> lexedValue fieldType MySQLInt64 lexSignedIntegral bytes+    KindFloat       -> lexedValue fieldType MySQLFloat readFloat bytes+    KindDouble      -> lexedValue fieldType MySQLDouble readDouble bytes+    KindYear        -> lexedValue fieldType MySQLYear lexSignedIntegral bytes+    KindTimeStamp   -> lexedValue fieldType (uncurry timeStampValue) lexDateTimeParts bytes+    KindDateTime    -> lexedValue fieldType (uncurry dateTimeValue) lexDateTimeParts bytes+    KindDate        -> lexedValue fieldType dateValue textDateParts bytes+    KindTime        -> lexedValue fieldType id lexTime bytes+    KindGeometry    -> Right $! MySQLGeometry bytes+    KindText charsetId -> utf8Value charsetId bytes+    KindLatin1Text  -> Right (MySQLText (decodeMySQLLatin1 bytes))+    KindBytes       -> Right $! MySQLBytes bytes+    KindBit         -> decodeTextBit bytes+    KindUnsupported -> Left (TextFieldUnsupportedType fieldType)+{-# INLINE decodeTextValue #-}++-- | Checked by 'B.isValidUtf8' at once, so the lazy 'T.decodeUtf8' cannot fail+-- when the value is used. See Note [Text rows decoded once per result set].+utf8Value :: Word16 -> ByteString -> Either TextFieldError MySQLValue+utf8Value charsetId bytes =+    if B.isValidUtf8 bytes+    then Right (MySQLText (T.decodeUtf8 bytes))+    else Left (TextFieldInvalidUtf8 charsetId bytes)+{-# INLINE utf8Value #-}++lexedValue :: FieldType -> (a -> MySQLValue) -> (ByteString -> Maybe a) -> ByteString+           -> Either TextFieldError MySQLValue+lexedValue fieldType construct lexer bytes = case lexer bytes of+    Just lexed -> Right (construct lexed)+    Nothing    -> Left (TextFieldUnparsable fieldType bytes)+{-# INLINE lexedValue #-}++-- | A BIT field's bytes, most significant first.+decodeTextBit :: ByteString -> Either TextFieldError MySQLValue+decodeTextBit bytes =+    if B.length bytes > 8+    then Left (TextFieldBitTooWide (B.length bytes))+    else Right $! MySQLBit (B.foldl' appendBitByte 0 bytes)++appendBitByte :: Word64 -> Word8 -> Word64+appendBitByte bits byte = unsafeShiftL bits 8 .|. Word8.toWord64 byte++lexSignedIntegral :: Integral a => ByteString -> Maybe a+lexSignedIntegral bytes = fst <$> LexInt.readSigned LexInt.readDecimal bytes+-- Specialised here so that "Database.MySQL.Decoder", which reaches these+-- lexers through higher-order arguments, gets the same specialised digit loops+-- as 'decodeTextValue' instead of the dictionary-passing ones.+{-# SPECIALIZE lexSignedIntegral :: ByteString -> Maybe Int8 #-}+{-# SPECIALIZE lexSignedIntegral :: ByteString -> Maybe Word8 #-}+{-# SPECIALIZE lexSignedIntegral :: ByteString -> Maybe Int16 #-}+{-# SPECIALIZE lexSignedIntegral :: ByteString -> Maybe Word16 #-}+{-# SPECIALIZE lexSignedIntegral :: ByteString -> Maybe Int32 #-}+{-# SPECIALIZE lexSignedIntegral :: ByteString -> Maybe Word32 #-}+{-# SPECIALIZE lexSignedIntegral :: ByteString -> Maybe Int64 #-}+{-# SPECIALIZE lexSignedIntegral :: ByteString -> Maybe Word64 #-}++lexSignedFraction :: Fractional a => ByteString -> Maybe a+lexSignedFraction bytes = fst <$> LexFrac.readSigned LexFrac.readDecimal bytes+{-# SPECIALIZE lexSignedFraction :: ByteString -> Maybe Scientific #-}+++-- | @YYYY-MM-DD hh:mm:ss[.fraction]@, as DATETIME and TIMESTAMP fields come;+-- the date may be one a 'Day' cannot hold.+lexDateTimeParts :: ByteString -> Maybe (RawDate, TimeOfDay)+lexDateTimeParts bytes = do+    guard (B.length bytes >= 12)+    (,) <$> textDateParts bytes <*> lexTimeOfDay (B.drop 11 bytes)++lexTime :: ByteString -> Maybe MySQLValue+lexTime bytes = uncurry MySQLTime <$> lexSignedTime bytes++-- | A TIME field: an optional minus sign before @hh:mm:ss[.fraction]@, where the+-- hours may exceed 24. The sign is 1 for negative, as in 'MySQLTime'.+lexSignedTime :: ByteString -> Maybe (Word8, TimeOfDay)+lexSignedTime bytes = do+    guard (not (B.null bytes))+    if B.index bytes 0 == 45  -- '-'+    then (,) 1 <$> lexTimeOfDay (B.drop 1 bytes)+    else (,) 0 <$> lexTimeOfDay bytes++-- | @hh:mm:ss[.fraction]@.+lexTimeOfDay :: ByteString -> Maybe TimeOfDay+lexTimeOfDay bytes = do+    (hh, rest) <- LexInt.readDecimal bytes+    guard (not (B.null rest))+    (mm, rest') <- LexInt.readDecimal (B.tail rest)+    guard (not (B.null rest'))+    (ss, _) <- LexFrac.readDecimal (B.tail rest')+    return (TimeOfDay hh mm ss)++-- | A column's position in a result set, counting from 0.+--+-- @since 1.4.0+newtype ColumnNumber = ColumnNumber Int+    deriving (Show, Eq, Ord)++-- | @since 1.4.0+nextColumn :: ColumnNumber -> ColumnNumber+nextColumn (ColumnNumber column) = ColumnNumber (column + 1)++-- | Where and why a text-protocol row did not decode.+--+-- @since 1.4.0+data RowError = RowError+    { rowErrorColumn :: !ColumnNumber+    , rowErrorOffset :: !Int               -- ^ byte offset of that column's field in the row+    , rowErrorKind   :: !RowErrorKind+    } deriving (Show, Eq)++-- | @since 1.4.0+data RowErrorKind+    = RowEndsEarly+      -- ^ the row ends before this column's field does+    | RowInvalidLengthPrefix !Word8+      -- ^ a field starting with a byte that is neither a length nor the NULL marker+    | RowLengthOverflow+      -- ^ an 8-byte length above 'maxBound' of 'Int'+    | RowFieldError !TextFieldError+      -- ^ the field's bytes did not decode+    deriving (Show, Eq)++-- | @since 1.4.0+describeRowError :: RowError -> String+describeRowError (RowError (ColumnNumber column) offset kind) =+    "Database.MySQL.Protocol.MySQLValue: column " ++ show column ++ " at byte "+        ++ show offset ++ ": " ++ kindDescription+  where+    kindDescription = case kind of+        RowEndsEarly                  -> "the row ends inside this field"+        RowInvalidLengthPrefix prefix -> "invalid length prefix " ++ show prefix+        RowLengthOverflow             -> "length does not fit an Int"+        RowFieldError fieldError      -> describeTextFieldError fieldError++-- | The values of a text-protocol row, one per 'ColumnKind'. Bytes after the+-- last column are ignored, as 'getTextRow' ignores them.+-- See Note [Text rows decoded once per result set].+--+-- @since 1.4.0+decodeTextRow :: [ColumnKind] -> ByteString -> Either RowError [MySQLValue]+decodeTextRow columns row = case decodeTextFields row (ColumnNumber 0) 0 columns of+    (# rowError | #) -> Left rowError+    (# | values #)   -> Right values++-- | 'V.Vector' version of 'decodeTextRow'.+--+-- @since 1.4.0+decodeTextRowVector :: V.Vector ColumnKind -> ByteString -> Either RowError (V.Vector MySQLValue)+decodeTextRowVector columns row =+    V.fromListN (V.length columns) <$> decodeTextRow (V.toList columns) row++-- | The fields of @columns@, the first of which is @column@ and starts at byte+-- @offset@ of the row.+decodeTextFields :: ByteString -> ColumnNumber -> Int -> [ColumnKind] -> (# RowError | [MySQLValue] #)+decodeTextFields row columnNumber offset columns = case columns of+    [] -> (# | [] #)+    column : laterColumns -> case decodeTextFieldAt row columnNumber offset column of+        (# rowError | #) -> (# rowError | #)+        (# | (# value, nextOffset #) #) ->+            case decodeTextFields row (nextColumn columnNumber) nextOffset laterColumns of+                (# rowError | #) -> (# rowError | #)+                (# | values #)   -> (# | value : values #)++-- | The field at byte @offset@ and the offset after it. The NULL marker is+-- checked before the column, as 'getTextRow' does.+decodeTextFieldAt :: ByteString -> ColumnNumber -> Int -> ColumnKind+                  -> (# RowError | (# MySQLValue, Int #) #)+decodeTextFieldAt row columnNumber offset column =+    if  | offset >= B.length row ->+            (# RowError columnNumber offset RowEndsEarly | #)+        | B.unsafeIndex row offset == 0xFB -> (# | (# MySQLNull, offset + 1 #) #)+        | otherwise -> case column of+            NullColumn -> (# | (# MySQLNull, offset #) #)+            ValueColumn fieldType value -> case lengthEncodedInt row offset of+                (# kind | #) -> (# RowError columnNumber offset kind | #)+                (# | (# fieldLength, fieldStart #) #) ->+                    if fieldLength > B.length row - fieldStart+                    then (# RowError columnNumber offset RowEndsEarly | #)+                    else case decodeTextValue fieldType value+                                (B.unsafeTake fieldLength (B.unsafeDrop fieldStart row)) of+                        Left fieldError ->+                            (# RowError columnNumber offset (RowFieldError fieldError) | #)+                        Right decoded -> (# | (# decoded, fieldStart + fieldLength #) #)++-- | The length-encoded integer at byte @offset@, which must be inside the row,+-- and the offset after it.+lengthEncodedInt :: ByteString -> Int -> (# RowErrorKind | (# Int, Int #) #)+lengthEncodedInt row offset =+    let prefix = B.unsafeIndex row offset+    in if  | prefix < 0xFB  -> (# | (# Word8.toInt prefix, offset + 1 #) #)+           | prefix == 0xFC -> littleEndianLength row (offset + 1) 2+           | prefix == 0xFD -> littleEndianLength row (offset + 1) 3+           | prefix == 0xFE -> littleEndianLength row (offset + 1) 8+           | otherwise      -> (# RowInvalidLengthPrefix prefix | #)++-- | The little-endian length of @width@ bytes at byte @start@, and the offset after it.+littleEndianLength :: ByteString -> Int -> Int -> (# RowErrorKind | (# Int, Int #) #)+littleEndianLength row start width =+    if width > B.length row - start+    then (# RowEndsEarly | #)+    else case Word64.toInt (B.foldr' prependLittleEndianByte 0+                                (B.unsafeTake width (B.unsafeDrop start row))) of+        Nothing          -> (# RowLengthOverflow | #)+        Just fieldLength -> (# | (# fieldLength, start + width #) #)++prependLittleEndianByte :: Word8 -> Word64 -> Word64+prependLittleEndianByte byte higherBytes = unsafeShiftL higherBytes 8 .|. Word8.toWord64 byte++-- | The @YYYY-MM-DD@ that starts a text-protocol date, which may be zero.+textDateParts :: ByteString -> Maybe RawDate+textDateParts bs = do+    (yyyy, rest) <- LexInt.readDecimal bs :: Maybe (Int, ByteString)+    guard (not (B.null rest))+    (mm, rest') <- LexInt.readDecimal (B.tail rest) :: Maybe (Int, ByteString)+    guard (not (B.null rest'))+    (dd, _) <- LexInt.readDecimal (B.tail rest') :: Maybe (Int, ByteString)+    RawDate <$> Int.toWord16 yyyy <*> Int.toWord8 mm <*> Int.toWord8 dd++-- | How the bytes of a string column decode, by the character set id the+-- server sent them in. See Note [Result character sets].+stringKind :: Word16 -> ValueKind+stringKind charsetId =+    if  | charsetId == 63 -> KindBytes+        | charsetId `elem` latin1Collations -> KindLatin1Text+        | otherwise -> KindText charsetId++-- | The ids of @information_schema.collations@ whose character set is latin1,+-- in MySQL 8.0 and MariaDB 11.4 (which adds the two nopad ones).+latin1Collations :: [Word16]+latin1Collations = [5, 8, 15, 31, 47, 48, 49, 94, 1032, 1071]++-- Note [Result character sets]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The server converts string columns to character_set_results, so with a+-- UTF-8 connection charset every text column arrives as UTF-8. A connection+-- set to another charset, as after @SET NAMES latin1@, gets that charset's+-- bytes. latin1 is decoded here; any other charset is read as UTF-8, which+-- keeps ASCII-only values working as they always did, and fails with a+-- 'TextFieldInvalidUtf8' naming the charset on bytes that are not UTF-8,+-- rather than return mangled text.++stringColumnValue :: ColumnDef -> ByteString -> Get MySQLValue+stringColumnValue column bytes =+    case decodeTextValue (columnType column) (stringKind (columnCharSet column)) bytes of+        Right value -> pure value+        Left fieldError ->+            fail (describeTextFieldError fieldError ++ " Column: " ++ show (columnName column))++-- | MySQL's latin1, which is Windows-1252 with its five unassigned bytes+-- (0x81, 0x8D, 0x8F, 0x90, 0x9D) mapped to the C1 controls of the same number.+-- 'T.decodeLatin1' alone is ISO-8859-1, which reads all of 0x80 to 0x9F as+-- C1 controls, so the 27 bytes Windows-1252 assigns are remapped after it.+decodeMySQLLatin1 :: ByteString -> Text+decodeMySQLLatin1 = T.map windows1252Char . T.decodeLatin1++windows1252Char :: Char -> Char+windows1252Char char = case char of+    '\x80' -> '\x20AC'+    '\x82' -> '\x201A'+    '\x83' -> '\x0192'+    '\x84' -> '\x201E'+    '\x85' -> '\x2026'+    '\x86' -> '\x2020'+    '\x87' -> '\x2021'+    '\x88' -> '\x02C6'+    '\x89' -> '\x2030'+    '\x8A' -> '\x0160'+    '\x8B' -> '\x2039'+    '\x8C' -> '\x0152'+    '\x8E' -> '\x017D'+    '\x91' -> '\x2018'+    '\x92' -> '\x2019'+    '\x93' -> '\x201C'+    '\x94' -> '\x201D'+    '\x95' -> '\x2022'+    '\x96' -> '\x2013'+    '\x97' -> '\x2014'+    '\x98' -> '\x02DC'+    '\x99' -> '\x2122'+    '\x9A' -> '\x0161'+    '\x9B' -> '\x203A'+    '\x9C' -> '\x0153'+    '\x9E' -> '\x017E'+    '\x9F' -> '\x0178'+    sameCodePoint -> sameCodePoint+ feedLenEncBytes :: FieldType -> (t -> b) -> (ByteString -> Maybe t) -> Get b feedLenEncBytes typ con parser = do     bs <- getLenEncBytes@@ -244,6 +692,11 @@                                       putByteString (BC.pack (formatTime defaultTimeLocale "%F %T%Q" dt)) putTextField (MySQLDate       d) = putInQuotes $                                       putByteString (BC.pack (formatTime defaultTimeLocale "%F" d))+putTextField (MySQLDateRaw    d) = putInQuotes $ putByteString (BC.pack (rawDateText d))+putTextField (MySQLDateTimeRaw d t) = putInQuotes $+                                      putByteString (BC.pack (rawDateText d ++ formatTime defaultTimeLocale " %T%Q" t))+putTextField (MySQLTimeStampRaw d t) = putInQuotes $+                                      putByteString (BC.pack (rawDateText d ++ formatTime defaultTimeLocale " %T%Q" t)) putTextField (MySQLTime  sign t) = putInQuotes $ do                                       when (sign == 1) (putCharUtf8 '-')                                       putByteString (BC.pack (formatTime defaultTimeLocale "%T%Q" t))@@ -263,6 +716,9 @@  putTextField MySQLNull           = putBuilder "NULL" +rawDateText :: RawDate -> String+rawDateText (RawDate year month day) = printf "%04d-%02d-%02d" year month day+ putInQuotes :: Put -> Put putInQuotes p = putCharUtf8 '\'' >> p >> putCharUtf8 '\'' {-# INLINE putInQuotes #-}@@ -308,43 +764,43 @@         || t == mySQLTypeTimestamp2   = do             n <- getLenEncInt             case n of-               0 -> pure $ MySQLTimeStamp (LocalTime (fromGregorian 0 0 0) (TimeOfDay 0 0 0))+               0 -> pure $ timeStampValue (RawDate 0 0 0) (TimeOfDay 0 0 0)                4 -> do-                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'-                   pure $ MySQLTimeStamp (LocalTime d (TimeOfDay 0 0 0))+                   d <- getBinaryDateParts+                   pure $ timeStampValue d (TimeOfDay 0 0 0)                7 -> do-                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+                   d <- getBinaryDateParts                    td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond4-                   pure $ MySQLTimeStamp (LocalTime d td)+                   pure $ timeStampValue d td                11 -> do-                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+                   d <- getBinaryDateParts                    td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond8-                   pure $ MySQLTimeStamp (LocalTime d td)+                   pure $ timeStampValue d td                _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong TIMESTAMP length"     | t == mySQLTypeDateTime         || t == mySQLTypeDateTime2    = do             n <- getLenEncInt             case n of-               0 -> pure $ MySQLDateTime (LocalTime (fromGregorian 0 0 0) (TimeOfDay 0 0 0))+               0 -> pure $ dateTimeValue (RawDate 0 0 0) (TimeOfDay 0 0 0)                4 -> do-                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'-                   pure $ MySQLDateTime (LocalTime d (TimeOfDay 0 0 0))+                   d <- getBinaryDateParts+                   pure $ dateTimeValue d (TimeOfDay 0 0 0)                7 -> do-                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+                   d <- getBinaryDateParts                    td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond4-                   pure $ MySQLDateTime (LocalTime d td)+                   pure $ dateTimeValue d td                11 -> do-                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+                   d <- getBinaryDateParts                    td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond8-                   pure $ MySQLDateTime (LocalTime d td)+                   pure $ dateTimeValue d td                _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong DATETIME length"      | t == mySQLTypeDate         || t == mySQLTypeNewDate      = do             n <- getLenEncInt             case n of-               0 -> pure $ MySQLDate (fromGregorian 0 0 0)-               4 -> MySQLDate <$> (fromGregorian <$> getYear <*> getInt8' <*> getInt8')+               0 -> pure $ dateValue (RawDate 0 0 0)+               4 -> dateValue <$> getBinaryDateParts                _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong DATE length"      | t == mySQLTypeTime@@ -374,18 +830,14 @@         || t == mySQLTypeLongBlob         || t == mySQLTypeBlob         || t == mySQLTypeVarString-        || t == mySQLTypeString       = if isText then MySQLText . T.decodeUtf8 <$> getLenEncBytes-                                                  else MySQLBytes <$> getLenEncBytes+        || t == mySQLTypeString       = getLenEncBytes >>= stringColumnValue f     | t == mySQLTypeBit               = MySQLBit <$> (getBits =<< getLenEncInt)     | otherwise                       = fail $ "Database.MySQL.Protocol.MySQLValue:\                                                \ missing binary decoder for " ++ show t   where     t = columnType f     isUnsigned = flagUnsigned (columnFlags f)-    isText = columnCharSet f /= 63     fracLexer bs = fst <$> LexFrac.readSigned LexFrac.readDecimal bs-    getYear :: Get Integer-    getYear = fromIntegral <$> getWord16le     getInt8' :: Get Int     getInt8' = fromIntegral <$> getWord8     getSecond4 :: Get Pico@@ -397,6 +849,9 @@         pure $! (realToFrac s + realToFrac ms / 1000000 :: Pico)  +getBinaryDateParts :: Get RawDate+getBinaryDateParts = RawDate <$> getWord16le <*> getWord8 <*> getWord8+ -- | Get a bit sequence as a Word64 -- -- Since 'Word64' has a @Bits@ instance, it's easier to deal with in haskell.@@ -440,6 +895,14 @@                                                            putBinaryTime' time putBinaryField (MySQLDate    d)    = do putWord8 4                                         putBinaryDay d+putBinaryField (MySQLDateRaw d)    = do putWord8 4+                                        putRawDate d+putBinaryField (MySQLDateTimeRaw d time) = do putWord8 11+                                              putRawDate d+                                              putBinaryTime' time+putBinaryField (MySQLTimeStampRaw d time) = do putWord8 11+                                               putRawDate d+                                               putBinaryTime' time putBinaryField (MySQLTime sign t)  = do putWord8 12    -- always put full                                         putWord8 sign                                         putBinaryTime t@@ -455,6 +918,9 @@                     putWord8 (fromIntegral mm)                     putWord8 (fromIntegral dd) {-# INLINE putBinaryDay #-}++putRawDate :: RawDate -> Put+putRawDate (RawDate year month day) = putWord16le year >> putWord8 month >> putWord8 day  putBinaryTime' :: TimeOfDay -> Put putBinaryTime' (TimeOfDay hh mm ss) = do let s = floor ss

@@ -28,6 +28,10 @@ import           Data.Word import           Data.Typeable import           Data.Word.Word24+import qualified Unwitch.Convert.Word16 as Word16+import qualified Unwitch.Convert.Word32 as Word32+import qualified Unwitch.Convert.Word64 as Word64+import qualified Unwitch.Convert.Word8  as Word8  -------------------------------------------------------------------------------- -- | MySQL packet type@@ -60,29 +64,38 @@     {-# INLINE get #-}  isERR :: Packet -> Bool-isERR p = L.index (pBody p) 0 == 0xFF+isERR = packetStartsWith 0xFF {-# INLINE isERR #-}  isOK :: Packet -> Bool-isOK p  = L.index (pBody p) 0 == 0x00+isOK = packetStartsWith 0x00 {-# INLINE isOK #-} +-- | A row can start with 0xFE too: the length prefix of a text field of+-- 16 MiB or more. Such a row is at least 9 bytes long, an EOF packet at most 5. isEOF :: Packet -> Bool-isEOF p = L.index (pBody p) 0 == 0xFE+isEOF p = pLen p < 9 && packetStartsWith 0xFE p {-# INLINE isEOF #-}  -- | Is this an AuthMoreData packet? (first byte 0x01) -- Used during authentication handshake for caching_sha2_password. isAuthMoreData :: Packet -> Bool-isAuthMoreData p = L.index (pBody p) 0 == 0x01+isAuthMoreData = packetStartsWith 0x01 {-# INLINE isAuthMoreData #-}  -- | Is this an AuthSwitchRequest packet? (first byte 0xFE) -- Same marker as EOF but used in authentication context. isAuthSwitch :: Packet -> Bool-isAuthSwitch p = L.index (pBody p) 0 == 0xFE+isAuthSwitch = packetStartsWith 0xFE {-# INLINE isAuthSwitch #-} +-- | False for an empty packet, which has no marker byte to classify it by.+packetStartsWith :: Word8 -> Packet -> Bool+packetStartsWith marker p = case L.uncons (pBody p) of+    Just (firstByte, _) -> firstByte == marker+    Nothing -> False+{-# INLINE packetStartsWith #-}+ -- | Is there more packet to be read? -- --  https://dev.mysql.com/doc/internals/en/status-flags.html@@ -125,12 +138,18 @@ -------------------------------------------------------------------------------- -- OK, ERR, EOF +-- Decision: okLastInsertID is a Word64 because the server sends the unsigned+-- 64-bit value of LAST_INSERT_ID(), which an Int wraps above 2^63.+-- okAffectedRows stays an Int (changing it would break every+-- @sum . map okAffectedRows@ for a count no table reaches); a count above+-- maxBound fails to decode rather than wrap, see getLenEncInt.+ -- | You may get interested in 'OK' packet because it provides information about -- successful operations. -- data OK = OK     { okAffectedRows :: !Int      -- ^ affected row number-    , okLastInsertID :: !Int      -- ^ last insert's ID+    , okLastInsertID :: !Word64   -- ^ last insert's ID     , okStatus       :: !Word16     , okWarningCnt   :: !Word16     } deriving (Show, Eq)@@ -138,7 +157,7 @@ getOK :: Get OK getOK = OK <$ skipN 1            <*> getLenEncInt-           <*> getLenEncInt+           <*> getLenEncWord64            <*> getWord16le            <*> getWord16le {-# INLINE getOK #-}@@ -147,7 +166,7 @@ putOK (OK row lid stat wcnt) = do     putWord8 0x00     putLenEncInt row-    putLenEncInt lid+    putLenEncWord64 lid     putWord16le stat     putWord16le wcnt {-# INLINE putOK #-}@@ -234,6 +253,8 @@  -- | length encoded int -- https://dev.mysql.com/doc/internals/en/integer.html#packet-Protocol::LengthEncodedInteger+--+-- Fails on a value above @maxBound :: Int@; 'getLenEncWord64' reads the full range. getLenEncInt:: Get Int getLenEncInt = getWord8 >>= word2Len   where@@ -241,9 +262,37 @@          | l <  0xFB  = pure (fromIntegral l)          | l == 0xFC  = fromIntegral <$> getWord16le          | l == 0xFD  = fromIntegral <$> getWord24le-         | l == 0xFE  = fromIntegral <$> getWord64le+         | l == 0xFE  = getWord64le >>= lenEncWord64ToInt          | otherwise = fail $ "invalid length val " ++ show l {-# INLINE getLenEncInt #-}++lenEncWord64ToInt :: Word64 -> Get Int+lenEncWord64ToInt value = case Word64.toInt value of+    Just int -> pure int+    Nothing -> fail ("length-encoded integer " ++ show value ++ " does not fit in an Int")++-- | A length-encoded integer over its full unsigned 64-bit range.+getLenEncWord64 :: Get Word64+getLenEncWord64 = do+    marker <- getWord8+    if  | marker < 0xFB -> pure (Word8.toWord64 marker)+        | marker == 0xFC -> Word16.toWord64 <$> getWord16le+        | marker == 0xFD -> Word32.toWord64 <$> getWord24le+        | marker == 0xFE -> getWord64le+        | otherwise -> fail ("invalid length-encoded integer marker " ++ show marker)++putLenEncWord64 :: Word64 -> Put+putLenEncWord64 value = case Word64.toWord8 value of+    Just byte -> if byte < 0xFB+        then putWord8 byte+        else putWord8 0xFC >> putWord16le (Word8.toWord16 byte)+    Nothing -> case Word64.toWord16 value of+        Just short -> putWord8 0xFC >> putWord16le short+        Nothing -> case Word64.toWord32 value of+            Just word -> if word < 0x1000000+                then putWord8 0xFD >> putWord24le word+                else putWord8 0xFE >> putWord64le value+            Nothing -> putWord8 0xFE >> putWord64le value  putLenEncInt:: Int -> Put putLenEncInt x

@@ -0,0 +1,231 @@+{-# LANGUAGE UnboxedSums   #-}+{-# LANGUAGE UnboxedTuples #-}++{-|+Module      : Database.MySQL.Protocol.RawRow+Description : Rows as their bytes plus the bounds of each field+Copyright   : (c) Jappie Klooster, 2026+License     : BSD3+Maintainer  : hi@jappie.me+Stability   : experimental+Portability : PORTABLE++A 'RawRow' is a row's bytes plus where each of its fields starts and how long+it is, found in one pass over the row. A field can then be read by its column+number without walking the row again, which is what a library decoding rows by+column number needs. "Database.MySQL.Decoder" reads 'RawRow's.+-}+module Database.MySQL.Protocol.RawRow+  ( -- * Protocols+    TextProtocol+  , BinaryProtocol+    -- * Raw rows+  , RawRow+  , rawRowBytes+  , rawRowFieldCount+  , RawField(..)+  , ColumnNumber(..)+  , rawField+    -- * Building raw rows+  , textRawRow+  , BinaryWidth(..)+  , binaryWidth+  , binaryRawRow+    -- * Internal utilities+  , binaryNullMapLength+  , isNullInMap+  ) where++import           Control.Monad.ST                   (ST, runST)+import           Data.Bits                          (testBit, unsafeShiftR,+                                                     (.&.))+import           Data.ByteString                    (ByteString)+import qualified Data.ByteString                    as B+import qualified Data.ByteString.Unsafe             as B+import           Data.Kind                          (Type)+import qualified Data.Vector                        as V+import qualified Data.Vector.Unboxed                as VU+import qualified Data.Vector.Unboxed.Mutable        as VUM+import           Database.MySQL.Protocol.ColumnDef+import           Database.MySQL.Protocol.MySQLValue (ColumnNumber (..),+                                                     RowError (..),+                                                     RowErrorKind (..),+                                                     lengthEncodedInt,+                                                     nextColumn)++-- | Rows of a plain query, whose fields are text.+--+-- @since 1.4.0+data TextProtocol++-- | Rows of a prepared statement, whose fields are binary.+--+-- @since 1.4.0+data BinaryProtocol++-- | A row's bytes and the bounds of each of its fields. The @protocol@,+-- 'TextProtocol' or 'BinaryProtocol', says how the fields are encoded, so a+-- decoder for the other protocol cannot be run on it.+--+-- @since 1.4.0+data RawRow (protocol :: Type) = RawRow+    { rawRowBytes  :: !ByteString+      -- ^ the row packet's body+    , rawRowBounds :: !(VU.Vector Int)+      -- ^ field @i@ starts at element @2i@ and its length is element @2i + 1@,+      -- or 'nullFieldLength' for a NULL+    }++-- | @since 1.4.0+rawRowFieldCount :: RawRow protocol -> Int+rawRowFieldCount row = VU.length (rawRowBounds row) `unsafeShiftR` 1++-- | One field of a 'RawRow'.+--+-- @since 1.4.0+data RawField+    = RawNull+    | RawBytes !ByteString+      -- ^ the field's bytes, without a length prefix: the value as text in+      -- 'TextProtocol', its binary encoding in 'BinaryProtocol'+    | RawAbsent+      -- ^ the row has no field with that column number+    deriving (Show, Eq)++-- | The field of a column, counting from 0. Inlined so that a caller matching+-- on the result never allocates the 'RawField'.+--+-- @since 1.4.0+rawField :: RawRow protocol -> ColumnNumber -> RawField+rawField row@(RawRow bytes bounds) (ColumnNumber column) =+    -- Compared with the field count, not @2 * column + 1@ with the bounds'+    -- length: doubling a large column number overflows and passes the check.+    if column < 0 || column >= rawRowFieldCount row+    then RawAbsent+    else+        let start       = VU.unsafeIndex bounds (2 * column)+            fieldLength = VU.unsafeIndex bounds (2 * column + 1)+        in if fieldLength == nullFieldLength+           then RawNull+           else RawBytes (B.unsafeTake fieldLength (B.unsafeDrop start bytes))+{-# INLINE rawField #-}++nullFieldLength :: Int+nullFieldLength = -1++-- | The bounds of the first @columnCount@ fields of a text-protocol row. Bytes+-- after the last field are ignored, as 'decodeTextRow' ignores them.+--+-- @since 1.4.0+textRawRow :: Int -> ByteString -> Either RowError (RawRow TextProtocol)+textRawRow columnCount row = runST $ do+    bounds <- VUM.unsafeNew (2 * columnCount)+    outcome <- fillTextBounds row bounds columnCount (ColumnNumber 0) 0+    case outcome of+        Left rowError -> pure (Left rowError)+        Right ()      -> Right . RawRow row <$> VU.unsafeFreeze bounds++-- | Records the bounds of the fields from @column@ on, the first of which+-- starts at byte @offset@.+fillTextBounds :: ByteString -> VUM.MVector s Int -> Int -> ColumnNumber -> Int -> ST s (Either RowError ())+fillTextBounds row bounds columnCount column@(ColumnNumber number) offset =+    if  | number >= columnCount -> pure (Right ())+        | offset >= B.length row -> pure (Left (RowError column offset RowEndsEarly))+        | B.unsafeIndex row offset == 0xFB -> do+            writeBounds bounds column offset nullFieldLength+            fillTextBounds row bounds columnCount (nextColumn column) (offset + 1)+        | otherwise -> case lengthEncodedInt row offset of+            (# kind | #) -> pure (Left (RowError column offset kind))+            (# | (# fieldLength, fieldStart #) #) ->+                if fieldLength > B.length row - fieldStart+                then pure (Left (RowError column offset RowEndsEarly))+                else do+                    writeBounds bounds column fieldStart fieldLength+                    fillTextBounds row bounds columnCount (nextColumn column) (fieldStart + fieldLength)++writeBounds :: VUM.MVector s Int -> ColumnNumber -> Int -> Int -> ST s ()+writeBounds bounds (ColumnNumber column) start fieldLength = do+    VUM.unsafeWrite bounds (2 * column) start+    VUM.unsafeWrite bounds (2 * column + 1) fieldLength++-- | How the binary protocol lays out the non-NULL fields of a column.+--+-- @since 1.4.0+data BinaryWidth+    = BinaryFixed !Int+      -- ^ always this many bytes: the integers, FLOAT, DOUBLE and YEAR+    | BinaryLengthEncoded+      -- ^ a length, then that many bytes: strings, DECIMAL, BIT, and the dates+      -- and times, whose length says which of their parts are present+    | BinaryNoBytes+      -- ^ a column of type NULL, whose fields the NULL map marks+    deriving (Show, Eq)++-- | @since 1.4.0+binaryWidth :: ColumnDef -> BinaryWidth+binaryWidth column =+    if  | t == mySQLTypeTiny -> BinaryFixed 1+        | t == mySQLTypeShort || t == mySQLTypeYear -> BinaryFixed 2+        | t == mySQLTypeLong || t == mySQLTypeInt24 || t == mySQLTypeFloat -> BinaryFixed 4+        | t == mySQLTypeLongLong || t == mySQLTypeDouble -> BinaryFixed 8+        | t == mySQLTypeNull -> BinaryNoBytes+        | otherwise -> BinaryLengthEncoded+  where+    t = columnType column++-- | The bounds of the fields of a binary-protocol row: a 0x00 header, a NULL+-- map with a bit per column from bit 2 on, then the non-NULL fields, laid out+-- as each column's 'BinaryWidth' says.+--+-- @since 1.4.0+binaryRawRow :: V.Vector BinaryWidth -> ByteString -> Either RowError (RawRow BinaryProtocol)+binaryRawRow widths row =+    let nullMapLength = binaryNullMapLength (V.length widths)+    in if 1 + nullMapLength > B.length row+       then Left (RowError (ColumnNumber 0) 0 RowEndsEarly)+       else runST $ do+           bounds <- VUM.unsafeNew (2 * V.length widths)+           outcome <- fillBinaryBounds row widths bounds (ColumnNumber 0) (1 + nullMapLength)+           case outcome of+               Left rowError -> pure (Left rowError)+               Right ()      -> Right . RawRow row <$> VU.unsafeFreeze bounds++fillBinaryBounds :: ByteString -> V.Vector BinaryWidth -> VUM.MVector s Int -> ColumnNumber -> Int+                 -> ST s (Either RowError ())+fillBinaryBounds row widths bounds column@(ColumnNumber number) offset =+    if  | number >= V.length widths -> pure (Right ())+        | isNullInMap row column -> do+            writeBounds bounds column offset nullFieldLength+            fillBinaryBounds row widths bounds (nextColumn column) offset+        | otherwise -> case V.unsafeIndex widths number of+            BinaryNoBytes -> do+                writeBounds bounds column offset 0+                fillBinaryBounds row widths bounds (nextColumn column) offset+            BinaryFixed width ->+                if width > B.length row - offset+                then pure (Left (RowError column offset RowEndsEarly))+                else do+                    writeBounds bounds column offset width+                    fillBinaryBounds row widths bounds (nextColumn column) (offset + width)+            BinaryLengthEncoded ->+                if offset >= B.length row+                then pure (Left (RowError column offset RowEndsEarly))+                else case lengthEncodedInt row offset of+                    (# kind | #) -> pure (Left (RowError column offset kind))+                    (# | (# fieldLength, fieldStart #) #) ->+                        if fieldLength > B.length row - fieldStart+                        then pure (Left (RowError column offset RowEndsEarly))+                        else do+                            writeBounds bounds column fieldStart fieldLength+                            fillBinaryBounds row widths bounds (nextColumn column) (fieldStart + fieldLength)++-- | The bytes of a binary-protocol row's NULL map, which holds a bit per+-- column from bit 2 on.+binaryNullMapLength :: Int -> Int+binaryNullMapLength columnCount = (columnCount + 7 + 2) `unsafeShiftR` 3++-- | The NULL map starts after the header byte; column @i@ is bit @i + 2@. The+-- row must be long enough to hold the map.+isNullInMap :: ByteString -> ColumnNumber -> Bool+isNullInMap row (ColumnNumber column) =+    testBit (B.unsafeIndex row (1 + ((column + 2) `unsafeShiftR` 3))) ((column + 2) .&. 7)

@@ -3,9 +3,10 @@ import           Data.String               (IsString (..)) import           Control.Exception         (throw, Exception) import           Data.Typeable+import qualified Data.ByteString           as B import qualified Data.ByteString.Lazy      as L-import qualified Data.ByteString.Lazy.Char8     as LC import qualified Data.ByteString.Builder   as BB+import           Data.Word                 (Word8) import           Control.Arrow             (first) import           Database.MySQL.Protocol.MySQLValue import           Data.Binary.Put@@ -67,14 +68,108 @@ instance QueryParam MySQLValue where     render = putTextField +-- | Fill the query's @?@ placeholders with the rendered parameters, in order.+--+-- A @?@ inside a quoted string or identifier (@\'...\'@, @\"...\"@,+-- @\`...\`@) or a comment (@-- @, @#@, @\/* *\/@) is not a placeholder. The+-- quotes are read with MySQL's default escaping, where a backslash escapes+-- the next character; under @NO_BACKSLASH_ESCAPES@ a string ending in a+-- backslash, such as @\'C:\\\'@, looks unterminated, so the placeholders+-- after it are missed. That mode breaks the escaping of the rendered values+-- as well.+--+-- Throws 'WrongParamsCount' when the number of placeholders and parameters+-- differ. renderParams :: QueryParam p => Query -> [p] -> Query renderParams (Query qry) params =-    let fragments = LC.split '?' qry+    let fragments = map L.fromStrict (splitAtPlaceholders (L.toStrict qry))     in Query . runPut $ merge fragments params   where     merge [x]    []     = putLazyByteString x     merge (x:xs) (y:ys) = putLazyByteString x >> render y >> merge xs ys     merge _     _       = throw WrongParamsCount++-- | The query text between its placeholders, see 'renderParams': one more+-- fragment than there are placeholders.+splitAtPlaceholders :: B.ByteString -> [B.ByteString]+splitAtPlaceholders query = scanCode query 0 0++-- | Scan SQL outside quotes and comments; @start@ is where the current+-- fragment began.+scanCode :: B.ByteString -> Int -> Int -> [B.ByteString]+scanCode query start position = case byteAt query position of+    Nothing -> [B.drop start query]+    Just byte -> if+        | byte == questionMark ->+            fragment query start position : scanCode query (position + 1) (position + 1)+        | byte == singleQuote || byte == doubleQuote || byte == backtick ->+            scanQuoted query start byte (position + 1)+        | byte == hash ->+            scanLineComment query start (position + 1)+        | byte == dash && byteAt query (position + 1) == Just dash+            && opensDashComment (byteAt query (position + 2)) ->+            scanLineComment query start (position + 2)+        | byte == slash && byteAt query (position + 1) == Just star+            && not (isExecutableComment query (position + 2)) ->+            scanBlockComment query start (position + 2)+        | otherwise -> scanCode query start (position + 1)++-- | Scan inside a quote opened by @quote@. A doubled quote stands for the+-- quote character itself; a backslash escapes the next byte in strings but+-- not in backtick-quoted identifiers.+scanQuoted :: B.ByteString -> Int -> Word8 -> Int -> [B.ByteString]+scanQuoted query start quote position = case byteAt query position of+    Nothing -> [B.drop start query]+    Just byte -> if+        | byte == backslash && quote /= backtick -> scanQuoted query start quote (position + 2)+        | byte == quote -> if byteAt query (position + 1) == Just quote+            then scanQuoted query start quote (position + 2)+            else scanCode query start (position + 1)+        | otherwise -> scanQuoted query start quote (position + 1)++scanLineComment :: B.ByteString -> Int -> Int -> [B.ByteString]+scanLineComment query start position = case B.elemIndex newline (B.drop position query) of+    Nothing -> [B.drop start query]+    Just offset -> scanCode query start (position + offset + 1)++scanBlockComment :: B.ByteString -> Int -> Int -> [B.ByteString]+scanBlockComment query start position = case B.breakSubstring "*/" (B.drop position query) of+    (comment, rest) -> if B.null rest+        then [B.drop start query]+        else scanCode query start (position + B.length comment + 2)++-- | MySQL only takes @--@ for a comment when a space or control character+-- follows it, so @1--1@ stays arithmetic.+opensDashComment :: Maybe Word8 -> Bool+opensDashComment next = case next of+    Nothing -> True+    Just byte -> byte <= 0x20++-- | @\/*!@ and MariaDB's @\/*M!@ wrap SQL the server runs, so their+-- placeholders count.+isExecutableComment :: B.ByteString -> Int -> Bool+isExecutableComment query position =+    B.isPrefixOf "!" (B.drop position query) || B.isPrefixOf "M!" (B.drop position query)++-- | 'B.indexMaybe' needs bytestring 0.11, the bounds still admit 0.10.+byteAt :: B.ByteString -> Int -> Maybe Word8+byteAt query position =+    if position < B.length query then Just (B.index query position) else Nothing++fragment :: B.ByteString -> Int -> Int -> B.ByteString+fragment query start end = B.take (end - start) (B.drop start query)++questionMark, singleQuote, doubleQuote, backtick, backslash, hash, dash, slash, star, newline :: Word8+questionMark = 0x3F+singleQuote = 0x27+doubleQuote = 0x22+backtick = 0x60+backslash = 0x5C+hash = 0x23+dash = 0x2D+slash = 0x2F+star = 0x2A+newline = 0x0A  data WrongParamsCount = WrongParamsCount deriving (Show, Typeable) instance Exception WrongParamsCount

@@ -14,23 +14,19 @@ module Database.MySQL.TLS (       connect     , connectDetail+    , connectDetailExtended     , module Data.TLSSetting     ) where -import           Control.Exception              (bracketOnError, throwIO, catch, SomeException)-import           Control.Monad                  (void)-import qualified Data.Binary                    as Binary-import qualified Data.Binary.Put                as Binary+import           Control.Exception              (bracketOnError, throwIO) import           Data.ByteString                (ByteString) import qualified Data.ByteString                as B import qualified Data.ByteString.Lazy           as L import           Data.Word                      (Word8) import qualified Data.Connection                as Conn-import           Data.IORef                     (newIORef) import           Data.TLSSetting-import           Database.MySQL.Connection      hiding (connect, connectDetail)+import           Database.MySQL.Connection      hiding (connect, connectDetail, connectDetailExtended) import           Database.MySQL.Protocol.Auth-import           Database.MySQL.Protocol.Command import           Database.MySQL.Protocol.Packet import           System.IO.Streams               (InputStream) import qualified Network.TLS                    as TLS@@ -46,43 +42,47 @@ connect c cp = fmap snd (connectDetail c cp)  connectDetail :: ConnectInfo -> (TLS.ClientParams, String) -> IO (Greeting, MySQLConn)-connectDetail (ConnectInfo host port db user pass charset) (cparams, subName) =-    bracketOnError (connectWithBufferSize host port bUFSIZE)-       (TCP.close) $ \ c -> do-            let is = TCP.source c-            is' <- decodeInputStream is-            p <- readPacket is'-            greet <- decodeFromPacket p-            if supportTLS (greetingCaps greet)-            then do-                let cparams' = cparams {-                            TLS.clientUseServerNameIndication = False-                        ,   TLS.clientServerIdentification = (subName, "")-                        }-                let (sock, sockAddr) = Conn.connExtraInfo c-                write c (encodeToPacket 1 $ sslRequest charset)-                bracketOnError (TLS.contextNew sock cparams')-                               ( \ ctx -> TLS.bye ctx >> TCP.close c ) $ \ ctx -> do-                    TLS.handshake ctx-                    tc <- TLS.tLsToConnection (ctx, sockAddr)-                    let tlsIs = TCP.source tc-                    tlsIs' <- decodeInputStream tlsIs-                    let auth = mkAuth db user pass charset greet-                    write tc (encodeToPacket 2 auth)-                    q <- readPacket tlsIs'-                    completeAuth tlsIs' (write tc) pass q tlsFullAuth-                    consumed <- newIORef True-                    let waitNotMandatoryOK = catch-                            (void (waitCommandReply tlsIs'))-                            ((\ _ -> return ()) :: SomeException -> IO ())-                        conn = MySQLConn tlsIs' (write tc)-                            (writeCommand COM_QUIT (write tc) >> waitNotMandatoryOK >> TCP.close tc)-                            consumed-                    return (greet, conn)-            else error "Database.MySQL.TLS: server doesn't support TLS connection"-  where-    connectWithBufferSize h p bs = TCP.connectSocket h p >>= TCP.socketToConnection bs-    write c a = TCP.send c $ Binary.runPut . Binary.put $ a+connectDetail c cp = fmap withoutNegotiated (connectDetailExtended noExtendedCapabilities c cp)++-- | 'connectDetail' asking a MariaDB server for extended capabilities, also+-- returning those the server agreed to. Asking for none gives exactly+-- 'connectDetail'. See Note [MariaDB extended capabilities].+--+-- @since 1.4.0+connectDetailExtended :: ExtendedCapabilities -> ConnectInfo -> (TLS.ClientParams, String)+                      -> IO (Greeting, ExtendedCapabilities, MySQLConn)+connectDetailExtended requested ci tlsParams =+    bracketOnError+        (TCP.connectSocket (ciHost ci) (ciPort ci) >>= TCP.socketToConnection bUFSIZE)+        TCP.close+        (handshakeTLS requested ci tlsParams)++handshakeTLS :: ExtendedCapabilities -> ConnectInfo -> (TLS.ClientParams, String) -> TCP.TCPConnection+             -> IO (Greeting, ExtendedCapabilities, MySQLConn)+handshakeTLS requested (ConnectInfo _host _port db user pass charset) (cparams, subName) c = do+    is' <- decodeInputStream (TCP.source c)+    p <- readPacket is'+    (greet, offered) <- getFromPacket getGreetingExtended p+    let negotiated = negotiateExtended requested greet offered+    if supportTLS (greetingCaps greet)+    then do+        let cparams' = cparams {+                    TLS.clientUseServerNameIndication = False+                ,   TLS.clientServerIdentification = (subName, "")+                }+        let (sock, sockAddr) = Conn.connExtraInfo c+        sendPacket c (sslRequestPacket negotiated charset)+        bracketOnError (TLS.contextNew sock cparams')+                       ( \ ctx -> TLS.bye ctx >> TCP.close c ) $ \ ctx -> do+            TLS.handshake ctx+            tc <- TLS.tLsToConnection (ctx, sockAddr)+            tlsIs' <- decodeInputStream (TCP.source tc)+            sendPacket tc (handshakeResponsePacket 2 negotiated db user pass charset greet)+            q <- readPacket tlsIs'+            completeAuth tlsIs' (sendPacket tc) pass q tlsFullAuth+            conn <- authenticatedConnection tlsIs' tc+            return (greet, negotiated, conn)+    else error "Database.MySQL.TLS: server doesn't support TLS connection"  -- | Full auth handler for TLS connections: sends the cleartext password -- as a NUL-terminated packet, which MySQL accepts over encrypted connections.

@@ -0,0 +1,51 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | Replies left unread on the connection. The server answers in order, so+-- whatever part of a reply stays unread used to be taken for the reply to the+-- next command (issue #10).+module AbandonedReplies (tests) where++import           Control.Exception   (SomeException, fromException, throwIO, try)+import           Control.Monad       (void)+import           Database.MySQL.Base+import           QueryApi+import qualified System.IO.Streams   as Stream+import           System.Timeout      (timeout)+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUser            (withTestConnection)++tests :: QueryApi -> TestTree+tests api = testGroup "replies left unread"+    [ testCase "a query interrupted by a timeout makes the connection refuse commands" $+        withTestConnection $ \c -> do+            interrupted <- timeout 20000+                (apiQuery_ api (ColumnCount 1) c "SELECT SLEEP(0.2)" >>= Stream.toList . snd)+            assertEqual "the timeout fired" Nothing interrupted+            next <- try (apiQuery_ api (ColumnCount 1) c "SELECT 'next'" >>= Stream.toList . snd)+            case next of+                Left AbandonedReply -> pure ()+                Right rows -> assertFailure ("the next query returned " ++ show rows)+    , testCase "resetStmt with rows unread refuses instead of reading a row as its reply" $+        withTestConnection $ \c -> do+            stmt <- prepareStmt c "SELECT 'row' UNION ALL SELECT 'row'"+            (_, rows) <- apiQueryStmt api (ColumnCount 1) c stmt []+            reset <- try (resetStmt c stmt)+            case reset of+                Left UnconsumedResultSet -> pure ()+                Right () -> assertFailure "resetStmt read a row packet as its reply"+            Stream.skipToEof rows+            (_, after) <- query_ c "SELECT 'next'"+            Stream.toList after >>= assertEqual "the next query's rows" [[MySQLText "next"]]+    , testCase "withTransaction rethrows the procedure's exception" $+        withTestConnection $ \c -> do+            outcome <- try (withTransaction c+                (apiQuery_ api (ColumnCount 1) c "SELECT 'unread'" >> throwIO (userError "procedure failed")))+            case outcome of+                Left (failure :: SomeException) -> assertEqual "exception"+                    (Just "user error (procedure failed)") (fmap show (fromException failure :: Maybe IOError))+                Right () -> assertFailure "no exception"+            next <- try (void (execute_ c "SELECT 1"))+            case next of+                Left AbandonedReply -> pure ()+                Right () -> assertFailure "the connection took a command inside the failed transaction"+    ]

@@ -0,0 +1,59 @@+-- | Binlog events of a type this library has no constructor for, such as+-- MySQL 8's compressed TRANSACTION_PAYLOAD_EVENT (40) or MariaDB's GTID+-- event (162), whose type code used to crash the decoder through toEnum.+module BinLogEventCodes (tests) where++import           Control.Exception              (try)+import qualified Data.ByteString.Lazy           as L+import           Data.Binary.Put                (runPut, putWord8, putWord16le, putWord32le, putLazyByteString)+import           Data.IORef                     (newIORef)+import           Data.Word                      (Word16, Word8)+import           Database.MySQL.BinLog+import           Database.MySQL.Protocol.Packet+import qualified System.IO.Streams              as Stream+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "binlog event codes"+    [ testCase "an event of an unknown type keeps its type code" $ do+        event <- getFromPacket (getBinLogPacket False False) (eventPacket 162 notIgnorable)+        assertEqual "type code" 162 (binLogEventTypeCode (blEventType event))+    , testCase "the row decoder refuses an unknown event not marked ignorable" $ do+        rows <- decodeEvents [eventPacket 40 notIgnorable]+        decoded <- try (Stream.read rows)+        case decoded of+            Left (UnsupportedEventType code _) -> assertEqual "type code" 40 code+            Left other -> assertFailure ("raised " <> show other)+            Right event -> assertFailure ("decoded " <> show event)+    , testCase "the row decoder skips an unknown event marked ignorable" $ do+        rows <- decodeEvents [eventPacket 40 ignorable]+        decoded <- Stream.read rows+        assertEqual "row events" Nothing decoded+    ]++decodeEvents :: [Packet] -> IO (Stream.InputStream RowBinLogEvent)+decodeEvents packets = do+    events <- traverse (getFromPacket (getBinLogPacket False False)) packets+    fileName <- newIORef "mysql-bin.000001"+    eventStream <- Stream.fromList events+    decodeRowBinLogEvent (FormatDescription 4 "" 0 "", fileName, eventStream)++-- | A binlog event packet as COM_BINLOG_DUMP streams it, without checksum.+eventPacket :: Word8 -> Word16 -> Packet+eventPacket typeCode flags = Packet (L.length body) 1 body+  where+    eventBody = "\x01\x02\x03"+    body = runPut $ do+        putWord8 0x00                      -- OK marker+        putWord32le 1700000000             -- timestamp+        putWord8 typeCode+        putWord32le 1                      -- server id+        putWord32le (19 + 3)               -- event size: header and body+        putWord32le 4096                   -- next position+        putWord16le flags+        putLazyByteString eventBody++notIgnorable, ignorable :: Word16+notIgnorable = 0x0000+ignorable = 0x0080

@@ -0,0 +1,119 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | Row events the binlog decoder used to drop: those after the first one of+-- a statement, which splits its rows over events of about 8 KiB, and those+-- of a statement that maps several tables before its first rows event.+module BinLogRowEvents (tests, compressedTransactionTests) where++import           Control.Concurrent  (forkIO)+import           Control.Exception   (SomeException, fromException, try)+import           Control.Monad       (forM_, void)+import qualified Data.ByteString.Lazy.Char8 as LC+import           Data.IORef          (IORef, modifyIORef', newIORef, readIORef)+import           Data.List           (intercalate)+import           Database.MySQL.Base+import           Database.MySQL.BinLog+import qualified System.IO.Streams   as Stream+import           System.Timeout      (timeout)+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUser            (testConnectInfo)++tests :: TestTree+tests = testGroup "binlog row events"+    [ testCase "every rows event of a statement that spans several" $ do+            c <- dumpConnection+            void (execute_ c "DROP TABLE IF EXISTS binlog_split_rows")+            void (execute_ c "CREATE TABLE binlog_split_rows (id INT, filler VARCHAR(1000))")+            rowEvents <- rowEventsFrom c 1010 $ \producer ->+                execute_ producer (Query (LC.pack ("INSERT INTO binlog_split_rows VALUES "+                    ++ intercalate ", " (map splitRow [1 .. splitRowCount]))))+            written <- countUntil splitRowCount rowEvents writtenRows+            assertEqual "rows decoded" (Just splitRowCount) written+    , testCase "every table of a statement that maps two before its rows" $ do+            c <- dumpConnection+            forM_ ["binlog_left", "binlog_right" :: LC.ByteString] $ \table -> do+                void (execute_ c (Query ("DROP TABLE IF EXISTS " <> table)))+                void (execute_ c (Query ("CREATE TABLE " <> table <> " (id INT, v INT)")))+                void (execute_ c (Query ("INSERT INTO " <> table <> " VALUES (1, 0)")))+            rowEvents <- rowEventsFrom c 1011 $ \producer ->+                execute_ producer "UPDATE binlog_left, binlog_right \+                                  \SET binlog_left.v = 1, binlog_right.v = 1 \+                                  \WHERE binlog_left.id = binlog_right.id"+            updated <- countUntil 2 rowEvents updatedRows+            assertEqual "update rows decoded across both tables" (Just 2) updated+    ]++-- | MySQL 8 only: a compressed transaction is one TRANSACTION_PAYLOAD_EVENT+-- holding its rows, which the decoder cannot read.+compressedTransactionTests :: TestTree+compressedTransactionTests = testCase "a compressed transaction stops the row decoder" $ do+        c <- dumpConnection+        void (execute_ c "DROP TABLE IF EXISTS binlog_compressed")+        void (execute_ c "CREATE TABLE binlog_compressed (id INT)")+        rowEvents <- rowEventsFrom c 1012 $ \producer -> do+            void (execute_ producer "SET SESSION binlog_transaction_compression = ON")+            execute_ producer "INSERT INTO binlog_compressed VALUES (1)"+        decoded <- timeout tenSeconds (try (Stream.read rowEvents))+        case decoded of+            Just (Left (failure :: SomeException)) -> case fromException failure of+                Just (UnsupportedEventType code _) -> assertEqual "event type" 40 code+                _ -> assertFailure ("raised " ++ show failure)+            Just (Right event) -> assertFailure ("decoded " ++ show event)+            Nothing -> assertFailure "no event within 10 s"++-- | A connection for 'dumpBinLog', left open: once dumping, the server stops+-- reading commands from it, so 'close' would wait for its next event (issue #35).+dumpConnection :: IO MySQLConn+dumpConnection = connect testConnectInfo++-- | The row events from the current end of the binlog on, while @produce@+-- runs on a second connection.+rowEventsFrom :: MySQLConn -> SlaveID -> (MySQLConn -> IO OK) -> IO (Stream.InputStream RowBinLogEvent)+rowEventsFrom c slaveId produce = do+    Just tracker <- getLastBinLogTracker c+    dump <- dumpBinLog c slaveId tracker False+    rowEvents <- decodeRowBinLogEvent dump+    void (forkIO (connect testConnectInfo >>= \producer -> produce producer >> close producer))+    pure rowEvents++-- | Reads events until the counted rows reach @target@; Nothing when they+-- do not within 10 s, as when events are dropped.+countUntil :: Int -> Stream.InputStream RowBinLogEvent -> (RowBinLogEvent -> Int) -> IO (Maybe Int)+countUntil target rowEvents rowsOf = do+    counted <- newIORef 0+    reached <- timeout tenSeconds (readUntil target rowEvents rowsOf counted)+    case reached of+        Just () -> Just <$> readIORef counted+        Nothing -> pure Nothing++readUntil :: Int -> Stream.InputStream RowBinLogEvent -> (RowBinLogEvent -> Int) -> IORef Int -> IO ()+readUntil target rowEvents rowsOf counted = do+    event <- Stream.read rowEvents+    forM_ event (\e -> modifyIORef' counted (+ rowsOf e))+    total <- readIORef counted+    if total >= target then pure () else readUntil target rowEvents rowsOf counted++writtenRows :: RowBinLogEvent -> Int+writtenRows event = case event of+    RowWriteEvent _ _ table rows -> if tmTableName table == "binlog_split_rows" then length (writeRowData rows) else 0+    RowUpdateEvent {} -> 0+    RowDeleteEvent {} -> 0+    RowQueryEvent {} -> 0++updatedRows :: RowBinLogEvent -> Int+updatedRows event = case event of+    RowUpdateEvent _ _ _ rows -> length (updateRowData rows)+    RowWriteEvent {} -> 0+    RowDeleteEvent {} -> 0+    RowQueryEvent {} -> 0++-- | Enough 1000-byte rows for several rows events of binlog_row_event_max_size+-- (8 KiB by default).+splitRowCount :: Int+splitRowCount = 200++splitRow :: Int -> String+splitRow n = "(" ++ show n ++ ", REPEAT('x', 1000))"++tenSeconds :: Int+tenSeconds = 10000000

@@ -9,17 +9,22 @@ import           Data.Time.Calendar  (fromGregorian) import           Data.Time.LocalTime (LocalTime (..), TimeOfDay (..)) import           Database.MySQL.Base+import           QueryApi import qualified System.IO.Streams   as Stream import           Test.Tasty.HUnit import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.Vector as V -tests :: MySQLConn -> Assertion-tests c = do+-- | The columns of the @test@ table.+testColumns :: ColumnCount+testColumns = ColumnCount 30++tests :: QueryApi -> MySQLConn -> Assertion+tests api c = do     selStmt <- prepareStmt c "SELECT * FROM test" -    (f, is) <- queryStmt c selStmt []+    (f, is) <- apiQueryStmt api testColumns c selStmt []     assertEqual "decode Field types" (columnType <$> f)         [ mySQLTypeLong         , mySQLTypeBit@@ -122,7 +127,7 @@                 \__enum       = 'foo'                                  ,\                 \__set        = 'foo,bar' WHERE __id=0" -    (_, is) <- queryStmt c selStmt []+    (_, is) <- apiQueryStmt api testColumns c selStmt []     Just v <- Stream.read is      assertEqual "decode binary protocol" v@@ -158,7 +163,7 @@         , MySQLText "foo,bar"]     Stream.skipToEof is -    (_, is') <- queryStmtVector c selStmt []+    (_, is') <- apiQueryStmtVector api testColumns c selStmt []     Just v' <- Stream.read is'     Stream.skipToEof is' @@ -231,7 +236,7 @@   -    (_, is) <- queryStmt c selStmt []+    (_, is) <- apiQueryStmt api testColumns c selStmt []     Just v <- Stream.read is      assertEqual "roundtrip binary protocol" v@@ -274,7 +279,7 @@         \__double     = null         ,\         \__text = null WHERE __id=0" -    (_, is) <- queryStmt c selStmt []+    (_, is) <- apiQueryStmt api testColumns c selStmt []     Just v <- Stream.read is      assertEqual "decode binary protocol with null" v@@ -318,7 +323,7 @@         \__timestamp = ? WHERE __id=0"     executeStmt c updStmt1 [MySQLNull, MySQLNull, MySQLNull] -    (_, is) <- queryStmt c selStmt []+    (_, is) <- apiQueryStmt api testColumns c selStmt []     Just v <- Stream.read is      assertEqual "roundtrip binary protocol with null" v@@ -360,7 +365,7 @@         \__year       = 0  WHERE __id=0"      selStmt2 <- prepareStmt c "SELECT __time, __year FROM test"-    (_, is) <- queryStmt c selStmt2 []+    (_, is) <- apiQueryStmt api (ColumnCount 2) c selStmt2 []     Just v <- Stream.read is      assertEqual "decode binary protocol 2" v@@ -376,7 +381,7 @@      executeStmt c updStmt2 [ MySQLTime 0 (TimeOfDay 00 00 00), MySQLYear 2055] -    (_, is) <- queryStmt c selStmt2 []+    (_, is) <- apiQueryStmt api (ColumnCount 2) c selStmt2 []     Just v <- Stream.read is     assertEqual "roundtrip binary protocol 2" v             [ MySQLTime 0 (TimeOfDay 00 00 00)@@ -390,7 +395,7 @@         \__blob       = ''  WHERE __id=0"      selStmt3 <- prepareStmt c "SELECT __text, __blob FROM test"-    (_, is) <- queryStmt c selStmt3 []+    (_, is) <- apiQueryStmt api (ColumnCount 2) c selStmt3 []     Just v <- Stream.read is      assertEqual "decode binary protocol 3" v@@ -409,7 +414,7 @@         , MySQLBytes (B.replicate 1000000 64)         ] -    (_, is) <- queryStmt c selStmt3 []+    (_, is) <- apiQueryStmt api (ColumnCount 2) c selStmt3 []     Just v <- Stream.read is     assertEqual "roundtrip binary protocol 3" v         [ MySQLText (T.replicate 100000 "xyz")

@@ -7,14 +7,19 @@ import           Data.Time.Calendar  (fromGregorian) import           Data.Time.LocalTime (LocalTime (..), TimeOfDay (..)) import           Database.MySQL.Base+import           QueryApi import qualified System.IO.Streams   as Stream import           Test.Tasty.HUnit -tests :: MySQLConn -> Assertion-tests c = do+-- | The columns of the @test_new@ table.+testNewColumns :: ColumnCount+testNewColumns = ColumnCount 4++tests :: QueryApi -> MySQLConn -> Assertion+tests api c = do     selStmt <- prepareStmt c "SELECT * FROM test_new" -    (f, is) <- queryStmt c selStmt []+    (f, is) <- apiQueryStmt api testNewColumns c selStmt []     assertEqual "decode Field types" (columnType <$> f)         [ mySQLTypeLong         , mySQLTypeDateTime@@ -37,7 +42,7 @@                 \__timestamp  = '2016-08-08 17:25:59.1234'                ,\                 \__time       = '-199:59:59.123456' WHERE __id=0" -    (_, is) <- queryStmt c selStmt []+    (_, is) <- apiQueryStmt api testNewColumns c selStmt []     Just v <- Stream.read is      assertEqual "decode binary protocol" v@@ -54,7 +59,7 @@                 \__timestamp  = '2016-08-08 17:25:59.12'                ,\                 \__time       = '199:59:59.123' WHERE __id=0" -    (_, is) <- queryStmt c selStmt []+    (_, is) <- apiQueryStmt api testNewColumns c selStmt []     Just v <- Stream.read is      assertEqual "decode binary protocol 2" v@@ -79,7 +84,7 @@                 ]  -    (_, is) <- queryStmt c selStmt []+    (_, is) <- apiQueryStmt api testNewColumns c selStmt []     Just v <- Stream.read is      assertEqual "roundtrip binary protocol" v@@ -98,7 +103,7 @@                 ]  -    (_, is) <- queryStmt c selStmt []+    (_, is) <- apiQueryStmt api testNewColumns c selStmt []     Just v <- Stream.read is      assertEqual "roundtrip binary protocol 2" v

@@ -8,7 +8,13 @@ import           Test.Tasty.HUnit  import           Database.MySQL.Protocol.ColumnDef-import           Database.MySQL.Protocol.MySQLValue (getTextField, MySQLValue)+import           Data.Bifunctor              (first)+import qualified Data.Vector                 as V+import qualified Database.MySQL.Decoder      as Decode+import           Database.MySQL.Protocol.MySQLValue (ColumnKind, ColumnNumber (..),+                                                     MySQLValue, columnKind,+                                                     getTextField)+import           TypedValue                  (typedDecoder) import           Database.MySQL.Protocol.Packet (putLenEncInt) import           Database.MySQL.BinLogProtocol.BinLogEvent                     (FormatDescription(..), eventHeaderLen, BinLogEventType(..))@@ -17,7 +23,7 @@  tests :: TestTree tests = testGroup "bounds-check"-    [ testGroup "text-protocol" textProtocolTests+    [ testGroup "text-protocol" (map textProtocolTests textFieldApis)     , testGroup "binlog-value" binlogValueTests     , testGroup "binlog-event" binlogEventTests     ]@@ -40,15 +46,44 @@     , columnDecimals  = 0     } --- | Encode a length-prefixed ByteString as the MySQL wire protocol does,--- then run the given Get parser on it.+-- | Encode a length-prefixed ByteString as the MySQL wire protocol does.+lenEncoded :: B.ByteString -> B.ByteString+lenEncoded payload = L.toStrict . runPut $ do+    putLenEncInt (B.length payload)+    mapM_ putWord8 (B.unpack payload)++-- | Encode a length-prefixed field, then run 'getTextField' on it. parseLenEncField :: ColumnDef -> B.ByteString -> Either String MySQLValue-parseLenEncField cd payload =-    let encoded = L.toStrict . runPut $ do-            putLenEncInt (B.length payload)-            mapM_ putWord8 (B.unpack payload)-    in parseOnly (getTextField cd) encoded+parseLenEncField cd payload = parseOnly (getTextField cd) (lenEncoded payload) +-- | A text-protocol field decoded through the old 'getTextField' or one of the+-- paths of "Database.MySQL.Decoder"; every text-protocol case runs through each.+data TextFieldApi = TextFieldApi String (ColumnDef -> B.ByteString -> Either String MySQLValue)++textFieldApis :: [TextFieldApi]+textFieldApis =+    [ TextFieldApi "getTextField" parseLenEncField+    , TextFieldApi "RowDecoder" rowDecoderField+    , TextFieldApi "RawRow" (rawRowField (const Decode.mysqlValue))+    , TextFieldApi "typed decoders" (rawRowField typedDecoder)+    ]++-- | A one-column row decoded by a 'Decode.RowDecoder' with 'Decode.mysqlValue'.+rowDecoderField :: ColumnDef -> B.ByteString -> Either String MySQLValue+rowDecoderField cd payload = do+    prepared <- first show (Decode.prepareRowDecoder @Decode.TextProtocol+                                (Decode.field Decode.mysqlValue) (V.singleton cd))+    first show (Decode.runPreparedRow prepared (lenEncoded payload))++-- | A one-column 'Decode.RawRow' read by column number with the decoder for+-- the column's kind.+rawRowField :: (ColumnKind -> Decode.FieldDecoder MySQLValue) -> ColumnDef -> B.ByteString+            -> Either String MySQLValue+rawRowField decoderFor cd payload = do+    raw <- first show (Decode.textRawRow 1 (lenEncoded payload))+    parser <- first show (Decode.prepareFieldParser (decoderFor (columnKind cd)) (ColumnNumber 0) cd)+    Decode.runFieldParser parser raw (ColumnNumber 0) (Left . show) Right+ -- | Check that parsing yields a Left (failure), not a crash or garbage. assertParseFailure :: String -> Either String a -> Assertion assertParseFailure label result = case result of@@ -58,15 +93,15 @@ -------------------------------------------------------------------------------- -- Text protocol tests -textProtocolTests :: [TestTree]-textProtocolTests =+textProtocolTests :: TextFieldApi -> TestTree+textProtocolTests (TextFieldApi name parseField) = testGroup name     [ testCase "timestamp: date-only no time part" $ do         -- "2024-01-01" is 10 bytes. dateParser succeeds, then         -- unsafeDrop 11 on a 10-byte string is UB.         -- With "abc" this wouldn't trigger because readDecimal "abc" → Nothing         -- short-circuits via Maybe's Applicative before unsafeDrop is forced.         let cd = mkColumnDef mySQLTypeTimestamp-            result = parseLenEncField cd "2024-01-01"+            result = parseField cd "2024-01-01"         assertParseFailure "timestamp no time" result      , testCase "timestamp: truncated time" $ do@@ -74,34 +109,34 @@         -- gives "1", timeParser reads hour=1, rest="", then unsafeTail         -- on empty remainder is UB.         let cd = mkColumnDef mySQLTypeTimestamp-            result = parseLenEncField cd "2024-01-01 1"+            result = parseField cd "2024-01-01 1"         assertParseFailure "timestamp truncated time" result      , testCase "datetime: date-only no time part" $ do         -- Same as timestamp: dateParser succeeds on "2024-01-01",         -- then unsafeDrop 11 on 10-byte string is UB.         let cd = mkColumnDef mySQLTypeDateTime-            result = parseLenEncField cd "2024-01-01"+            result = parseField cd "2024-01-01"         assertParseFailure "datetime no time" result      , testCase "time: empty input" $ do         -- TIME parser does unsafeIndex 0 on the payload; empty = UB         let cd = mkColumnDef mySQLTypeTime-            result = parseLenEncField cd ""+            result = parseField cd ""         assertParseFailure "time empty" result      , testCase "date: missing separator" $ do         -- "2024" has no '-' separator; readDecimal consumes everything,         -- then unsafeTail is called on an empty remainder         let cd = mkColumnDef mySQLTypeDate-            result = parseLenEncField cd "2024"+            result = parseField cd "2024"         assertParseFailure "date missing sep" result      , testCase "time: missing separator" $ do         -- "12" has no ':' separator; readDecimal consumes it,         -- then unsafeTail is called on empty remainder         let cd = mkColumnDef mySQLTypeTime-            result = parseLenEncField cd "12"+            result = parseField cd "12"         assertParseFailure "time missing sep" result     ] 

@@ -0,0 +1,14 @@+-- | The Mozilla CA bundle behind 'MozillaCAStore', which an installed library+-- lacked: it was packaged as an extra source file, not a data file.+module CABundle (tests) where++import           Data.TLSSetting   (mozillaCAStorePath)+import           System.Directory  (doesFileExist)+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests = testCase "the Mozilla CA bundle is installed" $ do+    path <- mozillaCAStorePath+    exists <- doesFileExist path+    assertBool ("no CA bundle at " ++ path) exists

@@ -3,6 +3,7 @@ module CachingSha2 (tests) where  import Database.MySQL.Base+import QueryApi import qualified System.IO.Streams as Stream import Test.Tasty import Test.Tasty.HUnit@@ -23,8 +24,8 @@ --   sends a SHA256 scramble. The server then responds with AuthSwitchRequest --   (0xFE) telling the client to re-authenticate using @mysql_native_password@ --   with a new salt. The client re-scrambles with SHA1 and sends the response.-tests :: TestTree-tests = testGroup "caching_sha2_password"+tests :: QueryApi -> TestTree+tests api = testGroup "caching_sha2_password"     [ testCaseSteps "SHA256 fast auth" $ \step -> do         step "connecting as testMySQLHaskellSha2 (caching_sha2_password)..."         (_, c) <- connectDetail defaultConnectInfo@@ -34,7 +35,7 @@             }          step "executing SELECT 1..."-        (_, is) <- query_ c "SELECT 1"+        (_, is) <- apiQuery_ api (ColumnCount 1) c "SELECT 1"         Just row <- Stream.read is         assertBool "SELECT 1 returns 1" (row == [MySQLInt32 1] || row == [MySQLInt64 1])         Stream.skipToEof is@@ -50,7 +51,7 @@             }          step "executing SELECT 1..."-        (_, is) <- query_ c "SELECT 1"+        (_, is) <- apiQuery_ api (ColumnCount 1) c "SELECT 1"         Just row <- Stream.read is         assertBool "SELECT 1 returns 1" (row == [MySQLInt32 1] || row == [MySQLInt64 1])         Stream.skipToEof is

@@ -0,0 +1,179 @@+{-# LANGUAGE TypeApplications #-}++-- | 'FieldRoundtrip' for the typed decoders of "Database.MySQL.Decoder": the+-- same types, the same decode rules. The roundtrip goes through the bytes a+-- prepared statement's row carries: a value 'toField' gives, encoded by the+-- old 'putBinaryField', must decode back to itself.+module DecoderRoundtrip (tests) where++import           Data.Binary.Put                    (runPut)+import           Data.ByteString                    (ByteString)+import qualified Data.ByteString                    as B+import qualified Data.ByteString.Lazy               as LazyByteString+import           Data.Fixed                         (Fixed (MkFixed), Pico)+import           Data.Scientific                    (Scientific, scientific)+import qualified Data.Text                          as Text+import qualified Data.Text.Lazy                     as LazyText+import           Data.Time.Calendar                 (Day, fromGregorian)+import           Data.Time.LocalTime                (LocalTime (..),+                                                     TimeOfDay (..))+import qualified Data.Vector                        as V+import           Data.Word                          (Word16)+import qualified Database.MySQL.Decoder             as Decode+import           Database.MySQL.Field+import           Database.MySQL.Protocol.ColumnDef+import           Database.MySQL.Protocol.MySQLValue (ColumnNumber (..),+                                                     MySQLValue (..),+                                                     putBinaryField)+import           Test.QuickCheck                    (Gen, Property, arbitrary,+                                                     choose, forAll, (===))+import           Test.QuickCheck.Instances          ()+import           Test.Tasty+import           Test.Tasty.HUnit                   (testCase, (@?=))+import           Test.Tasty.QuickCheck              (testProperty)++tests :: TestTree+tests = testGroup "Decoder"+    [ testGroup "roundtrip through a prepared statement's row"+        [ testProperty "Int8" (roundtrips Decode.int8 (column mySQLTypeTiny signed binary))+        , testProperty "Word8" (roundtrips Decode.word8 (column mySQLTypeTiny unsigned binary))+        , testProperty "Int16" (roundtrips Decode.int16 (column mySQLTypeShort signed binary))+        , testProperty "Word16" (roundtrips Decode.word16 (column mySQLTypeShort unsigned binary))+        , testProperty "Int32" (roundtrips Decode.int32 (column mySQLTypeLong signed binary))+        , testProperty "Word32" (roundtrips Decode.word32 (column mySQLTypeLong unsigned binary))+        , testProperty "Int64" (roundtrips Decode.int64 (column mySQLTypeLongLong signed binary))+        , testProperty "Word64" (roundtrips Decode.word64 (column mySQLTypeLongLong unsigned binary))+        , testProperty "Float" (roundtrips Decode.float (column mySQLTypeFloat signed binary))+        , testProperty "Double" (roundtrips Decode.double (column mySQLTypeDouble signed binary))+        , testProperty "Scientific" $ forAll genDecimal $+            roundtrips Decode.scientific (column mySQLTypeNewDecimal signed binary)+        , testProperty "Text" (roundtrips Decode.text textColumn)+        , testProperty "lazy Text" (roundtrips (LazyText.fromStrict <$> Decode.text) textColumn)+        , testProperty "String" (roundtrips (Text.unpack <$> Decode.text) textColumn)+        , testProperty "ByteString" (roundtrips Decode.bytes bytesColumn)+        , testProperty "lazy ByteString"+            (roundtrips (LazyByteString.fromStrict <$> Decode.bytes) bytesColumn)+        , testProperty "Day" $ forAll genDay $+            roundtrips Decode.day (column mySQLTypeDate signed binary)+        , testProperty "LocalTime" $ forAll genLocalTime $+            roundtrips Decode.localTime (column mySQLTypeDateTime signed binary)+        , testProperty "TimeOfDay" $ forAll genTimeOfDay $+            roundtrips Decode.timeOfDay (column mySQLTypeTime signed binary)+        , testProperty "Bool" (roundtrips Decode.bool (column mySQLTypeTiny signed binary))+        , testProperty "Maybe Int32"+            (roundtrips (Decode.nullable Decode.int32) (column mySQLTypeLong signed binary))+        , testProperty "Maybe Text" (roundtrips (Decode.nullable Decode.text) textColumn)+        ]+    , testGroup "decode failures"+        [ testCase "NULL into a non-Maybe decoder is FieldUnexpectedNull" $+            decodeBinary Decode.text textColumn MySQLNull+                @?= Left (show (Decode.FieldError (ColumnNumber 0) Decode.FieldUnexpectedNull))+        , testCase "a column of another type is ColumnTypeMismatch" $+            decodeBinary Decode.int8 textColumn (MySQLText "hi")+                @?= Left (show (Decode.ColumnTypeMismatch (ColumnNumber 0) "" mySQLTypeVarString "Int8"))+        , testCase "no implicit widening: an INT column into int64 fails" $+            decodeBinary Decode.int64 (column mySQLTypeLong signed binary) (MySQLInt32 42)+                @?= Left (show (Decode.ColumnTypeMismatch (ColumnNumber 0) "" mySQLTypeLong "Int64"))+        , testCase "negative TIME into timeOfDay fails" $+            decodeBinary Decode.timeOfDay (column mySQLTypeTime signed binary)+                (MySQLTime 1 (TimeOfDay 1 2 3))+                @?= Left (show (Decode.FieldError (ColumnNumber 0)+                                    (Decode.FieldNegativeTime+                                        (B.drop 1 (encodedField (MySQLTime 1 (TimeOfDay 1 2 3)))))))+        ]+    , testGroup "decode alternatives"+        [ testCase "NULL into nullable is Nothing" $+            decodeBinary (Decode.nullable Decode.int32) (column mySQLTypeLong signed binary) MySQLNull+                @?= Right Nothing+        , testCase "TIMESTAMP decodes into LocalTime" $+            decodeBinary Decode.localTime (column mySQLTypeTimestamp signed binary)+                (MySQLTimeStamp (read "2026-07-21 12:00:00"))+                @?= Right (read "2026-07-21 12:00:00")+        , testCase "nonzero TINYINT decodes as True" $+            decodeBinary Decode.bool (column mySQLTypeTiny signed binary) (MySQLInt8 5)+                @?= Right True+        , testCase "unsigned TINYINT decodes into Bool" $+            decodeBinary Decode.bool (column mySQLTypeTiny unsigned binary) (MySQLInt8U 0)+                @?= Right False+        , testCase "nested nullable collapses a NULL to the outer Nothing (as Field does)" $+            decodeBinary (Decode.nullable (Decode.nullable Decode.int32))+                (column mySQLTypeLong signed binary) MySQLNull+                @?= Right Nothing+        , testCase "NaN decodes losslessly" $+            fmap isNaN (decodeBinary Decode.double (column mySQLTypeDouble signed binary)+                            (MySQLDouble (0 / 0)))+                @?= Right True+        ]+    ]++-- | 'toField', encoded as a prepared statement's row and decoded, gives the+-- value back.+roundtrips :: (Field a, Eq a, Show a) => Decode.FieldDecoder a -> ColumnDef -> a -> Property+roundtrips decoder definition value =+    decodeBinary decoder definition (toField value) === Right value++-- | A one-column binary-protocol row holding the value as 'putBinaryField'+-- encodes it, decoded with the decoder; errors are shown, so that column+-- mismatches and field errors compare in one type.+decodeBinary :: Decode.FieldDecoder a -> ColumnDef -> MySQLValue -> Either String a+decodeBinary decoder definition value =+    case Decode.prepareRowDecoder @Decode.BinaryProtocol (Decode.field decoder) (V.singleton definition) of+        Left mismatch  -> Left (show mismatch)+        Right prepared -> either (Left . show) Right (Decode.runPreparedRow prepared (binaryRow value))++-- | The 0x00 header and the NULL map (column 0 is bit 2), then the field.+binaryRow :: MySQLValue -> ByteString+binaryRow value = case value of+    MySQLNull -> B.pack [0x00, 0x04]+    _         -> B.concat [B.pack [0x00, 0x00], encodedField value]++-- | The value as 'putBinaryField' writes it; for the length-prefixed types+-- that includes the length byte, which a decoder's field bytes do not.+encodedField :: MySQLValue -> ByteString+encodedField value = LazyByteString.toStrict (runPut (putBinaryField value))++column :: FieldType -> Word16 -> Word16 -> ColumnDef+column fieldType flags charSet = ColumnDef+    { columnDB        = ""+    , columnTable     = ""+    , columnOrigTable = ""+    , columnName      = ""+    , columnOrigName  = ""+    , columnCharSet   = charSet+    , columnLength    = 0+    , columnType      = fieldType+    , columnFlags     = flags+    , columnDecimals  = 0+    }++signed, unsigned :: Word16+signed = 0+unsigned = 32++binary, utf8 :: Word16+binary = 63+utf8 = 33++textColumn, bytesColumn :: ColumnDef+textColumn = column mySQLTypeVarString signed utf8+bytesColumn = column mySQLTypeBlob signed binary++-- | DECIMALs as MySQL holds them: a coefficient and a modest exponent, which+-- 'putBinaryField' writes out in full.+genDecimal :: Gen Scientific+genDecimal = scientific <$> arbitrary <*> choose (-30, 30)++-- | Days the 2-byte year of the binary protocol carries.+genDay :: Gen Day+genDay = fromGregorian <$> choose (0, 9999) <*> choose (1, 12) <*> choose (1, 28)++-- | DATETIMEs to the microsecond, the binary protocol's resolution.+genLocalTime :: Gen LocalTime+genLocalTime = LocalTime <$> genDay <*> (TimeOfDay <$> choose (0, 23) <*> choose (0, 59) <*> genSeconds)++-- | TIMEs up to MySQL's 838 hours, to the microsecond.+genTimeOfDay :: Gen TimeOfDay+genTimeOfDay = TimeOfDay <$> choose (0, 838) <*> choose (0, 59) <*> genSeconds++genSeconds :: Gen Pico+genSeconds = MkFixed <$> ((* 1000000) <$> choose (0, 59999999))

@@ -0,0 +1,323 @@+-- | The decoders of "Database.MySQL.Decoder" against the paths they bypass:+-- 'mysqlValue' must give the values 'decodeTextRow' and 'getBinaryRow' give,+-- and each typed decoder the value "Database.MySQL.Field" gets from the same+-- field through 'MySQLValue', in both protocols.+module DirectDecoding (tests) where++import           Data.Binary.Parser                 (parseOnly)+import           Data.Binary.Put                    (putByteString, putDoublele,+                                                     putFloatle, runPut)+import           Data.Bits                          (setBit)+import           Data.ByteString                    (ByteString)+import qualified Data.ByteString                    as B+import qualified Data.ByteString.Char8              as BC+import qualified Data.ByteString.Lazy               as L+import           Data.Int                           (Int32)+import           Data.Maybe                         (fromMaybe, isJust, isNothing)+import           Data.Text                          (Text)+import qualified Data.Text.Encoding                 as T+import           Data.Time.Calendar                 (Day, fromGregorian)+import qualified Data.Vector                        as V+import           Data.Word                          (Word8)+import qualified Database.MySQL.Decoder             as Decode+import           Database.MySQL.Field+import           Database.MySQL.Protocol.ColumnDef+import           Database.MySQL.Protocol.MySQLValue+import           Database.MySQL.Protocol.Packet     (putLenEncInt)+import           Test.QuickCheck+import           Test.QuickCheck.Instances          ()+import           Test.Tasty+import           Test.Tasty.HUnit                   (testCase, (@?=))+import           Test.Tasty.QuickCheck              (testProperty)+import           TextRowDecoding                    (binary, columnOf,+                                                     employeeColumns,+                                                     employeeRow, encodeRow,+                                                     genColumn, genField, genRow,+                                                     utf8)++tests :: TestTree+tests = testGroup "direct decoding"+    [ testProperty "text rows: mysqlValue gives what decodeTextRow gives" $+        forAll genRow $ \(columns, fields) ->+            forAll (choose (0, B.length (encodeRow fields))) $ \kept ->+                conjoin+                    [ textMySQLValues columns (encodeRow fields)+                        === shownRow (decodeTextRow (map columnKind columns) (encodeRow fields))+                    , textMySQLValues columns (B.take kept (encodeRow fields))+                        === shownRow (decodeTextRow (map columnKind columns) (B.take kept (encodeRow fields)))+                    ]+    , testProperty "binary rows: mysqlValue gives what getBinaryRow gives" $ checkCoverage $+        forAll genBinaryRow $ \(columns, row) ->+            forAll (choose (0, B.length row)) $ \kept ->+                cover 25 (isJust (getBinaryRowValues columns row)) "the whole row decodes" $+                conjoin+                    [ binaryMySQLValues columns row === getBinaryRowValues columns row+                    , binaryMySQLValues columns (B.take kept row)+                        === getBinaryRowValues columns (B.take kept row)+                    ]+    , testProperty "binary rows: decodeBinaryValues gives what getBinaryRow gives" $ checkCoverage $+        forAll genBinaryRow $ \(columns, row) ->+            forAll (choose (0, B.length row)) $ \kept ->+                cover 25 (isJust (getBinaryRowValues columns row)) "the whole row decodes" $+                conjoin+                    [ shownRow (Decode.decodeBinaryValues (Decode.binaryValueColumns columns) row)+                        === getBinaryRowValues columns row+                    , shownRow (Decode.decodeBinaryValues (Decode.binaryValueColumns columns) (B.take kept row))+                        === getBinaryRowValues columns (B.take kept row)+                    ]+    , testProperty "text rows: by column number gives what the row decoder gives" $ checkCoverage $+        forAll genRow $ \(columns, fields) ->+            forAll (choose (0, B.length (encodeRow fields))) $ \kept ->+                cover 25 (isJust (textMySQLValues columns (encodeRow fields))) "the whole row decodes" $+                conjoin+                    [ rawRowValues columns (Decode.textRawRow (length columns) (encodeRow fields))+                        === textMySQLValues columns (encodeRow fields)+                    , rawRowValues columns (Decode.textRawRow (length columns) (B.take kept (encodeRow fields)))+                        === textMySQLValues columns (B.take kept (encodeRow fields))+                    ]+    , testProperty "binary rows: by column number gives what the row decoder gives" $ checkCoverage $+        forAll genBinaryRow $ \(columns, row) ->+            forAll (choose (0, B.length row)) $ \kept ->+                cover 25 (isJust (binaryMySQLValues columns row)) "the whole row decodes" $+                conjoin+                    [ rawRowValues columns (binaryRawRowOf columns row) === binaryMySQLValues columns row+                    , rawRowValues columns (binaryRawRowOf columns (B.take kept row))+                        === binaryMySQLValues columns (B.take kept row)+                    ]+    , testProperty "text fields: a typed decoder gives what Field gives" $ checkCoverage $+        forAll genColumn $ \column -> forAll (genField (columnKind column)) $ \fieldBytes ->+            case comparisonFor column of+                Nothing -> property True+                Just (Comparison decoder viaField) ->+                    cover 40 (isJust (viaFieldText viaField column (encodeRow [fieldBytes])))+                        "the field decodes" $+                    typedText decoder column (encodeRow [fieldBytes])+                        === viaFieldText viaField column (encodeRow [fieldBytes])+    , testProperty "binary fields: a typed decoder gives what Field gives" $ checkCoverage $+        forAll genColumn $ \column -> forAll (genBinaryField column) $ \fieldBytes ->+            case comparisonFor column of+                Nothing -> property True+                Just (Comparison decoder viaField) ->+                    cover 40 (isJust (viaFieldBinary viaField column (encodeBinaryRow [fieldBytes])))+                        "the field decodes" $+                    typedBinary decoder column (encodeBinaryRow [fieldBytes])+                        === viaFieldBinary viaField column (encodeBinaryRow [fieldBytes])+    , testCase "a raw row knows where each field is" $+        fmap (\row -> map (Decode.rawField row . ColumnNumber) [0, 1, 6]) (Decode.textRawRow 6 employeeRow)+            @?= Right [Decode.RawBytes "10001", Decode.RawBytes "1953-09-02", Decode.RawAbsent]+    , testCase "a column number past the row is absent, however large" $+        fmap (\row -> map (Decode.rawField row . ColumnNumber) [6, 2 ^ (62 :: Int), 2 ^ (62 :: Int) + 1000, -1])+             (Decode.textRawRow 6 employeeRow)+            @?= Right (replicate 4 Decode.RawAbsent)+    , testCase "a record decoder reads the employees row" $+        decodeTextWith employeeDecoder employeeColumns employeeRow+            @?= Decoded (10001, fromGregorian 1953 9 2, "Georgi", "Facello", "M", fromGregorian 1986 6 26)+    , testCase "a decoder for fewer columns than the result set has" $+        decodeTextWith (Decode.field Decode.int32) employeeColumns employeeRow+            @?= Mismatch (Decode.ColumnCountMismatch 1 6)+    , testCase "a decoder that does not take the column's type" $+        decodeTextWith (Decode.field Decode.text) [columnOf mySQLTypeLong 0 binary] (encodeRow [Just "1"])+            @?= Mismatch (Decode.ColumnTypeMismatch (ColumnNumber 0) "" mySQLTypeLong "Text")+    , testCase "NULL is Nothing for a nullable decoder" $+        decodeTextWith (Decode.field (Decode.nullable Decode.int32)) [columnOf mySQLTypeLong 0 binary]+            (encodeRow [Nothing])+            @?= Decoded Nothing+    , testCase "NULL is an error for any other decoder" $+        decodeTextWith (Decode.field Decode.int32) [columnOf mySQLTypeLong 0 binary] (encodeRow [Nothing])+            @?= FieldFailed (Decode.FieldError (ColumnNumber 0) Decode.FieldUnexpectedNull)+    , testCase "a negative TIME is not a TimeOfDay" $+        decodeTextWith (Decode.field Decode.timeOfDay) [columnOf mySQLTypeTime 0 binary]+            (encodeRow [Just "-01:00:00"])+            @?= FieldFailed (Decode.FieldError (ColumnNumber 0) (Decode.FieldNegativeTime "-01:00:00"))+    , testCase "invalid UTF-8 is an error, not an exception" $+        decodeTextWith (Decode.field Decode.text) [columnOf mySQLTypeVarString 0 utf8]+            (encodeRow [Just (B.pack [0xff])])+            @?= FieldFailed (Decode.FieldError (ColumnNumber 0) (Decode.FieldInvalidUtf8 (B.pack [0xff])))+    , testCase "the binary protocol's signed integers are two's complement" $+        decodeBinaryWith (Decode.field Decode.int32) [columnOf mySQLTypeLong 0 binary]+            (encodeBinaryRow [Just (B.pack [0xfe, 0xff, 0xff, 0xff])])+            @?= Decoded (-2)+    ]++employeeDecoder :: Decode.RowDecoder (Int32, Day, Text, Text, Text, Day)+employeeDecoder = (,,,,,)+    <$> Decode.field Decode.int32+    <*> Decode.field Decode.day+    <*> Decode.field Decode.text+    <*> Decode.field Decode.text+    <*> Decode.field Decode.text+    <*> Decode.field Decode.day++-- | What decoding one row came to.+data Outcome a+    = Mismatch Decode.ColumnMismatch+    | FieldFailed Decode.FieldError+    | Decoded a+    deriving (Show, Eq)++decodeTextWith :: Decode.RowDecoder a -> [ColumnDef] -> ByteString -> Outcome a+decodeTextWith decoder columns row = case Decode.prepareRowDecoder @Decode.TextProtocol decoder (V.fromList columns) of+    Left mismatch  -> Mismatch mismatch+    Right prepared -> either FieldFailed Decoded (Decode.runPreparedRow prepared row)++decodeBinaryWith :: Decode.RowDecoder a -> [ColumnDef] -> ByteString -> Outcome a+decodeBinaryWith decoder columns row = case Decode.prepareRowDecoder @Decode.BinaryProtocol decoder (V.fromList columns) of+    Left mismatch  -> Mismatch mismatch+    Right prepared -> either FieldFailed Decoded (Decode.runPreparedRow prepared row)++-- | Every column through 'Decode.mysqlValue'.+allValues :: [ColumnDef] -> Decode.RowDecoder [MySQLValue]+allValues = traverse (const (Decode.field Decode.mysqlValue))++-- | Every column through 'Decode.mysqlValue' on a 'Decode.RawRow', by column+-- number, as a library decoding by column number would.+rawRowValues :: Decode.RowProtocol protocol+             => [ColumnDef] -> Either RowError (Decode.RawRow protocol) -> Maybe String+rawRowValues columns rawRow = do+    raw <- either (const Nothing) Just rawRow+    parsers <- either (const Nothing) Just+        (traverse (uncurry (Decode.prepareFieldParser Decode.mysqlValue)) (zip (map ColumnNumber [0 ..]) columns))+    shownRow (traverse (rawFieldValue raw) (zip (map ColumnNumber [0 ..]) parsers))++rawFieldValue :: Decode.RawRow protocol -> (ColumnNumber, Decode.FieldParser protocol MySQLValue)+              -> Either Decode.FieldError MySQLValue+rawFieldValue raw (column, parser) = Decode.runFieldParser parser raw column Left Right++-- | Values are compared shown, so that a NaN read from random bytes equals itself.+shownRow :: Either rowError [MySQLValue] -> Maybe String+shownRow = either (const Nothing) (Just . show)++binaryRawRowOf :: [ColumnDef] -> ByteString -> Either RowError (Decode.RawRow Decode.BinaryProtocol)+binaryRawRowOf columns = Decode.binaryRawRow (V.fromList (map Decode.binaryWidth columns))++textMySQLValues :: [ColumnDef] -> ByteString -> Maybe String+textMySQLValues columns row = shownOutcome (decodeTextWith (allValues columns) columns row)++binaryMySQLValues :: [ColumnDef] -> ByteString -> Maybe String+binaryMySQLValues columns row = shownOutcome (decodeBinaryWith (allValues columns) columns row)++getBinaryRowValues :: [ColumnDef] -> ByteString -> Maybe String+getBinaryRowValues columns row = shownRow (parseOnly (getBinaryRow columns (length columns)) row)++-- | A typed decoder and the "Database.MySQL.Field" conversion for the same type.+data Comparison = forall a. Show a => Comparison (Decode.FieldDecoder a) (MySQLValue -> Either DecodeError a)++-- | The comparison for a column's kind; YEAR, GEOMETRY and BIT have no typed+-- decoder, and a column of type NULL has no kind.+comparisonFor :: ColumnDef -> Maybe Comparison+comparisonFor column = case columnKind column of+    NullColumn -> Nothing+    ValueColumn _ kind -> case kind of+        KindDecimal     -> Just (Comparison Decode.scientific decodeScientific)+        KindInt8U       -> Just (Comparison Decode.word8 decodeWord8)+        KindInt8        -> Just (Comparison Decode.int8 decodeInt8)+        KindInt16U      -> Just (Comparison Decode.word16 decodeWord16)+        KindInt16       -> Just (Comparison Decode.int16 decodeInt16)+        KindInt32U      -> Just (Comparison Decode.word32 decodeWord32)+        KindInt32       -> Just (Comparison Decode.int32 decodeInt32)+        KindInt64U      -> Just (Comparison Decode.word64 decodeWord64)+        KindInt64       -> Just (Comparison Decode.int64 decodeInt64)+        KindFloat       -> Just (Comparison Decode.float decodeFloat')+        KindDouble      -> Just (Comparison Decode.double decodeDouble)+        KindYear        -> Nothing+        KindTimeStamp   -> Just (Comparison Decode.localTime decodeLocalTime)+        KindDateTime    -> Just (Comparison Decode.localTime decodeLocalTime)+        KindDate        -> Just (Comparison Decode.day decodeDay)+        KindTime        -> Just (Comparison Decode.timeOfDay decodeTimeOfDay)+        KindGeometry    -> Nothing+        KindText _      -> Just (Comparison Decode.text decodeText)+        KindLatin1Text  -> Just (Comparison Decode.text decodeText)+        KindBytes       -> Just (Comparison Decode.bytes decodeByteString)+        KindBit         -> Nothing+        KindUnsupported -> Nothing++typedText :: Show a => Decode.FieldDecoder a -> ColumnDef -> ByteString -> Maybe String+typedText decoder column row = shownOutcome (decodeTextWith (Decode.field decoder) [column] row)++viaFieldText :: Show a => (MySQLValue -> Either DecodeError a) -> ColumnDef -> ByteString -> Maybe String+viaFieldText viaField column row = case decodeTextRow [columnKind column] row of+    Right [value] -> either (const Nothing) (Just . show) (viaField value)+    Right values  -> Just ("unexpected values: " ++ show values)+    Left _        -> Nothing++typedBinary :: Show a => Decode.FieldDecoder a -> ColumnDef -> ByteString -> Maybe String+typedBinary decoder column row = shownOutcome (decodeBinaryWith (Decode.field decoder) [column] row)++-- | The value shown, 'Nothing' for a row or field that did not decode; a column+-- mismatch is a failure of the test, so it shows up in the comparison.+shownOutcome :: Show a => Outcome a -> Maybe String+shownOutcome decoded = case decoded of+    Decoded value     -> Just (show value)+    FieldFailed _     -> Nothing+    Mismatch mismatch -> Just ("mismatch: " ++ show mismatch)++viaFieldBinary :: Show a => (MySQLValue -> Either DecodeError a) -> ColumnDef -> ByteString -> Maybe String+viaFieldBinary viaField column row = case parseOnly (getBinaryRow [column] 1) row of+    Right [value] -> either (const Nothing) (Just . show) (viaField value)+    Right values  -> Just ("unexpected values: " ++ show values)+    Left _        -> Nothing++genBinaryRow :: Gen ([ColumnDef], ByteString)+genBinaryRow = do+    columnCount <- choose (0, 8)+    columns <- vectorOf columnCount genColumn+    fields <- mapM genBinaryField columns+    pure (columns, encodeBinaryRow fields)++-- | A field as a prepared statement's row carries it: 'Nothing' for NULL, which+-- a column of type NULL always is, otherwise the bytes after the NULL map.+genBinaryField :: ColumnDef -> Gen (Maybe ByteString)+genBinaryField column = case columnKind column of+    NullColumn         -> pure Nothing+    ValueColumn _ kind -> frequency [(1, pure Nothing), (6, Just <$> genBinaryValue kind)]++-- | Mostly what the server sends, sometimes lengths or bytes it would not, such+-- as a string that is not UTF-8 in a character set read as UTF-8.+genBinaryValue :: ValueKind -> Gen ByteString+genBinaryValue kind = case kind of+    KindDecimal     -> lengthEncoded . BC.pack . show <$> (arbitrary :: Gen Double)+    KindInt8U       -> genBytes 1+    KindInt8        -> genBytes 1+    KindInt16U      -> genBytes 2+    KindInt16       -> genBytes 2+    KindInt32U      -> genBytes 4+    KindInt32       -> genBytes 4+    KindInt64U      -> genBytes 8+    KindInt64       -> genBytes 8+    KindFloat       -> L.toStrict . runPut . putFloatle <$> arbitrary+    KindDouble      -> L.toStrict . runPut . putDoublele <$> arbitrary+    KindYear        -> genBytes 2+    KindTimeStamp   -> lengthEncoded <$> (elements [0, 4, 7, 11, 5] >>= genBytes)+    KindDateTime    -> lengthEncoded <$> (elements [0, 4, 7, 11, 5] >>= genBytes)+    KindDate        -> lengthEncoded <$> (elements [0, 4, 3] >>= genBytes)+    KindTime        -> lengthEncoded <$> (elements [0, 8, 12, 9] >>= genBytes)+    KindGeometry    -> lengthEncoded <$> arbitrary+    KindText _      -> lengthEncoded <$> frequency [(9, T.encodeUtf8 <$> arbitrary), (1, arbitrary)]+    KindLatin1Text  -> lengthEncoded <$> arbitrary+    KindBytes       -> lengthEncoded <$> arbitrary+    KindBit         -> lengthEncoded <$> (choose (1, 10) >>= genBytes)+    KindUnsupported -> lengthEncoded <$> arbitrary++genBytes :: Int -> Gen ByteString+genBytes count = B.pack <$> vector count++lengthEncoded :: ByteString -> ByteString+lengthEncoded fieldBytes =+    L.toStrict (runPut (putLenEncInt (B.length fieldBytes) >> putByteString fieldBytes))++-- | The 0x00 header, the NULL map with column @i@ at bit @i + 2@, then the+-- non-NULL fields.+encodeBinaryRow :: [Maybe ByteString] -> ByteString+encodeBinaryRow fields = B.concat+    (B.singleton 0x00 : binaryNullMap fields : map (fromMaybe B.empty) fields)++binaryNullMap :: [Maybe ByteString] -> ByteString+binaryNullMap fields = B.pack+    (map (nullMapByte (nullBits fields)) [0 .. (length fields + 7 + 2) `div` 8 - 1])++nullBits :: [Maybe ByteString] -> [Int]+nullBits fields = map fst (filter (isNothing . snd) (zip [2 ..] fields))++nullMapByte :: [Int] -> Int -> Word8+nullMapByte bits byteIndex =+    foldr (flip setBit) 0 (map (subtract (8 * byteIndex)) (filter ((== byteIndex) . (`div` 8)) bits))

@@ -0,0 +1,40 @@+-- | FLOAT and DOUBLE values MySQL writes in exponent form. The text protocol+-- sends large ones as, for example, @1e20@; reading them as plain decimals+-- stopped at the @e@ and gave 1.+module FloatingPoint (tests) where++import           Database.MySQL.Base+import           QueryApi+import qualified System.IO.Streams as Stream+import           Test.Tasty+import           Test.Tasty.HUnit++exponentForms :: Query+exponentForms =+    "SELECT CAST(1e20 AS DOUBLE), CAST(-1e20 AS DOUBLE), CAST(1.5e300 AS DOUBLE), \+    \CAST(2.5e-7 AS DOUBLE), CAST(1e20 AS FLOAT)"++expected :: [MySQLValue]+expected = [MySQLDouble 1e20, MySQLDouble (-1e20), MySQLDouble 1.5e300, MySQLDouble 2.5e-7, MySQLFloat 1e20]++tests :: QueryApi -> TestTree+tests api = testGroup "FLOAT and DOUBLE in exponent form"+    [ testCase "text protocol" $ withConnection $ \c -> do+        (_, rows) <- apiQuery_ api (ColumnCount 5) c exponentForms+        values <- Stream.toList rows+        assertEqual "values" [expected] values+    , testCase "binary protocol" $ withConnection $ \c -> do+        stmt <- prepareStmt c exponentForms+        (_, rows) <- apiQueryStmt api (ColumnCount 5) c stmt []+        values <- Stream.toList rows+        assertEqual "values" [expected] values+    ]++withConnection :: (MySQLConn -> Assertion) -> Assertion+withConnection body = do+    (_, c) <- connectDetail defaultConnectInfo+        { ciUser = "testMySQLHaskell"+        , ciDatabase = "testMySQLHaskell"+        }+    body c+    close c

@@ -0,0 +1,59 @@+-- | 'readDouble' and 'readFloat' must give the nearest value, as 'read' does,+-- for every way MySQL writes a FLOAT or DOUBLE: plain decimals, and exponent+-- form for large values, whether the fast path or the exact one reads them.+module FloatingPointText (tests) where++import qualified Data.ByteString.Char8                 as BC+import           Database.MySQL.Protocol.FloatingPoint (readDouble, readFloat)+import           Numeric                               (showFFloat)+import           Test.QuickCheck+import           Test.Tasty+import           Test.Tasty.HUnit                      (testCase, (@?=))+import           Test.Tasty.QuickCheck                 (testProperty)++-- | The properties run 5,000 cases each: CI uses QuickCheck's default of 100,+-- which missed a fast path that accepted truncated significands.+tests :: TestTree+tests = testGroup "FLOAT and DOUBLE text"+    [ testProperty "a shown Double reads back as itself" $ withMaxSuccess 5000 $+        forAll finiteDouble $ \value -> readDouble (BC.pack (show value)) === Just value+    , testProperty "a Double in plain decimals reads back as itself" $ withMaxSuccess 5000 $+        forAll finiteDouble $ \value -> readDouble (BC.pack (showFFloat Nothing value "")) === Just value+    , testProperty "a shown Float reads back as itself" $ withMaxSuccess 5000 $+        forAll finiteFloat $ \value -> readFloat (BC.pack (show value)) === Just value+    , testProperty "any decimal text gives the Double read gives" $ withMaxSuccess 5000 $+        forAll genDecimalText $ \text -> readDouble (BC.pack text) === Just (read text)+    , testProperty "any decimal text gives the Float read gives" $ withMaxSuccess 5000 $+        forAll genDecimalText $ \text -> readFloat (BC.pack text) === Just (read text)+    , testCase "exponent form, as MySQL writes large values" $+        map (readDouble . BC.pack) ["1e20", "-1e20", "1.5e300", "2.5E-7", "1e+5"]+            @?= map Just [1e20, -1e20, 1.5e300, 2.5e-7, 1e5]+    , testCase "seventeen significant digits" $+        readDouble (BC.pack "0.30000000000000004") @?= Just (0.1 + 0.2)+    , testCase "more than 19 significant digits, the first 19 an exact Double" $+        map (readDouble . BC.pack) ["1000000000000000000000", "10000000000000000000000.5", "-20840713482839362564625e5"]+            @?= map Just [1e21, 1e22, -2.0840713482839362564625e27]+    , testCase "out of range" $+        map (readDouble . BC.pack) ["1e400", "1e-400"] @?= map Just [1 / 0, 0]+    , testCase "bytes after the number are ignored, as readDecimal ignored them" $+        map (readDouble . BC.pack) ["12abc", "3.5e", "7.", "1e5x"] @?= map Just [12, 3.5, 7, 1e5]+    , testCase "text that does not start with a number" $+        map (readDouble . BC.pack) ["", "abc", ".5", "-", "e5"] @?= replicate 5 Nothing+    ]++finiteDouble :: Gen Double+finiteDouble = arbitrary `suchThat` (\value -> not (isNaN value || isInfinite value))++finiteFloat :: Gen Float+finiteFloat = arbitrary `suchThat` (\value -> not (isNaN value || isInfinite value))++-- | A sign, 1 to 25 digits, an optional fraction and an optional exponent from+-- -330 to 330: short numbers take the fast path, long ones and large+-- exponents the exact one.+genDecimalText :: Gen String+genDecimalText = do+    sign <- elements ["", "-"]+    integerDigits <- choose (1, 25) >>= flip vectorOf (elements ['0' .. '9'])+    fraction <- oneof [pure "", ('.' :) <$> (choose (1, 20) >>= flip vectorOf (elements ['0' .. '9']))]+    exponentPart <- oneof [pure "", ('e' :) . show <$> choose (-330, 330 :: Int)]+    pure (sign ++ integerDigits ++ fraction ++ exponentPart)

@@ -0,0 +1,95 @@+module HandshakeGolden (tests) where++import qualified Data.Binary                as Binary+import           Data.Bits                  ((.|.))+import qualified Data.ByteString            as B+import qualified Data.ByteString.Base16     as Hex+import qualified Data.ByteString.Char8      as BC+import qualified Data.ByteString.Lazy       as L+import           Database.MySQL.Connection  (handshakeResponsePacket, sslRequestPacket)+import           Database.MySQL.Protocol.Auth+import           Database.MySQL.Protocol.Packet (Packet, getFromPacket, putToPacket)+import           Data.Binary.Put            (putByteString)+import           Test.Tasty+import           Test.Tasty.HUnit++-- Greetings captured from the servers nix/ci.nix tests against, and the+-- packets mysql-haskell 1.3.3 (92a9401) answered them with for user and+-- schema testMySQLHaskell, password "secret" and charset 33.+mariadbGreeting, mysqlGreeting :: B.ByteString+mariadbGreeting = hex "0a31312e342e392d4d6172696144422d6c6f67000a00000068513b714856583500feffe00200ff81150000000000001d0000003e78646c727473657e6b7a47006d7973716c5f6e61746976655f70617373776f726400"+mysqlGreeting = hex "0a382e302e3435001200000073454f634d16264e00ffffff0200ffdf15000000000000000000005d2658501266396b0d7546110063616368696e675f736861325f70617373776f726400"++masterAuthMariaDB, masterTLSAuthMariaDB, masterAuthMySQL, masterTLSAuthMySQL, masterSSLRequest :: B.ByteString+masterAuthMariaDB = hex "6d0000010da30b00ffffff00210000000000000000000000000000000000000000000000746573744d7953514c4861736b656c6c00148993d478ffb390507c14ce8d6da10baff99ac06c746573744d7953514c4861736b656c6c006d7973716c5f6e61746976655f70617373776f726400"+masterTLSAuthMariaDB = hex "6d0000020da30b00ffffff00210000000000000000000000000000000000000000000000746573744d7953514c4861736b656c6c00148993d478ffb390507c14ce8d6da10baff99ac06c746573744d7953514c4861736b656c6c006d7973716c5f6e61746976655f70617373776f726400"+masterAuthMySQL = hex "790000010da30b00ffffff00210000000000000000000000000000000000000000000000746573744d7953514c4861736b656c6c00208d6350e1245ca38229fd5cc86234ea67d2d19056795007230dbec8bd483e4b89746573744d7953514c4861736b656c6c0063616368696e675f736861325f70617373776f726400"+masterTLSAuthMySQL = hex "790000020da30b00ffffff00210000000000000000000000000000000000000000000000746573744d7953514c4861736b656c6c00208d6350e1245ca38229fd5cc86234ea67d2d19056795007230dbec8bd483e4b89746573744d7953514c4861736b656c6c0063616368696e675f736861325f70617373776f726400"+masterSSLRequest = hex "200000010dab0b00ffffff00210000000000000000000000000000000000000000000000"++hex :: String -> B.ByteString+hex = either error id . Hex.decode . BC.pack++parseGreeting :: B.ByteString -> IO (Greeting, ExtendedCapabilities)+parseGreeting = getFromPacket getGreetingExtended . putToPacket 0 . putByteString++wire :: Packet -> B.ByteString+wire = L.toStrict . Binary.encode++-- | Every byte one handshake sends: SSL request, response after it, and the+-- response without TLS.+handshakeBytes :: ExtendedCapabilities -> (Greeting, ExtendedCapabilities) -> (B.ByteString, B.ByteString, B.ByteString)+handshakeBytes requested (greeting, offered) =+    let negotiated = negotiateExtended requested greeting offered+        response seqN = wire (handshakeResponsePacket seqN negotiated "testMySQLHaskell" "testMySQLHaskell" "secret" 33 greeting)+    in (wire (sslRequestPacket negotiated 33), response 2, response 1)++extendedMetadata, everyCapability :: ExtendedCapabilities+extendedMetadata = ExtendedCapabilities 0x08+everyCapability = ExtendedCapabilities 0xffffffff++tests :: TestTree+tests = testGroup "handshake"+    [ testCase "greetings: MariaDB offers extended capabilities, MySQL none" $ do+        (_, mariadbOffer) <- parseGreeting mariadbGreeting+        (_, mysqlOffer) <- parseGreeting mysqlGreeting+        mariadbOffer @?= ExtendedCapabilities 0x1d+        mysqlOffer @?= noExtendedCapabilities+    , testCase "MariaDB is told apart by its greeting's capabilities, not its version string" $ do+        (mariadb, _) <- parseGreeting mariadbGreeting+        (mysql, _) <- parseGreeting mysqlGreeting+        offersExtendedCapabilities mariadb @?= True+        offersExtendedCapabilities mysql @?= False+        -- mariadbd --version=8.0.36 sends exactly this greeting.+        offersExtendedCapabilities mariadb {greetingVersion = "8.0.36"} @?= True+    , testCase "MySQL: 1.3.3's bytes whatever is requested" $ do+        greeting <- parseGreeting mysqlGreeting+        let master = (masterSSLRequest, masterTLSAuthMySQL, masterAuthMySQL)+        handshakeBytes noExtendedCapabilities greeting @?= master+        handshakeBytes extendedMetadata greeting @?= master+        handshakeBytes everyCapability greeting @?= master+    , testCase "MariaDB, nothing requested: 1.3.3's bytes" $ do+        greeting <- parseGreeting mariadbGreeting+        handshakeBytes noExtendedCapabilities greeting+            @?= (masterSSLRequest, masterTLSAuthMariaDB, masterAuthMariaDB)+    , testCase "MariaDB, a capability it does not offer: 1.3.3's bytes" $ do+        greeting <- parseGreeting mariadbGreeting+        handshakeBytes (ExtendedCapabilities 0x02) greeting+            @?= (masterSSLRequest, masterTLSAuthMariaDB, masterAuthMariaDB)+    , testCase "a server setting CLIENT_MYSQL gets 1.3.3's bytes, whatever it offers" $ do+        (greeting, offered) <- parseGreeting mariadbGreeting+        let mysqlFlagged = greeting { greetingCaps = greetingCaps greeting .|. 1 }+        handshakeBytes extendedMetadata (mysqlFlagged, offered)+            @?= (masterSSLRequest, masterTLSAuthMariaDB, masterAuthMariaDB)+    , testCase "MariaDB, extended metadata: CLIENT_MYSQL cleared, bit 35 sent" $ do+        greeting <- parseGreeting mariadbGreeting+        let (ssl, tlsAuth, auth) = handshakeBytes extendedMetadata greeting+            -- 4 header bytes, then capabilities; the extended capabilities+            -- are the last four of the 23 reserved bytes.+            expect master = B.concat+                [ B.take 4 master, hex "0ca30b00", B.take 24 (B.drop 8 master)+                , hex "08000000", B.drop 36 master ]+        auth @?= expect masterAuthMariaDB+        tlsAuth @?= expect masterTLSAuthMariaDB+        ssl @?= B.concat [B.take 4 masterSSLRequest, hex "0cab0b00", B.take 24 (B.drop 8 masterSSLRequest), hex "08000000"]+    ]

@@ -3,13 +3,25 @@ import qualified Data.ByteString as B import           Database.MySQL.Base import           System.Environment (lookupEnv)-import           Test.Tasty (defaultMain, testGroup)+import           Test.Tasty (TestTree, defaultMain, testGroup)+import qualified AbandonedReplies+import qualified BinLogRowEvents+import qualified CABundle import qualified CachingSha2+import qualified FloatingPoint+import qualified MariaDBNegotiation+import qualified LargeRows+import qualified Latin1Results+import qualified PlaceholderLiterals+import qualified UnsignedInsertId+import qualified ZeroDateRoundtrip import qualified MultipleResults import qualified MysqlTests+import           QueryApi import qualified QueryWithoutResultSet import qualified RoundtripBit import qualified RoundtripYear+import qualified RowDecoderQueries import qualified SelectOne import qualified TLSConnection import qualified UnixSocket@@ -30,17 +42,40 @@     mTlsCaPath <- lookupEnv "MYSQL_TLS_CA_PATH"      defaultMain $ testGroup "mysql-integration" $-        [ SelectOne.tests-        , RoundtripBit.tests-        , RoundtripYear.tests-        , MysqlTests.tests-        , QueryWithoutResultSet.tests+        [ MysqlTests.tests         , MultipleResults.tests+        , RowDecoderQueries.tests+        , MariaDBNegotiation.tests greet+        , UnsignedInsertId.tests+        , BinLogRowEvents.tests+        , CABundle.tests+        , ZeroDateRoundtrip.typedDecoderTests         ]-        -- 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.-        ++ [ CachingSha2.tests | isMySql80 ]-        -- Unix socket tests are included only when a socket file is found.-        ++ [ UnixSocket.tests p | Just p <- [mSockPath] ]-        -- TLS tests are included only when a CA certificate path is provided.-        ++ [ TLSConnection.tests p | Just p <- [mTlsCaPath] ]+        -- binlog_transaction_compression is MySQL 8.0.20+ only.+        ++ [ BinLogRowEvents.compressedTransactionTests | isMySql80 ]+        ++ map (apiTests isMySql80 mSockPath mTlsCaPath) queryApis+        -- The typed decoders give a date a 'Day' cannot hold as an error instead+        -- of a value to write back, which 'ZeroDateRoundtrip.typedDecoderTests' checks.+        ++ map ZeroDateRoundtrip.tests mysqlValueApis++-- | The suites that read rows, through one of the 'QueryApi's.+apiTests :: Bool -> Maybe FilePath -> Maybe FilePath -> QueryApi -> TestTree+apiTests isMySql80 mSockPath mTlsCaPath api = testGroup (apiName api) $+    [ SelectOne.tests api+    , RoundtripBit.tests api+    , RoundtripYear.tests api+    , QueryWithoutResultSet.tests api+    , MultipleResults.rowTests api+    , FloatingPoint.tests api+    , LargeRows.tests api+    , PlaceholderLiterals.tests api+    , Latin1Results.tests api+    , AbandonedReplies.tests api+    ]+    -- 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.+    ++ [ CachingSha2.tests api | isMySql80 ]+    -- Unix socket tests are included only when a socket file is found.+    ++ maybe [] (\p -> [UnixSocket.tests api p]) mSockPath+    -- TLS tests are included only when a CA certificate path is provided.+    ++ maybe [] (\p -> [TLSConnection.tests api p]) mTlsCaPath

@@ -0,0 +1,19 @@+-- | Tests of "Database.MariaDB" that need a MariaDB server; nix/ci.nix+-- runs them in the MariaDB VM only. Capability negotiation against MySQL is+-- covered by the shared integration suite.+module Main (main) where++import           System.Environment (lookupEnv)+import           Test.Tasty (defaultMain, testGroup)+import qualified MariaDBBulk+import qualified MariaDBExtendedMetadata+import qualified UnixSocket++main :: IO ()+main = do+    socketPath <- UnixSocket.findSocketPath+    caPath <- lookupEnv "MYSQL_TLS_CA_PATH"+    defaultMain $ testGroup "mariadb-integration"+        [ MariaDBExtendedMetadata.tests socketPath caPath+        , MariaDBBulk.tests+        ]

@@ -0,0 +1,28 @@+-- | Text-protocol rows whose first value is 16 MiB or longer: its length+-- prefix starts with the same byte as an EOF packet, so the row was taken for+-- the end of the result. Binary-protocol rows start with 0x00 and never were.+module LargeRows (tests) where++import qualified Data.ByteString.Lazy.Char8 as LC+import qualified Data.Text                  as T+import           Database.MySQL.Base+import           QueryApi+import qualified System.IO.Streams          as Stream+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUser                   (withTestConnection)++tests :: QueryApi -> TestTree+tests api = testGroup "values of 16 MiB and longer" (map (firstValueOf api) [16777216, 16777217, 33554430])++firstValueOf :: QueryApi -> Int -> TestTree+firstValueOf api size = testCase (show size ++ " bytes") $ withTestConnection $ \c -> do+    (_, rows) <- apiQuery_ api (ColumnCount 2) c (Query (LC.pack ("SELECT REPEAT('a', " ++ show size ++ "), 'after'")))+    Stream.toList rows >>= assertOneRow size++assertOneRow :: Int -> [[MySQLValue]] -> Assertion+assertOneRow size rows = case rows of+    [[MySQLText value, MySQLText after]] -> do+        assertEqual "length of the long value" size (T.length value)+        assertEqual "value after it" "after" after+    other -> assertFailure ("rows: " ++ take 200 (show other))

@@ -0,0 +1,36 @@+-- | Results in latin1, as after @SET NAMES latin1@. Their bytes used to be+-- decoded as UTF-8, which threw on anything outside ASCII.+module Latin1Results (tests) where++import           Control.Monad       (void)+import           Database.MySQL.Base+import           QueryApi+import qualified System.IO.Streams   as Stream+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUser            (withTestConnection)++tests :: QueryApi -> TestTree+tests api = testCase "latin1 results decode to the characters the server means" $+    withTestConnection $ \c -> do+        void (execute_ c "CREATE TEMPORARY TABLE latin1_results (b VARCHAR(200) CHARACTER SET latin1)")+        -- Every byte from 0x80 up, the part of latin1 that is not ASCII.+        void (execute_ c "INSERT INTO latin1_results VALUES (CONVERT(UNHEX(CONCAT(\+                         \'808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F',\+                         \'A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF',\+                         \'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF',\+                         \'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEFF0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF')) USING latin1))")+        serverUtf8 <- selectAll c+        void (execute_ c "SET NAMES latin1")+        (_, latin1Rows) <- apiQuery_ api (ColumnCount 1) c "SELECT b FROM latin1_results"+        textRows <- Stream.toList latin1Rows+        assertEqual "text protocol" serverUtf8 textRows+        stmt <- prepareStmt c "SELECT b FROM latin1_results"+        (_, rows) <- apiQueryStmt api (ColumnCount 1) c stmt []+        binaryRows <- Stream.toList rows+        assertEqual "binary protocol" serverUtf8 binaryRows++selectAll :: MySQLConn -> IO [[MySQLValue]]+selectAll c = do+    (_, rows) <- query_ c "SELECT b FROM latin1_results"+    Stream.toList rows

@@ -10,6 +10,16 @@ import qualified TCPStreams import qualified BoundsCheck import qualified FieldRoundtrip+import qualified TextRowDecoding+import qualified DirectDecoding+import qualified DecoderRoundtrip+import qualified FloatingPointText+import qualified HandshakeGolden+import qualified BinLogEventCodes+import qualified PacketClassification+import qualified Placeholders+import qualified ResultCharsets+import qualified ZeroDates  main :: IO () main = do@@ -30,4 +40,14 @@       , Sha256Scramble.tests       , BoundsCheck.tests       , FieldRoundtrip.tests+      , TextRowDecoding.tests+      , DirectDecoding.tests+      , DecoderRoundtrip.tests+      , FloatingPointText.tests+      , HandshakeGolden.tests+      , PacketClassification.tests+      , Placeholders.tests+      , ZeroDates.tests+      , ResultCharsets.tests+      , BinLogEventCodes.tests       ]

@@ -0,0 +1,82 @@+module MariaDBBulk (tests) where++import           Control.Exception      (try)+import           Data.List.NonEmpty     (NonEmpty ((:|)))+import qualified Data.List.NonEmpty     as NonEmpty+import qualified Data.Text              as T+import           Database.MySQL.Base+import           Database.MariaDB+import qualified System.IO.Streams      as Stream+import           Test.Tasty+import           Test.Tasty.HUnit++testConnectInfo :: ConnectInfo+testConnectInfo = defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"}++withBulkConnection :: (MariaDBConn -> MySQLConn -> IO a) -> IO a+withBulkConnection action = do+    conn <- connectMariaDB [MariaDBBulkOperations] testConnectInfo+    mariadbCapabilities conn @?= [MariaDBBulkOperations]+    result <- action conn (mysqlConnection conn)+    close (mysqlConnection conn)+    pure result++selectRows :: MySQLConn -> Query -> IO [[MySQLValue]]+selectRows conn sql = query_ conn sql >>= Stream.toList . snd++thousandRows :: NonEmpty [BulkParam]+thousandRows = NonEmpty.fromList+    (map (\n -> [BulkValue (MySQLInt32 n), BulkValue (MySQLText (T.pack ("row " ++ show n)))]) [1 .. 1000])++tests :: TestTree+tests = testGroup "MariaDB bulk execution"+    [ testCase "inserts every row in one command" $ withBulkConnection $ \conn mysqlConn -> do+        _ <- execute_ mysqlConn "CREATE TEMPORARY TABLE bulk_rows (n INT, s VARCHAR(16))"+        statement <- prepareStmt mysqlConn "INSERT INTO bulk_rows VALUES (?, ?)"+        ok <- executeBulk conn statement thousandRows+        okAffectedRows ok @?= 1000+        counts <- selectRows mysqlConn "SELECT COUNT(*), SUM(n), COUNT(DISTINCT s) FROM bulk_rows"+        counts @?= [[MySQLInt64 1000, MySQLDecimal 500500, MySQLInt64 1000]]+        sample <- selectRows mysqlConn "SELECT n, s FROM bulk_rows WHERE n IN (1, 1000) ORDER BY n"+        sample @?= [[MySQLInt32 1, MySQLText "row 1"], [MySQLInt32 1000, MySQLText "row 1000"]]+    , testCase "NULL, DEFAULT and IGNORE indicators" $ withBulkConnection $ \conn mysqlConn -> do+        _ <- execute_ mysqlConn "CREATE TEMPORARY TABLE bulk_indicators \+            \(id INT PRIMARY KEY, a INT DEFAULT 7, b VARCHAR(8) DEFAULT 'dflt', c INT NULL)"+        insert <- prepareStmt mysqlConn "INSERT INTO bulk_indicators VALUES (?, ?, ?, ?)"+        _ <- executeBulk conn insert $+               [BulkValue (MySQLInt32 1), BulkValue (MySQLInt32 1), BulkValue (MySQLText "x"), BulkValue MySQLNull]+            :| [[BulkValue (MySQLInt32 2), BulkDefault, BulkIgnore, BulkValue (MySQLInt32 3)]]+        inserted <- selectRows mysqlConn "SELECT id, a, b, c FROM bulk_indicators ORDER BY id"+        inserted @?=+            [ [MySQLInt32 1, MySQLInt32 1, MySQLText "x", MySQLNull]+            , [MySQLInt32 2, MySQLInt32 7, MySQLText "dflt", MySQLInt32 3] ]+        update <- prepareStmt mysqlConn "UPDATE bulk_indicators SET a = ?, b = ? WHERE id = ?"+        ok <- executeBulk conn update $+               [BulkIgnore, BulkValue (MySQLText "y"), BulkValue (MySQLInt32 1)]+            :| [[BulkValue (MySQLInt32 9), BulkIgnore, BulkValue (MySQLInt32 2)]]+        okAffectedRows ok @?= 2+        updated <- selectRows mysqlConn "SELECT id, a, b FROM bulk_indicators ORDER BY id"+        updated @?=+            [ [MySQLInt32 1, MySQLInt32 1, MySQLText "y"]+            , [MySQLInt32 2, MySQLInt32 9, MySQLText "dflt"] ]+    , testCase "rows the command cannot carry are refused before sending" $ withBulkConnection $ \conn mysqlConn -> do+        _ <- execute_ mysqlConn "CREATE TEMPORARY TABLE bulk_refused (n INT)"+        statement <- prepareStmt mysqlConn "INSERT INTO bulk_refused VALUES (?)"+        mixed <- try (executeBulk conn statement ([BulkValue (MySQLInt32 1)] :| [[BulkValue (MySQLText "2")]]))+        mixed @?= Left (BulkMixedTypes 0 [MySQLInt32 1, MySQLText "2"])+        ragged <- try (executeBulk conn statement ([BulkValue (MySQLInt32 1)] :| [[]]))+        ragged @?= Left (BulkRowWidth 1 1 0)+        empty <- try (executeBulk conn statement ([] :| []))+        empty @?= Left BulkNoParameters+        stored <- selectRows mysqlConn "SELECT COUNT(*) FROM bulk_refused"+        stored @?= [[MySQLInt64 0]]+    , testCase "a server error leaves the connection usable" $ withBulkConnection $ \conn mysqlConn -> do+        _ <- execute_ mysqlConn "CREATE TEMPORARY TABLE bulk_unique (n INT PRIMARY KEY)"+        statement <- prepareStmt mysqlConn "INSERT INTO bulk_unique VALUES (?)"+        duplicate <- try (executeBulk conn statement ([BulkValue (MySQLInt32 1)] :| [[BulkValue (MySQLInt32 1)]]))+        case duplicate of+            Left (ERRException err) -> errCode err @?= 1062+            Right ok -> assertFailure ("duplicate key accepted: " ++ show ok)+        rows <- selectRows mysqlConn "SELECT 'still usable'"+        rows @?= [[MySQLText "still usable"]]+    ]

@@ -0,0 +1,96 @@+module MariaDBExtendedMetadata (tests) where++import qualified Data.ByteString        as B+import           Database.MySQL.Base+import           Database.MariaDB+import qualified Database.MySQL.TLS     as TLS+import qualified System.IO.Streams      as Stream+import           Test.Tasty+import           Test.Tasty.HUnit++testConnectInfo :: ConnectInfo+testConnectInfo = defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"}++createTable :: MySQLConn -> IO ()+createTable conn = do+    _ <- execute_ conn "DROP TABLE IF EXISTS mariadb_extended"+    _ <- execute_ conn "CREATE TABLE mariadb_extended (n INT, j JSON, u UUID, a INET6, p POINT, s VARCHAR(8))"+    _ <- execute_ conn "INSERT INTO mariadb_extended VALUES (1, '{\"k\":1}', '123e4567-e89b-12d3-a456-426614174000', '::1', POINT(1,2), 'plain')"+    pure ()++columnNamed :: B.ByteString -> [ColumnMetadata] -> IO ColumnMetadata+columnNamed name columns = case filter ((== name) . columnName . columnDefinition) columns of+    [column] -> pure column+    found    -> assertFailure ("expected one column " ++ show name ++ ", got " ++ show found)++selectAll :: Query+selectAll = "SELECT n, j, u, a, s FROM mariadb_extended WHERE n = ?"++expectedRow :: [MySQLValue]+expectedRow =+    [ MySQLInt32 1, MySQLText "{\"k\":1}", MySQLText "123e4567-e89b-12d3-a456-426614174000"+    , MySQLText "::1", MySQLText "plain" ]++tests :: Maybe FilePath -> Maybe FilePath -> TestTree+tests socketPath caPath = testGroup "MariaDB extended column metadata" $+    [ testCase "prepared statement columns name their SQL types" $ do+        conn <- connectMariaDB [MariaDBExtendedMetadata] testConnectInfo+        createTable (mysqlConnection conn)+        (_, params, columns) <- prepareStmtMetadata conn "SELECT n, j, u, a, p, s FROM mariadb_extended WHERE n = ?"+        length params @?= 1+        map (columnName . columnDefinition) columns @?= ["n", "j", "u", "a", "p", "s"]+        n <- columnNamed "n" columns+        columnExtended n @?= []+        j <- columnNamed "j" columns+        columnExtended j @?= [ExtendedFormat "json"]+        u <- columnNamed "u" columns+        columnExtended u @?= [ExtendedTypeName "uuid"]+        a <- columnNamed "a" columns+        columnExtended a @?= [ExtendedTypeName "inet6"]+        p <- columnNamed "p" columns+        columnExtended p @?= [ExtendedTypeName "point"]+        s <- columnNamed "s" columns+        columnExtended s @?= []+        close (mysqlConnection conn)+    , testCase "text and binary queries read rows despite the metadata" $ do+        conn <- connectMariaDB [MariaDBExtendedMetadata] testConnectInfo+        let mysqlConn = mysqlConnection conn+        createTable mysqlConn+        (textColumns, textRows) <- query mysqlConn selectAll [MySQLInt32 1]+        map columnName textColumns @?= ["n", "j", "u", "a", "s"]+        textValues <- Stream.toList textRows+        textValues @?= [expectedRow]+        statement <- prepareStmt mysqlConn selectAll+        (binaryColumns, binaryRows) <- queryStmt mysqlConn statement [MySQLInt32 1]+        map columnType binaryColumns @?= map columnType textColumns+        binaryValues <- Stream.toList binaryRows+        binaryValues @?= [expectedRow]+        close mysqlConn+    ]+    ++ maybe [] (pure . unixSocketTest) socketPath+    ++ maybe [] (pure . tlsTest) caPath++-- | A temporary table keeps tests on separate connections apart.+jsonColumnMetadata :: MariaDBConn -> Assertion+jsonColumnMetadata conn = do+    _ <- execute_ (mysqlConnection conn) "CREATE TEMPORARY TABLE json_only (j JSON)"+    (_, _, columns) <- prepareStmtMetadata conn "SELECT j FROM json_only"+    map columnExtended columns @?= [[ExtendedFormat "json"]]++unixSocketTest :: FilePath -> TestTree+unixSocketTest path = testCase "negotiated over a Unix socket" $ do+    conn <- connectMariaDBUnixSocket [MariaDBExtendedMetadata] path testConnectInfo+    mariadbCapabilities conn @?= [MariaDBExtendedMetadata]+    jsonColumnMetadata conn+    close (mysqlConnection conn)++tlsTest :: FilePath -> TestTree+tlsTest caPath = testCase "negotiated over TLS, where the SSL request carries it" $ do+    cparams <- TLS.makeClientParams (TLS.CustomCAStore caPath)+    conn <- connectMariaDBTLS [MariaDBExtendedMetadata] testConnectInfo (cparams, "Winter")+    mariadbCapabilities conn @?= [MariaDBExtendedMetadata]+    (_, cipher) <- query_ (mysqlConnection conn) "SHOW STATUS LIKE 'Ssl_cipher'"+    cipherRows <- Stream.toList cipher+    assertBool "the connection is encrypted" (cipherRows /= [[MySQLText "Ssl_cipher", MySQLText ""]])+    jsonColumnMetadata conn+    close (mysqlConnection conn)

@@ -0,0 +1,92 @@+module MariaDBNegotiation (tests) where++import           Control.Concurrent     (threadDelay)+import           Control.Exception      (try)+import qualified Data.ByteString        as B+import           Data.List.NonEmpty     (NonEmpty ((:|)))+import           Database.MariaDB+import           Database.MySQL.Base+import qualified System.IO.Streams      as Stream+import           Test.Tasty+import           Test.Tasty.HUnit++testConnectInfo :: ConnectInfo+testConnectInfo = defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"}++-- | Runs on both servers, given the greeting of a plain connection: a MariaDB+-- server negotiates what it offers, and a MySQL server is refused.+tests :: Greeting -> TestTree+tests greeting = testGroup "MariaDB capability negotiation" $+    if offersExtendedCapabilities greeting then mariadbTests else mysqlTests++mariadbTests :: [TestTree]+mariadbTests =+    [ testCase "extended metadata is negotiated, and the MySQL functions work on it" $ do+        conn <- connectMariaDB [MariaDBExtendedMetadata] testConnectInfo+        mariadbCapabilities conn @?= [MariaDBExtendedMetadata]+        (_, rows) <- query_ (mysqlConnection conn) "SELECT 'probe'"+        values <- Stream.toList rows+        values @?= [[MySQLText "probe"]]+        close (mysqlConnection conn)+    , testCase "nothing asked, nothing negotiated" $ do+        conn <- connectMariaDB [] testConnectInfo+        mariadbCapabilities conn @?= []+        result <- try (prepareStmtMetadata conn "SELECT 1")+        case result of+            Left (CapabilityNotNegotiated MariaDBExtendedMetadata) -> pure ()+            Left (CapabilityNotNegotiated MariaDBBulkOperations) ->+                assertFailure "asked for the bulk capability instead of extended metadata"+            Right _ -> assertFailure "prepareStmtMetadata ran without extended metadata"+        close (mysqlConnection conn)+    , testCase "bulk execution with the capability" $ do+        conn <- connectMariaDB [MariaDBBulkOperations] testConnectInfo+        let mysqlConn = mysqlConnection conn+        _ <- execute_ mysqlConn "CREATE TEMPORARY TABLE bulk_negotiated (n INT)"+        statement <- prepareStmt mysqlConn "INSERT INTO bulk_negotiated VALUES (?)"+        ok <- executeBulk conn statement ([BulkValue (MySQLInt32 1)] :| [[BulkValue (MySQLInt32 2)]])+        okAffectedRows ok @?= 2+        close mysqlConn+    ]++mysqlTests :: [TestTree]+mysqlTests =+    [ testCase "connectMariaDB refuses a MySQL server and closes the connection" $ do+        admin <- connect testConnectInfo+        _ <- execute_ admin "CREATE USER IF NOT EXISTS 'mariadbRefusal'@'localhost' IDENTIFIED WITH mysql_native_password BY 'refusal'"+        observer <- connect refusalConnectInfo+        before <- refusalConnections observer+        result <- try (connectMariaDB [MariaDBExtendedMetadata] refusalConnectInfo)+        case result of+            Left (NotMariaDB version) ->+                assertBool ("refused with the server's version, got " ++ show version)+                    ("8." `B.isPrefixOf` version)+            Right conn -> do+                close (mysqlConnection conn)+                assertFailure "connected to a MySQL server"+        after <- settledRefusalConnections observer before (20 :: Int)+        after @?= before+        close observer+        _ <- execute_ admin "DROP USER 'mariadbRefusal'@'localhost'"+        close admin+    ]++-- | A user only this test connects as, so concurrent tests' connections do+-- not show up in its count.+refusalConnectInfo :: ConnectInfo+refusalConnectInfo = defaultConnectInfo {ciUser = "mariadbRefusal", ciPassword = "refusal", ciDatabase = ""}++-- | How many connections the server has open for 'refusalConnectInfo''s user.+-- A user sees its own threads in PROCESSLIST without the PROCESS privilege.+refusalConnections :: MySQLConn -> IO [[MySQLValue]]+refusalConnections conn = do+    (_, rows) <- query_ conn "SELECT COUNT(*) FROM information_schema.PROCESSLIST WHERE USER = 'mariadbRefusal'"+    Stream.toList rows++-- | The server ends a connection's thread shortly after COM_QUIT, so the count+-- may take a moment to drop back; poll for up to a second.+settledRefusalConnections :: MySQLConn -> [[MySQLValue]] -> Int -> IO [[MySQLValue]]+settledRefusalConnections conn expected attempts = do+    current <- refusalConnections conn+    if current == expected || attempts <= 0+        then pure current+        else threadDelay 50000 >> settledRefusalConnections conn expected (attempts - 1)

@@ -1,11 +1,12 @@ -- | 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+module MultipleResults (tests, rowTests) where  import           Control.Exception (try) import           Data.Int          (Int64) import           Database.MySQL.Base+import           QueryApi import qualified System.IO.Streams as Stream import           System.Timeout    (timeout) import           Test.Tasty@@ -13,12 +14,7 @@  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+    [ 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@@ -31,21 +27,77 @@         _ <- 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 "execute_ with a failing statement after a SELECT" $ withTable $ \c ->+        assertERRException c+            (execute_ c "SELECT COUNT(*) FROM several_results; SELECT * FROM no_such_table")+    , testCase "queryMulti_ with an INSERT and two SELECTs" $ withTable $ \c -> do+        results <- queryMulti_ c+            "INSERT INTO several_results VALUES (1); SELECT COUNT(*) FROM several_results; \+            \SELECT __id FROM several_results"+        assertEqual "every result, in order"+            [Left 1, Right [[MySQLInt64 1]], Right [[MySQLInt32 1]]]+            (map resultShape results)+        assertRowCount c 1+    , testCase "queryMulti_ with a CALL returning two result sets" $ withTable $ \c -> do+        _ <- execute_ c "DROP PROCEDURE IF EXISTS two_result_sets"+        _ <- execute_ c+            "CREATE PROCEDURE two_result_sets() BEGIN \+            \SELECT COUNT(*) FROM several_results; SELECT COUNT(*) + 1 FROM several_results; END"+        results <- queryMulti_ c "CALL two_result_sets()"+        assertEqual "both result sets, then the CALL's OK"+            [Right [[MySQLInt64 0]], Right [[MySQLInt64 1]], Left 0]+            (map resultShape results)+        assertRowCount c 0+    , testCase "queryMulti with a parameter" $ withTable $ \c -> do+        results <- queryMulti c+            "INSERT INTO several_results VALUES (?); SELECT __id FROM several_results"+            [MySQLInt32 7]+        assertEqual "every result, in order"+            [Left 1, Right [[MySQLInt32 7]]]+            (map resultShape results)+    , testCase "queryMulti_ with a failing statement after a SELECT" $ withTable $ \c ->+        assertERRException c+            (queryMulti_ c "SELECT COUNT(*) FROM several_results; SELECT * FROM no_such_table")+    , testCase "executeMany_ with a SELECT after a DO" $ withTable $ \c ->+        assertExtraResultSets c (executeMany_ c "DO 1; SELECT COUNT(*) FROM several_results")+    , testCase "executeMany with a SELECT" $ withTable $ \c ->+        assertExtraResultSets c+            (executeMany c "SELECT COUNT(*) + ? FROM several_results" [[MySQLInt32 1]])+    , testCase "executeMany with two statements per parameter set" $ withTable $ \c -> do+        oks <- executeMany c+            "INSERT INTO several_results VALUES (?); INSERT INTO several_results VALUES (?)"+            [[MySQLInt32 1, MySQLInt32 2], [MySQLInt32 3, MySQLInt32 4]]+        assertEqual "one OK per statement" [1, 1, 1, 1] (map okAffectedRows oks)+        assertRowCount c 4+    , testCase "executeMany with no parameter sets" $ withTable $ \c -> do+        oks <- executeMany c "INSERT INTO several_results VALUES (?)" ([] :: [[MySQLValue]])+        assertEqual "no OKs" [] (map okAffectedRows oks)+        assertRowCount c 0+    ]++-- | The cases that read rows, run for each API in "QueryApi".+rowTests :: QueryApi -> TestTree+rowTests api = testGroup "statements with several results, read as rows"+    [ testCase "query_ with two INSERTs" $ withTable $ \c -> do+        (_, rows) <- apiQuery_ api (ColumnCount 0) c+            "INSERT INTO several_results VALUES (1); INSERT INTO several_results VALUES (2)"+        Stream.skipToEof rows+        assertRowCount c 2     , 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()"+        (_, rows) <- apiQuery_ api (ColumnCount 1) 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+        (_, rows) <- apiQuery_ api (ColumnCount 1) 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+        (_, rows) <- apiQuery_ api (ColumnCount 1) c             "SELECT COUNT(*) FROM several_results; SELECT COUNT(*) FROM several_results"         outcome <- try (Stream.toList rows)         case outcome of@@ -55,14 +107,17 @@         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+        (_, rows) <- apiQuery_ api (ColumnCount 1) 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")     ] +-- | The affected rows of an 'OK', or the rows of a result set.+resultShape :: StatementResult -> Either Int [[MySQLValue]]+resultShape result = case result of+    StatementOK ok -> Left (okAffectedRows ok)+    StatementRows _ rows -> Right rows+ -- | 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@@ -82,7 +137,7 @@         Just () -> close c  -- | The statement must raise 'ExtraResultSets' and leave the connection in step.-assertExtraResultSets :: MySQLConn -> IO OK -> Assertion+assertExtraResultSets :: MySQLConn -> IO a -> Assertion assertExtraResultSets c runStatement = do     outcome <- try runStatement     case outcome of

@@ -18,6 +18,7 @@ import           Test.Tasty.HUnit import qualified TextRow import qualified ExecuteMany+import           QueryApi import qualified TextRowNew  tests :: TestTree@@ -77,15 +78,16 @@      resetTestTable c -    step "testing text protocol"-    TextRow.tests c+    forM_ queryApis $ \api -> do+        step ("testing text protocol through the " ++ apiName api)+        TextRow.tests api c -    resetTestTable c+        resetTestTable c -    step "testing binary protocol"-    BinaryRow.tests c+        step ("testing binary protocol through the " ++ apiName api)+        BinaryRow.tests api c -    resetTestTable c+        resetTestTable c       when isNew $ do@@ -96,15 +98,16 @@                    \__time         TIME(6)\                    \) CHARACTER SET utf8" -        resetTest57Table c+        forM_ queryApis $ \api -> do+            resetTest57Table c -        step "testing MySQL5.7 extra text protocol"-        TextRowNew.tests c+            step ("testing MySQL5.7 extra text protocol through the " ++ apiName api)+            TextRowNew.tests api c -        resetTest57Table c+            resetTest57Table c -        step "testing MySQL5.7 extra binary protocol"-        BinaryRowNew.tests c+            step ("testing MySQL5.7 extra binary protocol through the " ++ apiName api)+            BinaryRowNew.tests api c          void $ resetTest57Table c 

@@ -0,0 +1,36 @@+-- | Telling replies apart by their first byte. A row can start with the EOF+-- marker, and an empty packet has no first byte at all.+module PacketClassification (tests) where++import           Control.Exception              (SomeException, evaluate, try)+import qualified Data.ByteString.Lazy           as L+import           Database.MySQL.Protocol.Packet+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "packet classification"+    [ testCase "a row whose first value is 16 MiB or longer is not EOF" $ do+        -- 0xFE then the 8-byte length 16777216, then the value's first bytes.+        assertBool "row taken for EOF" (not (isEOF (packet ("\xFE\x00\x00\x00\x01\x00\x00\x00\x00" <> "abc"))))+        assertBool "EOF packet not recognised" (isEOF (packet "\xFE\x00\x00\x02\x00"))+    , testCase "an empty packet is neither OK, ERR nor EOF" $ do+        classified <- try (evaluate (isOK empty || isERR empty || isEOF empty))+        case classified of+            Left (failure :: SomeException) -> assertFailure ("classifying crashed: " <> show failure)+            Right anyMatch -> assertBool "empty packet classified" (not anyMatch)+    , testCase "an OK packet keeps an insert ID above Int's range" $ do+        ok <- decodeFromPacket (packet ("\x00\x01\xFE" <> "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF" <> "\x02\x00\x00\x00")) :: IO OK+        assertEqual "last insert ID" (18446744073709551615 :: Integer) (toInteger (okLastInsertID ok))+    , testCase "an OK packet with affected rows above Int's range fails to decode" $ do+        decoded <- try (decodeFromPacket (packet ("\x00\xFE" <> "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF" <> "\x00\x02\x00\x00\x00")) :: IO OK)+        case decoded of+            Left (DecodePacketFailed _ _ _) -> pure ()+            Right ok -> assertFailure ("decoded as " <> show ok)+    ]++packet :: L.ByteString -> Packet+packet body = Packet (L.length body) 1 body++empty :: Packet+empty = packet ""

@@ -0,0 +1,18 @@+-- | A question mark inside a string literal or a comment sent to the server+-- through 'query', where it used to count as a placeholder.+module PlaceholderLiterals (tests) where++import           Database.MySQL.Base+import           QueryApi+import qualified System.IO.Streams   as Stream+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUser            (withTestConnection)++tests :: QueryApi -> TestTree+tests api = testCase "a question mark in a literal or comment is not a placeholder" $+    withTestConnection $ \c -> do+        (_, rows) <- apiQuery api (ColumnCount 2) c "SELECT ?, '?' -- is this a placeholder?\n"+            [One (MySQLText "filled")]+        result <- Stream.toList rows+        assertEqual "rows" [[MySQLText "filled", MySQLText "?"]] result

@@ -0,0 +1,38 @@+-- | Which question marks 'renderParams' fills: not those inside quotes or+-- comments, which used to count as placeholders.+module Placeholders (tests) where++import           Control.Exception              (evaluate, try)+import qualified Data.ByteString.Lazy           as L+import           Database.MySQL.Base+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "placeholders"+    [ renders "single-quoted string" "SELECT '?', ?" [one] "SELECT '?', 1"+    , renders "double-quoted string and quoted identifier"+        "SELECT \"?\", `a?b`, ?" [one] "SELECT \"?\", `a?b`, 1"+    , renders "doubled and escaped quotes stay inside the string"+        "SELECT 'it''s ?', 'C\\'s ?', ?" [one] "SELECT 'it''s ?', 'C\\'s ?', 1"+    , renders "a backslash does not escape in a quoted identifier"+        "SELECT `a\\`, ?, '?'" [one] "SELECT `a\\`, 1, '?'"+    , renders "dash comment" "SELECT ? -- why?\n, ?" [one, two] "SELECT 1 -- why?\n, 2"+    , renders "hash comment" "SELECT ? # why?\n, ?" [one, two] "SELECT 1 # why?\n, 2"+    , renders "block comment" "SELECT /* ? */ ?" [one] "SELECT /* ? */ 1"+    , renders "two dashes without a space are arithmetic" "SELECT ?--?, '?'" [one, two] "SELECT 1--2, '?'"+    , renders "an executable comment is SQL" "SELECT /*! ? */ '?'" [one] "SELECT /*! 1 */ '?'"+    , testCase "more parameters than placeholders outside quotes" $ do+        rendered <- try (evaluate (L.length (fromQuery (renderParams "SELECT ?, '?'" [one, two]))))+        case rendered of+            Left WrongParamsCount -> pure ()+            Right _ -> assertFailure "rendered the second parameter into the string literal"+    ]++renders :: TestName -> Query -> [MySQLValue] -> L.ByteString -> TestTree+renders name sql params expected = testCase name $+    assertEqual "rendered SQL" expected (fromQuery (renderParams sql params))++one, two :: MySQLValue+one = MySQLInt32 1+two = MySQLInt32 2

@@ -0,0 +1,136 @@+-- | The calls the integration tests read rows with. Every suite that reads+-- rows takes a 'QueryApi' and runs once for each of 'queryApis', so the old+-- 'MySQLValue' functions and each path of "Database.MySQL.Decoder" go through+-- the very same cases, and a test differs between them only in the API.+module QueryApi+    ( QueryApi (..)+    , ColumnCount (..)+    , queryApis+    , mysqlValueApis+    ) where++import           Control.Exception                  (throwIO)+import           Control.Monad                      (replicateM)+import qualified Data.Vector                        as V+import           Database.MySQL.Base+import qualified Database.MySQL.Decoder             as Decode+import           System.IO.Streams                  (InputStream)+import           TypedValue                         (typedDecoder)+import qualified System.IO.Streams                  as Stream++-- | How many columns a query returns. Only the 'Decode.RowDecoder' path uses+-- it: a row decoder states its columns before the query runs, where the other+-- paths learn them from the result set.+newtype ColumnCount = ColumnCount Int++data QueryApi = QueryApi+    { apiName            :: String+    , apiQuery_          :: ColumnCount -> MySQLConn -> Query+                         -> IO ([ColumnDef], InputStream [MySQLValue])+    , apiQuery           :: ColumnCount -> MySQLConn -> Query -> [Param]+                         -> IO ([ColumnDef], InputStream [MySQLValue])+    , apiQueryVector_    :: ColumnCount -> MySQLConn -> Query+                         -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue))+    , apiQueryStmt       :: ColumnCount -> MySQLConn -> StmtID -> [MySQLValue]+                         -> IO ([ColumnDef], InputStream [MySQLValue])+    , apiQueryStmtVector :: ColumnCount -> MySQLConn -> StmtID -> [MySQLValue]+                         -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue))+    }++queryApis :: [QueryApi]+queryApis = mysqlValueApis ++ [typedRawRowApi]++-- | The APIs that give every field as the 'MySQLValue' the old API does, also+-- the dates a 'Data.Time.Calendar.Day' cannot hold.+mysqlValueApis :: [QueryApi]+mysqlValueApis = [valueApi, rowDecoderApi, rawRowApi]++-- | The API the tests were written for.+valueApi :: QueryApi+valueApi = QueryApi+    { apiName            = "MySQLValue API"+    , apiQuery_          = const query_+    , apiQuery           = const query+    , apiQueryVector_    = const queryVector_+    , apiQueryStmt       = const queryStmt+    , apiQueryStmtVector = const queryStmtVector+    }++-- | 'queryRows_', 'queryRows' and 'queryStmtRows' with 'Decode.mysqlValue' for+-- every column.+rowDecoderApi :: QueryApi+rowDecoderApi = QueryApi+    { apiName            = "RowDecoder API"+    , apiQuery_          = queryRows_ . everyColumn+    , apiQuery           = queryRows . everyColumn+    , apiQueryVector_    = rowDecoderQueryVector_+    , apiQueryStmt       = queryStmtRows . everyColumn+    , apiQueryStmtVector = rowDecoderQueryStmtVector+    }++everyColumn :: ColumnCount -> Decode.RowDecoder [MySQLValue]+everyColumn (ColumnCount count) = replicateM count (Decode.field Decode.mysqlValue)++rowDecoderQueryVector_ :: ColumnCount -> MySQLConn -> Query+                       -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue))+rowDecoderQueryVector_ count conn qry = toVectors =<< queryRows_ (everyColumn count) conn qry++rowDecoderQueryStmtVector :: ColumnCount -> MySQLConn -> StmtID -> [MySQLValue]+                          -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue))+rowDecoderQueryStmtVector count conn stmt params =+    toVectors =<< queryStmtRows (everyColumn count) conn stmt params++-- | 'queryRawRows_' and 'queryStmtRawRows', each column read by its number with+-- 'Decode.mysqlValue', as a library decoding by column number would.+rawRowApi :: QueryApi+rawRowApi = rawRowApiWith "RawRow API" valueDecoder++-- | 'queryRawRows_' and 'queryStmtRawRows', each column read with the typed+-- decoder for its type, the value put back into the 'MySQLValue' constructor+-- the old API returns, so the same expectations hold.+typedRawRowApi :: QueryApi+typedRawRowApi = rawRowApiWith "typed decoders" typedDecoder++rawRowApiWith :: String -> (ColumnKind -> Decode.FieldDecoder MySQLValue) -> QueryApi+rawRowApiWith name decoderFor = QueryApi+    { apiName            = name+    , apiQuery_          = \_ conn qry -> rawValues decoderFor =<< queryRawRows_ conn qry+    , apiQuery           = \_ conn qry params ->+        rawValues decoderFor =<< queryRawRows_ conn (renderParams qry params)+    , apiQueryVector_    = \_ conn qry -> toVectors =<< rawValues decoderFor =<< queryRawRows_ conn qry+    , apiQueryStmt       = \_ conn stmt params -> rawValues decoderFor =<< queryStmtRawRows conn stmt params+    , apiQueryStmtVector = \_ conn stmt params ->+        toVectors =<< rawValues decoderFor =<< queryStmtRawRows conn stmt params+    }++valueDecoder :: ColumnKind -> Decode.FieldDecoder MySQLValue+valueDecoder _ = Decode.mysqlValue++-- | Each raw row as the list of its columns' values, every column with the+-- parser 'prepareColumn' picks for it.+rawValues :: Decode.RowProtocol protocol+          => (ColumnKind -> Decode.FieldDecoder MySQLValue)+          -> ([ColumnDef], InputStream (Decode.RawRow protocol))+          -> IO ([ColumnDef], InputStream [MySQLValue])+rawValues decoderFor (columns, rows) = do+    parsers <- either throwIO pure+        (traverse (prepareColumn decoderFor) (zip (map Decode.ColumnNumber [0 ..]) columns))+    (,) columns <$> Stream.mapM (rowValues parsers) rows++prepareColumn :: Decode.RowProtocol protocol+              => (ColumnKind -> Decode.FieldDecoder MySQLValue) -> (Decode.ColumnNumber, ColumnDef)+              -> Either Decode.ColumnMismatch (Decode.ColumnNumber, Decode.FieldParser protocol MySQLValue)+prepareColumn decoderFor (column, definition) =+    (,) column <$> Decode.prepareFieldParser (decoderFor (columnKind definition)) column definition++rowValues :: [(Decode.ColumnNumber, Decode.FieldParser protocol MySQLValue)] -> Decode.RawRow protocol+          -> IO [MySQLValue]+rowValues parsers row = traverse (fieldValue row) parsers++fieldValue :: Decode.RawRow protocol -> (Decode.ColumnNumber, Decode.FieldParser protocol MySQLValue)+           -> IO MySQLValue+fieldValue row (column, parser) = Decode.runFieldParser parser row column throwIO pure++toVectors :: ([ColumnDef], InputStream [MySQLValue])+          -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue))+toVectors (columns, rows) = (,) (V.fromList columns) <$> Stream.map V.fromList rows

@@ -5,33 +5,38 @@ module QueryWithoutResultSet (tests) where  import           Database.MySQL.Base+import           QueryApi 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"+tests :: QueryApi -> TestTree+tests api = testGroup "query functions given an INSERT"     [ testCase "query_" $ assertEmptyResultSet $ \c -> do-        (columns, rows) <- query_ c "INSERT INTO without_result_set VALUES (1)"+        (columns, rows) <- apiQuery_ api noColumns 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)"+        (columns, rows) <- apiQueryVector_ api noColumns 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]+        (columns, rows) <- apiQueryStmt api noColumns 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]+        (columns, rows) <- apiQueryStmtVector api noColumns c stmt [MySQLInt32 1]         rowList <- Stream.toList rows         pure (V.length columns, length rowList)     ]++-- | An INSERT has no result set, so a row decoder for it reads no columns.+noColumns :: ColumnCount+noColumns = ColumnCount 0  -- | Generous for one INSERT into an empty temporary table, and short enough -- that a hang fails the suite instead of stalling CI.

@@ -0,0 +1,46 @@+-- | String columns in the character set the server sent them in. latin1 bytes+-- used to go through a UTF-8 decoder that threw an impure exception.+module ResultCharsets (tests) where++import           Control.Exception              (SomeException, evaluate, try)+import           Data.Binary.Parser             (parseOnly)+import           Data.Binary.Put                (runPut)+import qualified Data.ByteString                as B+import qualified Data.ByteString.Lazy           as L+import           Data.Word                      (Word16)+import           Database.MySQL.Protocol.ColumnDef+import           Database.MySQL.Protocol.MySQLValue+import           Database.MySQL.Protocol.Packet  (putLenEncBytes)+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "result character sets"+    [ testCase "latin1 (collation 8) is Windows-1252" $+        assertEqual "value" (Right (MySQLText "\x20AC\x00E9\x0081"))+            (parseOnly (getTextField (varchar latin1SwedishCi)) (lenEnc "\x80\xE9\x81"))+    , testCase "another charset decodes ASCII and fails to parse other bytes" $ do+        assertEqual "ASCII value" (Right (MySQLText "abc"))+            (parseOnly (getBinaryField (varchar gbkChineseCi)) (lenEnc "abc"))+        parsed <- try (evaluate (forced (parseOnly (getTextField (varchar gbkChineseCi)) (lenEnc "\xC4\xE3"))))+        case parsed of+            Right (Left _) -> pure ()+            Right (Right value) -> assertFailure ("decoded as " <> show value)+            Left (failure :: SomeException) -> assertFailure ("threw instead of failing the parse: " <> show failure)+    ]++-- | The value itself evaluated, so a decoder that throws does so here.+forced :: Either String MySQLValue -> Either String MySQLValue+forced parsed = case parsed of+    Left failure -> Left failure+    Right value -> value `seq` Right value++latin1SwedishCi, gbkChineseCi :: Word16+latin1SwedishCi = 8+gbkChineseCi = 28++varchar :: Word16 -> ColumnDef+varchar charset = ColumnDef "" "" "" "c" "c" charset 0 mySQLTypeVarString 0 0++lenEnc :: B.ByteString -> B.ByteString+lenEnc value = L.toStrict (runPut (putLenEncBytes value))

@@ -1,12 +1,13 @@ module RoundtripBit (tests) where  import Database.MySQL.Base+import QueryApi import qualified System.IO.Streams as Stream import Test.Tasty import Test.Tasty.HUnit -tests :: TestTree-tests = testCaseSteps "roundtrip MySQLBit" $ \step -> do+tests :: QueryApi -> TestTree+tests api = testCaseSteps "roundtrip MySQLBit" $ \step -> do     (_, c) <- connectDetail defaultConnectInfo         { ciUser = "testMySQLHaskell"         , ciDatabase = "testMySQLHaskell"@@ -22,7 +23,7 @@     let bitVal = 43744 -- 0b1010101011100000     executeStmt c updStmt [MySQLBit bitVal] -    (_, is) <- queryStmt c selStmt []+    (_, is) <- apiQueryStmt api (ColumnCount 1) c selStmt []     Just [v] <- Stream.read is     Stream.skipToEof is     assertEqual "MySQLBit roundtrips through BIT(16)" (MySQLBit bitVal) v@@ -30,7 +31,7 @@     step "roundtrip MySQLBit zero"     executeStmt c updStmt [MySQLBit 0] -    (_, is2) <- queryStmt c selStmt []+    (_, is2) <- apiQueryStmt api (ColumnCount 1) c selStmt []     Just [v2] <- Stream.read is2     Stream.skipToEof is2     assertEqual "MySQLBit 0 roundtrips" (MySQLBit 0) v2@@ -38,7 +39,7 @@     step "roundtrip MySQLBit max for BIT(16)"     executeStmt c updStmt [MySQLBit 65535] -    (_, is3) <- queryStmt c selStmt []+    (_, is3) <- apiQueryStmt api (ColumnCount 1) c selStmt []     Just [v3] <- Stream.read is3     Stream.skipToEof is3     assertEqual "MySQLBit 65535 roundtrips" (MySQLBit 65535) v3

@@ -1,12 +1,13 @@ module RoundtripYear (tests) where  import Database.MySQL.Base+import QueryApi import qualified System.IO.Streams as Stream import Test.Tasty import Test.Tasty.HUnit -tests :: TestTree-tests = testCaseSteps "roundtrip MySQLYear" $ \step -> do+tests :: QueryApi -> TestTree+tests api = testCaseSteps "roundtrip MySQLYear" $ \step -> do     (_, c) <- connectDetail defaultConnectInfo         { ciUser = "testMySQLHaskell"         , ciDatabase = "testMySQLHaskell"@@ -21,7 +22,7 @@      executeStmt c updStmt [MySQLYear 1999] -    (_, is) <- queryStmt c selStmt []+    (_, is) <- apiQueryStmt api (ColumnCount 1) c selStmt []     Just [v] <- Stream.read is     Stream.skipToEof is     assertEqual "MySQLYear 1999 roundtrips" (MySQLYear 1999) v@@ -29,7 +30,7 @@     step "roundtrip MySQLYear min (1901)"     executeStmt c updStmt [MySQLYear 1901] -    (_, is2) <- queryStmt c selStmt []+    (_, is2) <- apiQueryStmt api (ColumnCount 1) c selStmt []     Just [v2] <- Stream.read is2     Stream.skipToEof is2     assertEqual "MySQLYear 1901 roundtrips" (MySQLYear 1901) v2@@ -37,7 +38,7 @@     step "roundtrip MySQLYear max (2155)"     executeStmt c updStmt [MySQLYear 2155] -    (_, is3) <- queryStmt c selStmt []+    (_, is3) <- apiQueryStmt api (ColumnCount 1) c selStmt []     Just [v3] <- Stream.read is3     Stream.skipToEof is3     assertEqual "MySQLYear 2155 roundtrips" (MySQLYear 2155) v3@@ -45,7 +46,7 @@     step "roundtrip MySQLYear zero"     executeStmt c updStmt [MySQLYear 0] -    (_, is4) <- queryStmt c selStmt []+    (_, is4) <- apiQueryStmt api (ColumnCount 1) c selStmt []     Just [v4] <- Stream.read is4     Stream.skipToEof is4     assertEqual "MySQLYear 0 roundtrips" (MySQLYear 0) v4

@@ -0,0 +1,144 @@+-- | 'queryRows_', 'queryStmtRows' and 'queryRawRows_' against a server. The+-- typed decoders must give what 'query_' and 'queryStmt' give through+-- "Database.MySQL.Field", and a result set a decoder does not fit, or a field+-- it cannot decode, must leave the connection usable.+module RowDecoderQueries (tests) where++import           Control.Exception      (try)+import           Data.Int               (Int32)+import           Data.Scientific        (Scientific)+import           Data.Text              (Text)+import           Data.Time.Calendar     (Day, fromGregorian)+import           Data.Time.LocalTime    (LocalTime (..), TimeOfDay (..))+import           Database.MySQL.Base+import qualified Database.MySQL.Decoder as Decode+import           Database.MySQL.Field+import qualified System.IO.Streams      as Stream+import           System.Timeout         (timeout)+import           Test.Tasty+import           Test.Tasty.HUnit++type Row = (Int32, Text, Day, LocalTime, Double, Scientific, Maybe Int32, Bool, TimeOfDay)++rowDecoder :: Decode.RowDecoder Row+rowDecoder = (,,,,,,,,)+    <$> Decode.field Decode.int32+    <*> Decode.field Decode.text+    <*> Decode.field Decode.day+    <*> Decode.field Decode.localTime+    <*> Decode.field Decode.double+    <*> Decode.field Decode.scientific+    <*> Decode.field (Decode.nullable Decode.int32)+    <*> Decode.field Decode.bool+    <*> Decode.field Decode.timeOfDay++expectedRows :: [Row]+expectedRows =+    [ ( 1, "Jappie", fromGregorian 1990 1 2+      , LocalTime (fromGregorian 2026 10 8) (TimeOfDay 12 34 56.789012)+      , 0.25, 12.5, Nothing, True, TimeOfDay 12 0 1 )+    , ( 2, "café", fromGregorian 2000 2 29+      , LocalTime (fromGregorian 2000 2 29) (TimeOfDay 23 59 59.000001)+      , -1.5, -3.25, Just 7, False, TimeOfDay 838 59 59 )+    ]++-- | The same row through 'MySQLValue' and "Database.MySQL.Field".+viaField :: [MySQLValue] -> Either String Row+viaField values = case values of+    [number, name, born, created, ratio, amount, count, flag, duration] ->+        either (Left . show) Right $ (,,,,,,,,)+            <$> decodeInt32 number+            <*> decodeText name+            <*> decodeDay born+            <*> decodeLocalTime created+            <*> decodeDouble ratio+            <*> decodeScientific amount+            <*> decodeMaybe count+            <*> decodeBool flag+            <*> decodeTimeOfDay duration+    _ -> Left ("expected 9 values, got " ++ show values)++tests :: TestTree+tests = testGroup "decoding rows without MySQLValue"+    [ testCase "queryRows_ gives what query_ and Field give" $ withRows $ \c -> do+        (_, rows) <- queryRows_ rowDecoder c "SELECT * FROM decoded_rows ORDER BY id"+        decoded <- Stream.toList rows+        (_, values) <- query_ c "SELECT * FROM decoded_rows ORDER BY id"+        throughField <- Stream.toList values+        decoded @?= expectedRows+        traverse viaField throughField @?= Right expectedRows+    , testCase "queryStmtRows gives what queryStmt and Field give" $ withRows $ \c -> do+        stmt <- prepareStmt c "SELECT * FROM decoded_rows WHERE id >= ? ORDER BY id"+        (_, rows) <- queryStmtRows rowDecoder c stmt [MySQLInt32 0]+        decoded <- Stream.toList rows+        (_, values) <- queryStmt c stmt [MySQLInt32 0]+        throughField <- Stream.toList values+        decoded @?= expectedRows+        traverse viaField throughField @?= Right expectedRows+    , testCase "queryRawRows_ rows decode by column number" $ withRows $ \c -> do+        (columns, rows) <- queryRawRows_ c "SELECT id, name FROM decoded_rows ORDER BY id"+        parser <- either (assertFailure . show) pure+            (Decode.prepareFieldParser Decode.text (Decode.ColumnNumber 1) (columns !! 1))+        names <- Stream.toList =<< Stream.mapM+            (\row -> Decode.runFieldParser parser row (Decode.ColumnNumber 1) (assertFailure . show) pure) rows+        names @?= ["Jappie", "café"]+    , testCase "a column the decoder does not take raises before any row" $ withRows $ \c -> do+        outcome <- try (queryRows_ (Decode.field Decode.text) c "SELECT id FROM decoded_rows")+        case outcome of+            Left mismatch -> mismatch @?= Decode.ColumnTypeMismatch (Decode.ColumnNumber 0) "id" mySQLTypeLong "Text"+            Right _       -> assertFailure "the INT column was accepted as Text"+        assertRowCount c+    , testCase "a decoder for another number of columns raises before any row" $ withRows $ \c -> do+        stmt <- prepareStmt c "SELECT id, name FROM decoded_rows"+        outcome <- try (queryStmtRows (Decode.field Decode.int32) c stmt [])+        case outcome of+            Left mismatch -> mismatch @?= Decode.ColumnCountMismatch 1 2+            Right _       -> assertFailure "a 2-column result set fit a 1-column decoder"+        assertRowCount c+    , testCase "a field that does not decode raises and skips the other rows" $ withRows $ \c -> do+        (_, rows) <- queryRows_ (Decode.field Decode.int32) c+            "SELECT maybe_count FROM decoded_rows ORDER BY id"+        outcome <- try (Stream.toList rows)+        case outcome of+            Left fieldError -> fieldError @?= Decode.FieldError (Decode.ColumnNumber 0) Decode.FieldUnexpectedNull+            Right counts    -> assertFailure ("the NULL decoded: " ++ show counts)+        assertRowCount c+    , testCase "an INSERT gives no columns and no rows" $ withRows $ \c -> do+        (columns, rows) <- queryRows_ rowDecoder c+            "INSERT INTO decoded_rows (id, name, born, created, ratio, amount, flag, duration) \+            \VALUES (3, 'x', '2001-01-01', '2001-01-01', 0, 0, 0, '00:00:00')"+        decoded <- Stream.toList rows+        (length columns, length decoded) @?= (0, 0)+    ]++-- | Generous for a few statements on a two-row temporary table, and short+-- enough that a hang fails the suite instead of stalling CI.+replyTimeLimitMicroseconds :: Int+replyTimeLimitMicroseconds = 10000000++withRows :: (MySQLConn -> Assertion) -> Assertion+withRows body = do+    (_, c) <- connectDetail defaultConnectInfo+        { ciUser = "testMySQLHaskell"+        , ciDatabase = "testMySQLHaskell"+        }+    _ <- execute_ c+        "CREATE TEMPORARY TABLE decoded_rows (\+        \id INT, name VARCHAR(20), born DATE, created DATETIME(6), ratio DOUBLE, \+        \amount DECIMAL(10, 2), maybe_count INT NULL, flag TINYINT(1), duration TIME\+        \) CHARACTER SET utf8mb4"+    _ <- execute_ c+        "INSERT INTO decoded_rows VALUES \+        \(1, 'Jappie', '1990-01-02', '2026-10-08 12:34:56.789012', 0.25, 12.50, NULL, 1, '12:00:01'), \+        \(2, 'café', '2000-02-29', '2000-02-29 23:59:59.000001', -1.5, -3.25, 7, 0, '838:59:59')"+    finished <- timeout replyTimeLimitMicroseconds (body c)+    case finished of+        Nothing -> assertFailure "blocked for 10 s waiting for a reply"+        Just () -> close c++-- | The connection must be back in step: a fresh query gets its own rows.+assertRowCount :: MySQLConn -> Assertion+assertRowCount c = do+    (_, rows) <- query_ c "SELECT COUNT(*) FROM decoded_rows"+    counts <- Stream.toList rows+    assertEqual "rows of the next query" [[MySQLInt64 2]] counts