Improve precision of Data.Text.Read.rational

src/Data/Text/Lazy/Read.hs

@@ -134,8 +134,16 @@ signed f = runP (signa (P f))
 -- >rational "3e"    == Right (3.0, "e")
 rational :: Fractional a => Reader a
 {-# SPECIALIZE rational :: Reader Double #-}
-rational = floaty $ \real frac fracDenom -> fromRational $
-                     real % 1 + frac % fracDenom
+rational = floaty $ \real frac fracDenom power ->
+  -- We must be careful to prevent DDoS attacks: if the return type is 'Double',
+  -- a client rightfully expects 'rational' to operate within bounded memory.
+  -- Thus if power is small, we can compute fraction with full precision and divide.
+  -- Otherwise divide first, apply fromRational and scale last:
+  -- the small loss of precision for Double does not matter much because the result is
+  -- likely infinity or zero anyway.
+  if abs power < 1000
+  then fromRational ((real % 1 + frac % fracDenom) * (10 ^^ power))
+  else fromRational (real % 1 + frac % fracDenom) * (10 ^^ power)
 
 -- | Read a rational number.
 --
@@ -150,9 +158,9 @@ rational = floaty $ \real frac fracDenom -> fromRational $
 -- around the 15th decimal place.  For 0.001% of numbers, this
 -- function will lose precision at the 13th or 14th decimal place.
 double :: Reader Double
-double = floaty $ \real frac fracDenom ->
-                   fromInteger real +
-                   fromInteger frac / fromInteger fracDenom
+double = floaty $ \real frac fracDenom power ->
+                   (fromInteger real +
+                   fromInteger frac / fromInteger fracDenom) * (10 ^^ power)
 
 signa :: Num a => Parser a -> Parser a
 {-# SPECIALIZE signa :: Parser Int -> Parser Int #-}
@@ -174,7 +182,7 @@ charAscii p = P $ \case
     then Right (c, if len <= 1 then ts else Chunk (T.Text arr (off + 1) (len - 1)) ts)
     else Left "character does not match"
 
-floaty :: Fractional a => (Integer -> Integer -> Integer -> a) -> Reader a
+floaty :: Fractional a => (Integer -> Integer -> Integer -> Int -> a) -> Reader a
 {-# INLINE floaty #-}
 floaty f = runP $ do
   sign <- perhaps (ord8 '+') $ charAscii (\c -> c == ord8 '-' || c == ord8 '+')
@@ -190,9 +198,7 @@ floaty f = runP $ do
           then if power == 0
                then fromInteger real
                else fromInteger real * (10 ^^ power)
-          else if power == 0
-               then f real fraction (10 ^ fracDigits)
-               else f real fraction (10 ^ fracDigits) * (10 ^^ power)
+          else f real fraction (10 ^ fracDigits) power
   return $! if sign == ord8 '+'
             then n
             else -n

src/Data/Text/Read.hs

@@ -140,8 +140,16 @@ signed f = runP (signa (P f))
 -- >rational "3e"    == Right (3.0, "e")
 rational :: Fractional a => Reader a
 {-# SPECIALIZE rational :: Reader Double #-}
-rational = floaty $ \real frac fracDenom -> fromRational $
-                     real % 1 + frac % fracDenom
+rational = floaty $ \real frac fracDenom power ->
+  -- We must be careful to prevent DDoS attacks: if the return type is 'Double',
+  -- a client rightfully expects 'rational' to operate within bounded memory.
+  -- Thus if power is small, we can compute fraction with full precision and divide.
+  -- Otherwise divide first, apply fromRational and scale last:
+  -- the small loss of precision for Double does not matter much because the result is
+  -- likely infinity or zero anyway.
+  if abs power < 1000
+  then fromRational ((real % 1 + frac % fracDenom) * (10 ^^ power))
+  else fromRational (real % 1 + frac % fracDenom) * (10 ^^ power)
 
 -- | Read a rational number.
 --
@@ -156,9 +164,9 @@ rational = floaty $ \real frac fracDenom -> fromRational $
 -- around the 15th decimal place.  For 0.001% of numbers, this
 -- function will lose precision at the 13th or 14th decimal place.
 double :: Reader Double
-double = floaty $ \real frac fracDenom ->
-                   fromInteger real +
-                   fromInteger frac / fromInteger fracDenom
+double = floaty $ \real frac fracDenom power ->
+                   (fromInteger real +
+                   fromInteger frac / fromInteger fracDenom) * (10 ^^ power)
 
 signa :: Num a => Parser a -> Parser a
 {-# SPECIALIZE signa :: Parser Int -> Parser Int #-}
@@ -177,7 +185,7 @@ charAscii p = P $ \(Text arr off len) -> let c = A.unsafeIndex arr off in
   then Right (c, Text arr (off + 1) (len - 1))
   else Left "character does not match"
 
-floaty :: Fractional a => (Integer -> Integer -> Integer -> a) -> Reader a
+floaty :: Fractional a => (Integer -> Integer -> Integer -> Int -> a) -> Reader a
 {-# INLINE floaty #-}
 floaty f = runP $ do
   sign <- perhaps (ord8 '+') $ charAscii (\c -> c == ord8 '-' || c == ord8 '+')
@@ -193,9 +201,7 @@ floaty f = runP $ do
           then if power == 0
                then fromInteger real
                else fromInteger real * (10 ^^ power)
-          else if power == 0
-               then f real fraction (10 ^ fracDigits)
-               else f real fraction (10 ^ fracDigits) * (10 ^^ power)
+          else f real fraction (10 ^ fracDigits) power
   return $! if sign == ord8 '+'
             then n
             else -n

tests/Tests/Properties/Read.hs

@@ -8,7 +8,7 @@ module Tests.Properties.Read
 
 import Data.Char (isDigit, isHexDigit)
 import Numeric (showHex)
-import Test.Tasty (TestTree, testGroup)
+import Test.Tasty (TestTree, testGroup, localOption, mkTimeout)
 import Test.Tasty.QuickCheck (testProperty)
 import Test.QuickCheck
 import Tests.QuickCheckUtils ()
@@ -38,23 +38,39 @@ tl_hexadecimal m s ox =
 
 isFloaty c = c `elem` ("+-.0123456789eE" :: String)
 
-t_read_rational p tol (n::Double) s =
-    case p (T.pack (show n) `T.append` t) of
-      Left err      -> counterexample err $ property False
-      Right (n',t') -> t === t' .&&. property (abs (n-n') <= tol)
-    where t = T.dropWhile isFloaty s
+t_read_rational :: Double -> T.Text -> Property
+t_read_rational n s =
+  case T.rational (T.pack (show n) `T.append` t) of
+    Left err       -> counterexample err $ property False
+    Right (n', t') -> t === t' .&&. n' === n''
+  where
+    t = T.dropWhile isFloaty s
+    n'' = read (show n) :: Double
 
-tl_read_rational p tol (n::Double) s =
-    case p (TL.pack (show n) `TL.append` t) of
-      Left err      -> counterexample err $ property False
-      Right (n',t') -> t === t' .&&. property (abs (n-n') <= tol)
-    where t = TL.dropWhile isFloaty s
+t_read_double :: Double -> Double -> T.Text -> Property
+t_read_double tol n s =
+  case T.double (T.pack (show n) `T.append` t) of
+    Left err       -> counterexample err $ property False
+    Right (n', t') -> t === t' .&&. property (abs (n - n') <= tol)
+  where
+    t = T.dropWhile isFloaty s
 
