diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: mysql-haskell -version: 1.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 diff --git a/src/Database/MySQL/Decoder.hs b/src/Database/MySQL/Decoder.hs --- a/src/Database/MySQL/Decoder.hs +++ b/src/Database/MySQL/Decoder.hs @@ -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 #) diff --git a/src/Database/MySQL/Protocol/MySQLValue.hs b/src/Database/MySQL/Protocol/MySQLValue.hs --- a/src/Database/MySQL/Protocol/MySQLValue.hs +++ b/src/Database/MySQL/Protocol/MySQLValue.hs @@ -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 diff --git a/test/DirectDecoding.hs b/test/DirectDecoding.hs --- a/test/DirectDecoding.hs +++ b/test/DirectDecoding.hs @@ -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) diff --git a/test/Integration.hs b/test/Integration.hs --- a/test/Integration.hs +++ b/test/Integration.hs @@ -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 diff --git a/test/NonUtf8Results.hs b/test/NonUtf8Results.hs new file mode 100644 --- /dev/null +++ b/test/NonUtf8Results.hs @@ -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 diff --git a/test/ResultCharsets.hs b/test/ResultCharsets.hs --- a/test/ResultCharsets.hs +++ b/test/ResultCharsets.hs @@ -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 diff --git a/test/TextRowDecoding.hs b/test/TextRowDecoding.hs --- a/test/TextRowDecoding.hs +++ b/test/TextRowDecoding.hs @@ -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) diff --git a/test/ZeroDates.hs b/test/ZeroDates.hs --- a/test/ZeroDates.hs +++ b/test/ZeroDates.hs @@ -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