mysql-haskell 1.4.0 → 1.4.1

raw patch · 10 files changed

+180/−33 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +17/−1
• mysql-haskell.cabal +2/−1
• src/Database/MySQL/Decoder.hs +5/−0
• src/Database/MySQL/Protocol/MySQLValue.hs +60/−14
• test/DirectDecoding.hs +6/−1
• test/Integration.hs +2/−0
• test/NonUtf8Results.hs +47/−0
• test/ResultCharsets.hs +19/−14
• test/TextRowDecoding.hs +3/−1
• test/ZeroDates.hs +19/−1

@@ -1,5 +1,20 @@ # Revision history for mysql-haskell +## 1.4.1 -- 2026.11.11++Faster decoding. No type changes beyond one new exception, but one change of+behaviour, described last. `query_` and+`queryStmt` decode rows with dates and text up to a third faster than 1.4.0:+a date in a common range is computed without `Integer` arithmetic, and a+string is decoded as UTF-8 once, when its value is used, instead of checked+while the row is read and decoded again later. A string whose bytes are not+UTF-8, as a connection in another charset can send, now raises+`InvalidUtf8Text` when the value is used, where 1.4.0 refused the whole row;+the decoders of `Database.MySQL.Decoder` still refuse it while reading.++* Text decoded when used, common dates without `Integer` arithmetic+  [#107](https://github.com/winterland1989/mysql-haskell/pull/107)+ ## 1.4.0 -- 2026.11.11  Fixes for MySQL and MariaDB alike, found comparing mysql-haskell with the@@ -41,7 +56,8 @@ 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.+0.11.2; projects on older compilers keep resolving to 1.3.2, the last release+before this on Hackage (1.3.3 was never uploaded).  * Fix eight defects for MySQL and MariaDB, each with a reproducer   [#102](https://github.com/winterland1989/mysql-haskell/pull/102)

@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               mysql-haskell-version:            1.4.0+version:            1.4.1 synopsis:           pure haskell MySQL driver description:        pure haskell MySQL driver. license:            BSD-3-Clause@@ -217,6 +217,7 @@     MariaDBNegotiation     MultipleResults     MysqlTests+    NonUtf8Results     PlaceholderLiterals     QueryApi     QueryWithoutResultSet

