diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. 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.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 diff --git a/src/Database/MySQL/BinLogProtocol/BinLogEvent.hs b/src/Database/MySQL/BinLogProtocol/BinLogEvent.hs --- a/src/Database/MySQL/BinLogProtocol/BinLogEvent.hs +++ b/src/Database/MySQL/BinLogProtocol/BinLogEvent.hs @@ -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) diff --git a/src/Database/MySQL/BinLogProtocol/BinLogValue.hs b/src/Database/MySQL/BinLogProtocol/BinLogValue.hs --- a/src/Database/MySQL/BinLogProtocol/BinLogValue.hs +++ b/src/Database/MySQL/BinLogProtocol/BinLogValue.hs @@ -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 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 @@ -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) diff --git a/test/BoundsCheck.hs b/test/BoundsCheck.hs new file mode 100644 --- /dev/null +++ b/test/BoundsCheck.hs @@ -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 + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ]