mysql-haskell-1.4.0: test/BoundsCheck.hs
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 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(..))
import Database.MySQL.BinLogProtocol.BinLogValue (getBinLogField)
import Database.MySQL.BinLogProtocol.BinLogMeta (BinLogMeta(..))
tests :: TestTree
tests = testGroup "bounds-check"
[ testGroup "text-protocol" (map textProtocolTests textFieldApis)
, 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.
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 = 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
Left _ -> pure ()
Right _ -> assertFailure (label ++ ": expected parse failure but got a result")
--------------------------------------------------------------------------------
-- Text protocol tests
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 = parseField 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 = 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 = 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 = 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 = 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 = parseField 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
]