@@ -340,6 +340,11 @@ textMySQLValue :: ColumnKind -> ParseBytes MySQLValue textMySQLValue column fieldBytes = case column of     NullColumn -> (# | MySQLNull #)+    -- 'decodeTextValue' leaves a string's UTF-8 to be checked when the value is+    -- used; a decoder checks while it reads the row, see the module header.+    ValueColumn _ (KindText _) -> case utf8Field fieldBytes of+        (# fieldError | #) -> (# fieldError | #)+        (# | decoded #)    -> (# | MySQLText decoded #)     ValueColumn fieldType kind -> case decodeTextValue fieldType kind fieldBytes of         Left fieldError -> (# textFieldErrorKind fieldError | #)         Right value     -> (# | value #)

@@ -35,6 +35,7 @@   , RowError(..)   , RowErrorKind(..)   , TextFieldError(..)+  , InvalidUtf8Text(..)   , describeRowError   , getBinaryField   , putBinaryField@@ -62,6 +63,7 @@   ) where  import qualified Blaze.Text                         as Textual+import           Control.Exception                  (Exception (displayException), throw) import           Control.Monad import           Data.Binary.Put import           Data.Binary.Parser@@ -81,7 +83,8 @@ import           Data.Scientific                    (Scientific) import           Data.Text                          (Text) import qualified Data.Text.Encoding                 as T-import           Data.Time.Calendar                 (Day, fromGregorianValid,+import           Data.Time.Calendar                 (Day (ModifiedJulianDay),+                                                     fromGregorianValid,                                                      toGregorian) import           Data.Time.Format                   (defaultTimeLocale,                                                      formatTime)@@ -171,9 +174,31 @@ -- | 'Right' when a 'Day' can hold the date. calendarDate :: RawDate -> Either RawDate Day calendarDate raw@(RawDate year month day) =-    maybe (Left raw) Right+    -- Every month has 28 days, so these dates exist in every year and need no+    -- check; only the rest go through 'fromGregorianValid', whose Integer+    -- arithmetic took about a quarter of the instructions on date-heavy rows+    -- (docs/direct-row-decoding.md, 1.4.1).+    if month >= 1 && month <= 12 && day >= 1 && day <= 28+    then Right (dayOfCommonDate (Word16.toInt year) (Word8.toInt month) (Word8.toInt day))+    else maybe (Left raw) Right         (fromGregorianValid (Word16.toInteger year) (Word8.toInt month) (Word8.toInt day)) +-- | The 'Day' of a date that exists, computed in 'Int': Howard Hinnant's+-- days_from_civil (http://howardhinnant.github.io/date_algorithms.html),+-- counted from the Modified Julian Day epoch, 1858-11-17. The year counts from+-- March, so that February's leap day falls at its end.+dayOfCommonDate :: Int -> Int -> Int -> Day+dayOfCommonDate year month day =+    let marchYear = if month <= 2 then year - 1 else year+        era = marchYear `div` 400+        yearOfEra = marchYear - era * 400+        dayOfEra = yearOfEra * 365 + yearOfEra `div` 4 - yearOfEra `div` 100 + marchDayOfYear month day+    in ModifiedJulianDay (Int.toInteger (era * 146097 + dayOfEra - 678881))++-- | The day's number in a year that starts on 1 March, from 0.+marchDayOfYear :: Int -> Int -> Int+marchDayOfYear month day = (153 * (if month > 2 then month - 3 else month + 9) + 2) `div` 5 + day - 1+ dateValue :: RawDate -> MySQLValue dateValue = either MySQLDateRaw MySQLDate . calendarDate @@ -239,9 +264,12 @@ 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.+(docs/direct-row-decoding.md). A string is decoded as UTF-8 only when its+value is used, as in 1.3: bytes that are not UTF-8 raise 'InvalidUtf8Text'+from pure code then. 1.4.0 checked every string while reading the row+instead, which cost a validation pass on text nobody looked at and a second+pass on text that was used; callers who want the check up front use the+typed decoders of "Database.MySQL.Decoder", which check as they read.  'getTextField' and 'getTextRow' keep their 'Get' interface and share 'columnKind' and 'decodeTextValue', so both paths turn the same bytes into the@@ -342,9 +370,25 @@     | 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+      -- ^ a string in this character set id whose bytes are not UTF-8. Not+      -- raised since 1.4.1, where such a string raises 'InvalidUtf8Text' when+      -- its value is used; kept so that matches on it still compile.     deriving (Show, Eq) +-- | A string value, in the character set with this id, whose bytes are not+-- UTF-8. Raised when the 'MySQLText' is evaluated, not while its row is read.+--+-- @since 1.4.1+data InvalidUtf8Text = InvalidUtf8Text !Word16 !ByteString+    deriving (Show, Eq)++instance Exception InvalidUtf8Text where+    displayException (InvalidUtf8Text charsetId _) =+        "Database.MySQL.Protocol.MySQLValue: a string value 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 message 'getTextField' fails with. describeTextFieldError :: TextFieldError -> String describeTextFieldError fieldError = case fieldError of@@ -393,15 +437,17 @@     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].+-- | Always 'Right': the 'MySQLText' is decoded, in one UTF-8 pass, when it 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)+utf8Value charsetId bytes = Right (lazyUtf8Text charsetId bytes) {-# INLINE utf8Value #-} +lazyUtf8Text :: Word16 -> ByteString -> MySQLValue+lazyUtf8Text charsetId bytes = case T.decodeUtf8' bytes of+    Right decoded -> MySQLText decoded+    Left _        -> throw (InvalidUtf8Text charsetId bytes)+ lexedValue :: FieldType -> (a -> MySQLValue) -> (ByteString -> Maybe a) -> ByteString            -> Either TextFieldError MySQLValue lexedValue fieldType construct lexer bytes = case lexer bytes of@@ -613,8 +659,8 @@ -- 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,+-- keeps ASCII-only values working as they always did. Bytes that are not+-- UTF-8 raise an 'InvalidUtf8Text' naming the charset when the value is used, -- rather than return mangled text.  stringColumnValue :: ColumnDef -> ByteString -> Get MySQLValue

@@ -133,6 +133,10 @@         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 "mysqlValue checks UTF-8 while it reads the row, unlike query_" $+        decodeTextWith (Decode.field Decode.mysqlValue) [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])])@@ -292,7 +296,8 @@     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)]+    -- Valid UTF-8 only, as in TextRowDecoding's genField.+    KindText _      -> lengthEncoded . T.encodeUtf8 <$> arbitrary     KindLatin1Text  -> lengthEncoded <$> arbitrary     KindBytes       -> lengthEncoded <$> arbitrary     KindBit         -> lengthEncoded <$> (choose (1, 10) >>= genBytes)

