From ebfe8082ae05641c3d1fe7bf71c4ea51097ca96d Mon Sep 17 00:00:00 2001 From: Ashley Yakeley Date: Sun, 19 Jul 2026 20:40:29 -0700 Subject: [PATCH] fix numeric parsers accepting overflowing bounded values (#302) --- changelog.md | 1 + lib/Data/Format.hs | 43 +++++++++++++++++++++---- lib/Data/Time/Format/ISO8601.hs | 2 +- lib/Data/Time/Format/Parse/Instances.hs | 17 +++++++--- test/main/Test/Format/ISO8601.hs | 7 ++++ test/main/Test/Format/ParseTime.hs | 7 +++- 6 files changed, 64 insertions(+), 13 deletions(-) diff --git a/changelog.md b/changelog.md index 261ded28..b3ea3a70 100644 --- a/changelog.md +++ b/changelog.md @@ -7,6 +7,7 @@ - fix case-insensitive parsing for AM/PM markers, UTC, and known timezone names - fix Unix timezone fallback offset sign and DST abbreviation - fix JavaScript getTimeZone offsets and summer flag around DST transitions +- fix numeric parsers accepting overflowing bounded values ## [1.16] - 2026-05-03 diff --git a/lib/Data/Format.hs b/lib/Data/Format.hs index 9e9010b4..19058ad3 100644 --- a/lib/Data/Format.hs +++ b/lib/Data/Format.hs @@ -29,6 +29,7 @@ import Control.Monad.Fail import Data.Char import Data.Void import Text.ParserCombinators.ReadP +import Text.Read (readMaybe) import Prelude hiding (fail) class IsoVariant f where @@ -213,13 +214,40 @@ readSign NoSign = return id readSign NegSign = option id $ char '-' >> return negate readSign PosNegSign = (char '+' >> return id) +++ (char '-' >> return negate) +readDigits :: Maybe Int -> ReadP String +readDigits mdigitcount = + case mdigitcount of + Just digitcount -> count digitcount $ satisfy isDigit + Nothing -> munch1 isDigit + +readMaybeP :: Read t => String -> ReadP t +readMaybeP str = + case readMaybe str of + Just t -> return t + Nothing -> pfail + +fromIntegerExact :: Integral t => Integer -> Maybe t +fromIntegerExact i = + let + t = fromInteger i + in + if toInteger t == i + then Just t + else Nothing + +readIntegerNumber :: Integral t => SignOption -> Maybe Int -> ReadP t +readIntegerNumber signOpt mdigitcount = do + sign <- readSign signOpt + digits <- readDigits mdigitcount + i <- readMaybeP digits + case fromIntegerExact $ sign i of + Just t -> return t + Nothing -> pfail + readNumber :: (Num t, Read t) => SignOption -> Maybe Int -> Bool -> ReadP t readNumber signOpt mdigitcount allowDecimal = do sign <- readSign signOpt - digits <- - case mdigitcount of - Just digitcount -> count digitcount $ satisfy isDigit - Nothing -> munch1 isDigit + digits <- readDigits mdigitcount moredigits <- case allowDecimal of False -> return "" @@ -228,7 +256,8 @@ readNumber signOpt mdigitcount allowDecimal = do _ <- char '.' +++ char ',' dd <- munch1 isDigit return $ '.' : dd - return $ sign $ read $ digits ++ moredigits + a <- readMaybeP $ digits ++ moredigits + return $ sign a zeroPad :: Maybe Int -> String -> Maybe String zeroPad Nothing s = Just s @@ -269,8 +298,8 @@ showNumber signOpt mdigitcount t = PosNegSign -> '+' : s _ -> s -integerFormat :: (Show t, Read t, Num t) => SignOption -> Maybe Int -> Format t -integerFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount False) +integerFormat :: (Show t, Integral t) => SignOption -> Maybe Int -> Format t +integerFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readIntegerNumber signOpt mdigitcount) decimalFormat :: (Show t, Read t, Num t) => SignOption -> Maybe Int -> Format t decimalFormat signOpt mdigitcount = MkFormat (showNumber signOpt mdigitcount) (readNumber signOpt mdigitcount True) diff --git a/lib/Data/Time/Format/ISO8601.hs b/lib/Data/Time/Format/ISO8601.hs index 86dec7bb..1459b689 100644 --- a/lib/Data/Time/Format/ISO8601.hs +++ b/lib/Data/Time/Format/ISO8601.hs @@ -328,7 +328,7 @@ dayAndTimeFormat fday ftod = fday <**> withTimeDesignator ftod timeAndOffsetFormat :: Format t -> FormatExtension -> Format (t, TimeZone) timeAndOffsetFormat ft fe = ft <**> timeOffsetFormat fe -intDesignator :: (Eq t, Show t, Read t, Num t) => Char -> Format t +intDesignator :: (Show t, Integral t) => Char -> Format t intDesignator c = optionalFormat 0 $ integerFormat NegSign Nothing <** literalFormat [c] decDesignator :: (Eq t, Show t, Read t, Num t) => Char -> Format t diff --git a/lib/Data/Time/Format/Parse/Instances.hs b/lib/Data/Time/Format/Parse/Instances.hs index 216e3889..53f2ba5c 100644 --- a/lib/Data/Time/Format/Parse/Instances.hs +++ b/lib/Data/Time/Format/Parse/Instances.hs @@ -129,11 +129,20 @@ readSpec_Z _ _ = Nothing eqCI :: String -> String -> Bool eqCI x y = map toUpper x == map toUpper y +readIntegralMaybe :: Integral a => String -> Maybe a +readIntegralMaybe str = do + i <- readMaybe str + let + a = fromInteger i + if toInteger a == i + then Just a + else Nothing + makeDayFact :: TimeLocale -> Char -> String -> Maybe [DayFact] makeDayFact l c x = let - ra :: Read a => Maybe a - ra = readMaybe x + ra :: Integral a => Maybe a + ra = readIntegralMaybe x zeroBasedListIndex :: [String] -> Maybe Int zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss oneBasedListIndex :: [String] -> Maybe Int @@ -411,8 +420,8 @@ timeFactGetZone = lastMatch $ \case makeTimeFact :: TimeLocale -> Char -> String -> Maybe [TimeFact] makeTimeFact l c x = let - ra :: Read a => Maybe a - ra = readMaybe x + ra :: Integral a => Maybe a + ra = readIntegralMaybe x getAmPm = let (amStr, pmStr) = amPm l diff --git a/test/main/Test/Format/ISO8601.hs b/test/main/Test/Format/ISO8601.hs index 988999a9..71e4a4cd 100644 --- a/test/main/Test/Format/ISO8601.hs +++ b/test/main/Test/Format/ISO8601.hs @@ -160,6 +160,9 @@ testShowReadFormat name fmt str val = testReadFormat :: (Show t, Eq t) => String -> Format t -> String -> t -> TestTree testReadFormat name fmt str val = nameTest (name ++ ": " ++ str) $ assertEqual "" (Just val) $ formatParseM fmt str +testReadFormatFails :: (Show t, Eq t) => String -> Format t -> String -> TestTree +testReadFormatFails name fmt str = nameTest (name ++ ": " ++ str) $ assertEqual "" Nothing $ formatParseM fmt str + testShowFormats :: TestTree testShowFormats = nameTest @@ -240,6 +243,10 @@ testShowFormats = (recurringIntervalFormat (calendarFormat ExtendedFormat) durationDaysFormat) "R74/2015-06-13/P1Y2M7D" (74, fromGregorian 2015 6 13, CalendarDiffDays 14 7) + , testReadFormatFails + "recurringIntervalFormat etc." + (recurringIntervalFormat (calendarFormat ExtendedFormat) (calendarFormat ExtendedFormat)) + "R18446744073709551616/2024-01-01/2024-01-02" , testShowReadFormat "timeOffsetFormat" iso8601Format "-06:30" (minutesToTimeZone (-390)) , testShowReadFormat "timeOffsetFormat" iso8601Format "-06:00" (minutesToTimeZone (-360)) , testReadFormat "timeOffsetFormat" iso8601Format "-06" (minutesToTimeZone (-360)) diff --git a/test/main/Test/Format/ParseTime.hs b/test/main/Test/Format/ParseTime.hs index 70849388..22897069 100644 --- a/test/main/Test/Format/ParseTime.hs +++ b/test/main/Test/Format/ParseTime.hs @@ -293,7 +293,12 @@ particularParseTests = lowerKnownZoneLocale = defaultTimeLocale{knownTimeZones = [lowerKnownZone]} badParseTests :: TestTree -badParseTests = testGroup "bad" [parseTest False (Nothing :: Maybe Day) "%Y" ""] +badParseTests = + testGroup + "bad" + [ parseTest False (Nothing :: Maybe Day) "%Y" "" + , parseTest False (Nothing :: Maybe TimeOfDay) "%-H" "18446744073709551616" + ] {- parseYMD :: Day -> TestTree