More tests for Data.Text.Read.{double,rational}

haskell · Feb 29, 2024 · 6fa8b26 · 6fa8b26
1 parent e182733
commit 6fa8b26
Showing 1 changed file with 61 additions and 20 deletions.
diff --git a/tests/Tests/Properties/Read.hs b/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)
+      ]
+
+    ]