@@ -12,6 +12,7 @@ import qualified MariaDBNegotiation import qualified LargeRows import qualified Latin1Results+import qualified NonUtf8Results import qualified PlaceholderLiterals import qualified UnsignedInsertId import qualified ZeroDateRoundtrip@@ -46,6 +47,7 @@         , MultipleResults.tests         , RowDecoderQueries.tests         , MariaDBNegotiation.tests greet+        , NonUtf8Results.tests         , UnsignedInsertId.tests         , BinLogRowEvents.tests         , CABundle.tests

@@ -0,0 +1,47 @@+-- | Results in a charset other than UTF-8 or latin1, here gbk after+-- @SET NAMES gbk@. 'query_' hands the rows over and a string whose bytes are+-- not UTF-8 raises 'InvalidUtf8Text' when used; the typed decoders refuse the+-- row while reading it. 1.4.0 refused the row in 'query_' too.+module NonUtf8Results (tests) where++import           Control.Exception      (evaluate, try)+import           Control.Monad          (void)+import           Data.Word              (Word16)+import           Database.MySQL.Base+import qualified Database.MySQL.Decoder as Decode+import qualified System.IO.Streams      as Stream+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUser               (withTestConnection)++tests :: TestTree+tests = testGroup "results in gbk"+    [ testCase "query_ reads the row; the string that is not UTF-8 raises when used" $+        withTestConnection $ \c -> do+            void (execute_ c "SET NAMES gbk")+            (_, rows) <- query_ c gbkQuery+            values <- Stream.toList rows+            case values of+                [[ok, nihao]] -> do+                    ok @?= MySQLText "ok"+                    used <- try (evaluate nihao)+                    used @?= Left (InvalidUtf8Text gbkChineseCi "\xC4\xE3")+                other -> assertFailure ("expected one row of two values, got " ++ show (length other))+    , testCase "queryRows_ with Decode.text refuses the row while reading it" $+        withTestConnection $ \c -> do+            void (execute_ c "SET NAMES gbk")+            (_, rows) <- queryRows_ ((,) <$> Decode.field Decode.text <*> Decode.field Decode.text) c gbkQuery+            refused <- try (Stream.toList rows)+            case refused of+                Left (Decode.FieldError (ColumnNumber 1) (Decode.FieldInvalidUtf8 bytes)) -> bytes @?= "\xC4\xE3"+                Left other -> assertFailure ("refused with " ++ show other)+                Right decoded -> assertFailure ("decoded " ++ show decoded)+    ]++-- | 你, which gbk sends as the two bytes C4 E3.+gbkQuery :: Query+gbkQuery = "SELECT 'ok', CONVERT(_utf8mb4 X'E4BDA0' USING gbk)"++-- | The id the server gives gbk results' default collation.+gbkChineseCi :: Word16+gbkChineseCi = 28

