packages feed

mysql-haskell 1.2.1 → 1.2.2

raw patch · 7 files changed

+179/−12 lines, 7 filesdep ~tls

Dependency ranges changed: tls

Files

ChangeLog.md view
@@ -1,5 +1,13 @@ # Revision history for mysql-haskell +## 1.2.2 -- 2026.03.25++ Widen tls upper bound to allow tls 2.4.x++ Fix unsafe ByteString operations (`unsafeDrop`, `unsafeTail`, `unsafeIndex`)+  on untrusted wire protocol data that caused undefined behavior (segfaults,+  garbage reads) on malformed input. The safe alternatives are also O(1).+  Affected parsers: text protocol timestamp/datetime/time/date fields,+  NEWDECIMAL in binlog, and `eventHeaderLen` for unknown event types.+ ## 1.2.1 -- 2026.03.23 + Export `connectUnixSocket` function. + Tweak cabal file to better handle crypton vs cryptonite.
mysql-haskell.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               mysql-haskell-version:            1.2.1+version:            1.2.2 synopsis:           pure haskell MySQL driver description:        pure haskell MySQL driver. license:            BSD-3-Clause@@ -106,7 +106,7 @@     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,+    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,     vector >=0.8 && <0.13 || ^>=0.13.0,     word-compat >=0.0 && <0.1 @@ -133,6 +133,7 @@   other-modules:     Aeson     AesonBP+    BoundsCheck     JSON     QC.ByteString     QC.Combinator
src/Database/MySQL/BinLogProtocol/BinLogEvent.hs view
@@ -135,7 +135,14 @@                                          <*> (L.toStrict <$> getRemainingLazyByteString)  eventHeaderLen :: FormatDescription -> BinLogEventType -> Word8-eventHeaderLen fd typ = B.unsafeIndex (fdEventHeaderLenVector fd) (fromEnum typ - 1)+eventHeaderLen fd typ+    | idx < 0 || idx >= B.length vec = 0+    | otherwise = B.unsafeIndex vec idx+  where+    vec :: ByteString+    vec = fdEventHeaderLenVector fd+    idx :: Int+    idx = fromEnum typ - 1  data RotateEvent = RotateEvent     { rPos :: !Word64, rFileName :: !ByteString } deriving (Show, Eq)
src/Database/MySQL/BinLogProtocol/BinLogValue.hs view
@@ -203,7 +203,9 @@ -- if there're < 9 digits at first, it will be compressed into suitable length words -- following a simple lookup table. ---getBinLogField (BINLOG_TYPE_NEWDECIMAL precision scale) = do+getBinLogField (BINLOG_TYPE_NEWDECIMAL precision scale)+    | precision < scale = fail "NEWDECIMAL: precision must be >= scale"+    | otherwise = do     let i = (precision - scale)         (ucI, cI) = i `quotRem` digitsPerInteger         (ucF, cF) = scale `quotRem` digitsPerInteger
src/Database/MySQL/Protocol/MySQLValue.hs view
@@ -162,16 +162,19 @@     | t == mySQLTypeYear            = feedLenEncBytes t MySQLYear intLexer     | t == mySQLTypeTimestamp         || t == mySQLTypeTimestamp2 = feedLenEncBytes t MySQLTimeStamp $ \ bs ->-                                          LocalTime <$> dateParser bs <*> timeParser (B.unsafeDrop 11 bs)+                                          guard (B.length bs >= 12) >>+                                          LocalTime <$> dateParser bs <*> timeParser (B.drop 11 bs)     | t == mySQLTypeDateTime         || t == mySQLTypeDateTime2  = feedLenEncBytes t MySQLDateTime $ \ bs ->-                                          LocalTime <$> dateParser bs <*> timeParser (B.unsafeDrop 11 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 ->-                                          if bs `B.unsafeIndex` 0 == 45  -- '-'-                                               then MySQLTime 1 <$> timeParser (B.unsafeDrop 1 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      | t == mySQLTypeGeometry        = MySQLGeometry <$> getLenEncBytes@@ -196,14 +199,18 @@     fracLexer bs = fst <$> LexFrac.readSigned LexFrac.readDecimal bs     dateParser bs = do         (yyyy, rest) <- LexInt.readDecimal bs-        (mm, rest') <- LexInt.readDecimal (B.unsafeTail rest)-        (dd, _) <- LexInt.readDecimal (B.unsafeTail rest')+        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-        (mm, rest') <- LexInt.readDecimal (B.unsafeTail rest)-        (ss, _) <- LexFrac.readDecimal (B.unsafeTail rest')+        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)
+ test/BoundsCheck.hs view
@@ -0,0 +1,140 @@+module BoundsCheck (tests) where++import qualified Data.ByteString             as B+import qualified Data.ByteString.Lazy        as L+import           Data.Binary.Put             (runPut, putWord8)+import           Data.Binary.Parser          (parseOnly)+import           Test.Tasty+import           Test.Tasty.HUnit++import           Database.MySQL.Protocol.ColumnDef+import           Database.MySQL.Protocol.MySQLValue (getTextField, MySQLValue)+import           Database.MySQL.Protocol.Packet (putLenEncInt)+import           Database.MySQL.BinLogProtocol.BinLogEvent+                    (FormatDescription(..), eventHeaderLen, BinLogEventType(..))+import           Database.MySQL.BinLogProtocol.BinLogValue (getBinLogField)+import           Database.MySQL.BinLogProtocol.BinLogMeta (BinLogMeta(..))++tests :: TestTree+tests = testGroup "bounds-check"+    [ testGroup "text-protocol" textProtocolTests+    , testGroup "binlog-value" binlogValueTests+    , testGroup "binlog-event" binlogEventTests+    ]++--------------------------------------------------------------------------------+-- Helpers++-- | Build a ColumnDef with the given field type and default flags.+mkColumnDef :: FieldType -> ColumnDef+mkColumnDef ft = ColumnDef+    { columnDB        = ""+    , columnTable     = ""+    , columnOrigTable = ""+    , columnName      = ""+    , columnOrigName  = ""+    , columnCharSet   = 63 -- binary+    , columnLength    = 0+    , columnType      = ft+    , columnFlags     = 0+    , columnDecimals  = 0+    }++-- | Encode a length-prefixed ByteString as the MySQL wire protocol does,+-- then run the given Get parser 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++-- | Check that parsing yields a Left (failure), not a crash or garbage.+assertParseFailure :: String -> Either String a -> Assertion+assertParseFailure label result = case result of+    Left _  -> pure ()+    Right _ -> assertFailure (label ++ ": expected parse failure but got a result")++--------------------------------------------------------------------------------+-- Text protocol tests++textProtocolTests :: [TestTree]+textProtocolTests =+    [ 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"+        assertParseFailure "timestamp no time" result++    , testCase "timestamp: truncated time" $ do+        -- "2024-01-01 1" is 12 bytes. dateParser succeeds, unsafeDrop 11+        -- 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"+        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"+        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 ""+        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"+        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"+        assertParseFailure "time missing sep" result+    ]++--------------------------------------------------------------------------------+-- BinLog value tests++binlogValueTests :: [TestTree]+binlogValueTests =+    [ testCase "NEWDECIMAL: precision < scale causes underflow" $ do+        -- precision=3, scale=10: (precision - scale) underflows Word8 to 249,+        -- producing a huge index into the 10-element sizeTable+        let meta = BINLOG_TYPE_NEWDECIMAL 3 10+            -- Provide some bytes so Get doesn't fail on "not enough input" first+            input = B.replicate 64 0x80+            result = parseOnly (getBinLogField meta) input+        assertParseFailure "NEWDECIMAL underflow" result+    ]++--------------------------------------------------------------------------------+-- BinLog event tests++binlogEventTests :: [TestTree]+binlogEventTests =+    [ testCase "eventHeaderLen: BINLOG_UNKNOWN_EVENT (negative index)" $ do+        -- fromEnum BINLOG_UNKNOWN_EVENT - 1 = -1, negative index into ByteString+        let fd = FormatDescription+                { fdVersion = 4+                , fdMySQLVersion = B.replicate 50 0+                , fdCreateTime = 0+                , fdEventHeaderLenVector = B.pack [19, 19, 19]  -- short vector+                }+            -- This should not crash; should return safe fallback+            result = eventHeaderLen fd BINLOG_UNKNOWN_EVENT+        -- After fix: returns 0 (safe fallback) instead of crashing+        assertEqual "unknown event should return 0" 0 result+    ]
test/Main.hs view
@@ -7,6 +7,7 @@ import qualified Sha256Scramble import qualified Word24 import qualified TCPStreams+import qualified BoundsCheck  main :: IO () main = do@@ -24,4 +25,5 @@            TCPStreams.tests          ]       , Sha256Scramble.tests+      , BoundsCheck.tests       ]