-t_double = t_read_rational T.double 1e-13
-tl_double = tl_read_rational TL.double 1e-13
-t_rational = t_read_rational T.rational 1e-16
-tl_rational = tl_read_rational TL.rational 1e-16
+tl_read_rational :: Double -> TL.Text -> Property
+tl_read_rational n s =
+  case TL.rational (TL.pack (show n) `TL.append` t) of
+    Left err       -> counterexample err $ property False
+    Right (n', t') -> t === t' .&&. n' === n''
+  where
+    t = TL.dropWhile isFloaty s
+    n'' = read (show n) :: Double
 
+tl_read_double :: Double -> Double -> TL.Text -> Property
+tl_read_double tol n s =
+  case TL.rational (TL.pack (show n) `TL.append` t) of
+    Left err       -> counterexample err $ property False
+    Right (n', t') -> t === t' .&&. property (abs (n - n') <= tol)
+  where
+    t = TL.dropWhile isFloaty s
 
 testRead :: TestTree
 testRead =
@@ -63,8 +79,33 @@ testRead =
     testProperty "tl_decimal" tl_decimal,
     testProperty "t_hexadecimal" t_hexadecimal,
     testProperty "tl_hexadecimal" tl_hexadecimal,
-    testProperty "t_double" t_double,
-    testProperty "tl_double" tl_double,
-    testProperty "t_rational" t_rational,
-    testProperty "tl_rational" tl_rational
-  ]
+
+    testProperty "t_double" $ t_read_double 1e-13,
+    testProperty "tl_double" $ tl_read_double 1e-13,
+
+    testProperty "t_rational" t_read_rational,
+    testProperty "t_rational 1.3e-2" (t_read_rational 1.3e-2),
+    testProperty "tl_rational" tl_read_rational,
+    testProperty "tl_rational 9e-3" (tl_read_rational 9e-3),
+
+    localOption (mkTimeout 100000) $ testGroup "DDoS attacks" [
+      testProperty "t_double large positive exponent" $
+        T.double (T.pack "1.1e1000000000") === Right (1 / 0, mempty),
+      testProperty "t_double large negative exponent" $
+        T.double (T.pack "1.1e-1000000000") === Right (0.0, mempty),
+      testProperty "tl_double large positive exponent" $
+        TL.double (TL.pack "1.1e1000000000") === Right (1 / 0, mempty),
+      testProperty "tl_double large negative exponent" $
+        TL.double (TL.pack "1.1e-1000000000") === Right (0.0, mempty),
+
+      testProperty "t_rational large positive exponent" $
+        T.rational (T.pack "1.1e1000000000") === Right (1 / 0 :: Double, mempty),
+      testProperty "t_rational large negative exponent" $
+        T.rational (T.pack "1.1e-1000000000") === Right (0.0 :: Double, mempty),
+      testProperty "tl_rational large positive exponent" $
+        TL.rational (TL.pack "1.1e1000000000") === Right (1 / 0 :: Double, mempty),
+      testProperty "tl_rational large negative exponent" $
+        TL.rational (TL.pack "1.1e-1000000000") === Right (0.0 :: Double, mempty)
+      ]
+
+    ]