@@ -1,8 +1,10 @@ -- | 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.+-- used to go through a UTF-8 decoder that threw an impure exception. Bytes+-- that are not UTF-8 in any other charset raise 'InvalidUtf8Text' when the+-- value is used, not while the row is read (1.4.0 refused the row). module ResultCharsets (tests) where -import           Control.Exception              (SomeException, evaluate, try)+import           Control.Exception              (evaluate, try) import           Data.Binary.Parser             (parseOnly) import           Data.Binary.Put                (runPut) import qualified Data.ByteString                as B@@ -19,21 +21,24 @@     [ 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+    , testCase "another charset decodes ASCII, and other bytes raise when the value is used" $ 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)+        text <- either (assertFailure . ("refused the field: " <>)) pure+            (parseOnly (getTextField (varchar gbkChineseCi)) (lenEnc "\xC4\xE3"))+        used <- try (evaluate text)+        used @?= Left (InvalidUtf8Text gbkChineseCi "\xC4\xE3")+    , testCase "a text row with one invalid string decodes, and only that value raises" $ do+        let kinds = map columnKind [varchar gbkChineseCi, varchar gbkChineseCi]+        values <- either (assertFailure . ("refused the row: " <>) . show) pure+            (decodeTextRow kinds (lenEnc "ok" <> lenEnc "\xC4\xE3"))+        case values of+            [ok, invalid] -> do+                ok @?= MySQLText "ok"+                used <- try (evaluate invalid)+                used @?= Left (InvalidUtf8Text gbkChineseCi "\xC4\xE3")+            other -> assertFailure ("expected two values, got " <> show (length other))     ]---- | 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

@@ -180,7 +180,9 @@     KindDate        -> renderedOrArbitrary (arbitrary :: Gen Day)     KindTime        -> oneof [genTime, renderedOrArbitrary (arbitrary :: Gen TimeOfDay)]     KindGeometry    -> arbitrary-    KindText _      -> frequency [(9, T.encodeUtf8 <$> arbitrary), (1, arbitrary)]+    -- Valid UTF-8 only: invalid bytes raise when the value is used, while the+    -- typed decoders refuse the row, which ResultCharsets and DirectDecoding test.+    KindText _      -> T.encodeUtf8 <$> arbitrary     KindLatin1Text  -> arbitrary     KindBytes       -> frequency [(9, arbitrary), (1, genLongBytes)]     KindBit         -> B.pack <$> (choose (1, 10) >>= vector)

@@ -6,7 +6,8 @@ import           Data.Binary.Put                (runPut) import qualified Data.ByteString                as B import qualified Data.ByteString.Lazy           as L-import           Data.Time.Calendar             (Day)+import           Data.Time.Calendar             (Day, fromGregorianValid)+import           Data.Word                      (Word16, Word8) import           Data.Time.LocalTime            (TimeOfDay (..)) import           Database.MySQL.Field import           Database.MySQL.Protocol.ColumnDef@@ -38,7 +39,24 @@         assertEqual "decoded"             (Left (DecodeUnrepresentableDate (ExpectedTypeName "Day") (MySQLDateRaw (RawDate 0 0 0))))             (fromField (MySQLDateRaw (RawDate 0 0 0)) :: Either DecodeError Day)+    , testCase "calendarDate agrees with fromGregorianValid on every month and day" $+        take 5 (filter disagrees calendarSample) @?= []     ]++-- | Two full 400-year Gregorian cycles from year 0, the turns of centuries+-- around them, and the ends of 'Word16', each with every month 0 to 13 and+-- day 0 to 32, so that the fast path and its fallback both run.+calendarSample :: [RawDate]+calendarSample = do+    year <- [0 .. 800] ++ [1582, 1858, 1900, 1970, 2000, 2024, 2100, 9999, 65534, 65535 :: Word16]+    month <- [0 .. 13 :: Word8]+    day <- [0 .. 32 :: Word8]+    pure (RawDate year month day)++disagrees :: RawDate -> Bool+disagrees raw@(RawDate year month day) =+    calendarDate raw+        /= maybe (Left raw) Right (fromGregorianValid (toInteger year) (fromEnum month) (fromEnum day))  column :: FieldType -> ColumnDef column fieldType = ColumnDef "" "" "" "" "" 63 0 fieldType 0 0