Add bounds checks for unsafe conversions from Scientific

Author: bergmark

Data/Aeson/Encoding/Builder.hs

@@ -133,7 +133,7 @@ c2w c = fromIntegral (ord c)
 -- | Encode a JSON number.
 scientific :: Scientific -> Builder
 scientific s
-    | e < 0     = scientificBuilder s
+    | e < 0 || e > 1024 = scientificBuilder s
     | otherwise = B.integerDec (coefficient s * 10 ^ e)
   where
     e = base10Exponent s

Data/Aeson/Types/FromJSON.hs

@@ -85,7 +85,6 @@ import Data.Aeson.Internal.Functions (mapKey)
 import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
 import Data.Aeson.Types.Generic
 import Data.Aeson.Types.Internal
-import Data.Attoparsec.Number (Number(..))
 import Data.Bits (unsafeShiftR)
 import Data.Fixed (Fixed, HasResolution)
 import Data.Functor.Compose (Compose(..))
@@ -99,7 +98,7 @@ import Data.Maybe (fromMaybe)
 import Data.Semigroup ((<>))
 import Data.Proxy (Proxy(..))
 import Data.Ratio ((%), Ratio)
-import Data.Scientific (Scientific)
+import Data.Scientific (Scientific, base10Exponent)
 import Data.Tagged (Tagged(..))
 import Data.Text (Text, pack, unpack)
 import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
@@ -172,15 +171,6 @@ parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
 parseJSONElemAtIndex :: (Value -> Parser a) -> Int -> V.Vector Value -> Parser a
 parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx
 
-scientificToNumber :: Scientific -> Number
-scientificToNumber s
-    | e < 0     = D $ Scientific.toRealFloat s
-    | otherwise = I $ c * 10 ^ e
-  where
-    e = Scientific.base10Exponent s
-    c = Scientific.coefficient s
-{-# INLINE scientificToNumber #-}
-
 parseRealFloat :: RealFloat a => String -> Value -> Parser a
 parseRealFloat _        (Number s) = pure $ Scientific.toRealFloat s
 parseRealFloat _        Null       = pure (0/0)
@@ -196,7 +186,7 @@ parseIntegralFromScientific expected s =
 
 parseIntegral :: Integral a => String -> Value -> Parser a
 parseIntegral expected =
-    withScientific expected $ parseIntegralFromScientific expected
+    withBoundedScientific expected $ parseIntegralFromScientific expected
 {-# INLINE parseIntegral #-}
 
 parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => String -> Scientific -> Parser a
@@ -218,8 +208,13 @@ parseScientificText
     . T.encodeUtf8
 
 parseIntegralText :: Integral a => String -> Text -> Parser a
-parseIntegralText expected t =
-    parseScientificText t >>= parseIntegralFromScientific expected
+parseIntegralText expected t
+    = parseScientificText t
+  >>= rejectLargeExponent
+  >>= parseIntegralFromScientific expected
+  where
+    rejectLargeExponent :: Scientific -> Parser Scientific
+    rejectLargeExponent s = withBoundedScientific expected pure (Number s)
 {-# INLINE parseIntegralText #-}
 
 parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a
@@ -648,11 +643,30 @@ withArray expected _ v           = typeMismatch expected v
 -- | @'withScientific' expected f value@ applies @f@ to the 'Scientific' number
 -- when @value@ is a 'Number' and fails using @'typeMismatch' expected@
 -- otherwise.
+-- .
+-- /Warning/: If you are converting from a scientific to an unbounded
+-- type such as 'Integer' you may want to add a restriction on the
+-- size of the exponent (see 'withBoundedScientific') to prevent
+-- malicious input from filling up the memory of the target system.
 withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
 withScientific _        f (Number scientific) = f scientific
 withScientific expected _ v                   = typeMismatch expected v
 {-# INLINE withScientific #-}
 
+-- | @'withBoundedScientific' expected f value@ applies @f@ to the 'Scientific' number
+-- when @value@ is a 'Number' and fails using @'typeMismatch' expected@
+-- otherwise.
+--
+-- The conversion will also fail wyth a @'typeMismatch' if the
+-- 'Scientific' exponent is larger than 1024.
+withBoundedScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
+withBoundedScientific _ f v@(Number scientific) =
+    if base10Exponent scientific > 1024
+    then typeMismatch "a number with exponent <= 1024" v
+    else f scientific
+withBoundedScientific expected _ v                   = typeMismatch expected v
+{-# INLINE withBoundedScientific #-}
+
 -- | @'withBool' expected f value@ applies @f@ to the 'Bool' when @value@ is a
 -- 'Bool' and fails using @'typeMismatch' expected@ otherwise.
 withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
@@ -1232,12 +1246,6 @@ instance FromJSONKey Double where
         "-Infinity" -> pure (negate 1/0)
         _           -> Scientific.toRealFloat <$> parseScientificText t
 
-instance FromJSON Number where
-    parseJSON (Number s) = pure $ scientificToNumber s
-    parseJSON Null       = pure (D (0/0))
-    parseJSON v          = typeMismatch "Number" v
-    {-# INLINE parseJSON #-}
-
 instance FromJSON Float where
     parseJSON = parseRealFloat "Float"
     {-# INLINE parseJSON #-}
@@ -1258,12 +1266,12 @@ instance (FromJSON a, Integral a) => FromJSON (Ratio a) where
         else pure $ numerator % denominator
     {-# INLINE parseJSON #-}
 
--- | /WARNING:/ Only parse fixed-precision numbers from trusted input
--- since an attacker could easily fill up the memory of the target
--- system by specifying a scientific number with a big exponent like
--- @1e1000000000@.
+-- | This instance includes a bounds check to prevent maliciously
+-- large inputs to fill up the memory of the target system. You can
+-- newtype 'Scientific' and provide your own instance using
+-- 'withScientific' if you want to allow larger inputs.
 instance HasResolution a => FromJSON (Fixed a) where
-    parseJSON = withScientific "Fixed" $ pure . realToFrac
+    parseJSON = withBoundedScientific "Fixed" $ pure . realToFrac
     {-# INLINE parseJSON #-}
 
 instance FromJSON Int where
@@ -1273,10 +1281,10 @@ instance FromJSON Int where
 instance FromJSONKey Int where
     fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Int"
 
--- | /WARNING:/ Only parse Integers from trusted input since an
--- attacker could easily fill up the memory of the target system by
--- specifying a scientific number with a big exponent like
--- @1e1000000000@.
+-- | This instance includes a bounds check to prevent maliciously
+-- large inputs to fill up the memory of the target system. You can
+-- newtype 'Scientific' and provide your own instance using
+-- 'withScientific' if you want to allow larger inputs.
 instance FromJSON Integer where
     parseJSON = parseIntegral "Integer"
     {-# INLINE parseJSON #-}
@@ -1715,21 +1723,21 @@ instance FromJSONKey UTCTime where
     fromJSONKey = FromJSONKeyTextParser (Time.run Time.utcTime)
 
 
--- | /WARNING:/ Only parse lengths of time from trusted input
--- since an attacker could easily fill up the memory of the target
--- system by specifying a scientific number with a big exponent like
--- @1e1000000000@.
+-- | This instance includes a bounds check to prevent maliciously
+-- large inputs to fill up the memory of the target system. You can
+-- newtype 'Scientific' and provide your own instance using
+-- 'withScientific' if you want to allow larger inputs.
 instance FromJSON NominalDiffTime where
-    parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac
+    parseJSON = withBoundedScientific "NominalDiffTime" $ pure . realToFrac
     {-# INLINE parseJSON #-}
 
 
--- | /WARNING:/ Only parse lengths of time from trusted input
--- since an attacker could easily fill up the memory of the target
--- system by specifying a scientific number with a big exponent like
--- @1e1000000000@.
+-- | This instance includes a bounds check to prevent maliciously
+-- large inputs to fill up the memory of the target system. You can
+-- newtype 'Scientific' and provide your own instance using
+-- 'withScientific' if you want to allow larger inputs.
 instance FromJSON DiffTime where
-    parseJSON = withScientific "DiffTime" $ pure . realToFrac
+    parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac
     {-# INLINE parseJSON #-}
 
 -------------------------------------------------------------------------------

aeson.cabal

@@ -1,5 +1,5 @@
 name:            aeson
-version:         1.3.1.1
+version:         1.4.0.0
 license:         BSD3
 license-file:    LICENSE
 category:        Text, Web, JSON

changelog.md

@@ -1,9 +1,24 @@
 For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md).
 
-### 1.4.0.0 (upcoming)
+### 1.4.0.0
 
+This release introduces bounds on the size of `Scientific` numbers when they are converted to other arbitrary precision types that do not represent them efficiently in memory.
+
+This means that trying to decode a number such as `1e1000000000` into an `Integer` will now fail instead of using a lot of memory. If you need to represent large numbers you can add a newtype (preferably over `Scientific`) and providing a parser using `withScientific`.
+
+The following instances are affected by this:
+* `FromJSON Natural`
+* `FromJSONKey Natural`
+* `FromJSON Integer`
+* `FromJSONKey Integer`
+* `FromJSON NominalDiffTime`
+
+For the same reasons the following instances & functions have been removed:
+* Remove `FromJSON Data.Attoparsec.Number` instance. Note that `Data.Attoparsec.Number` is deprecated.
 * Remove deprecated `withNumber`, use `withScientific` instead.
 
+Finally, encoding integral values with large exponents now uses scientific notation, this saves space for large numbers.
+
 ### 1.3.1.1
 
 * Catch 0 denominators when parsing Ratio

tests/UnitTests.hs

@@ -31,16 +31,19 @@ import Data.Aeson.Types (Options(..), Result(Success), ToJSON(..), Value(Null),
 import Data.Char (toUpper)
 import Data.Either.Compat (isLeft, isRight)
 import Data.Hashable (hash)
+import Data.HashMap.Strict (HashMap)
 import Data.List (sort)
 import Data.Maybe (fromMaybe)
 import Data.Sequence (Seq)
+import Data.Scientific (Scientific, scientific)
 import Data.Tagged (Tagged(..))
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Data.Time.Format (parseTime)
 import Data.Time.Locale.Compat (defaultTimeLocale)
 import GHC.Generics (Generic)
 import Instances ()
+import Numeric.Natural (Natural)
 import System.Directory (getDirectoryContents)
 import System.FilePath ((</>), takeExtension, takeFileName)
 import Test.Tasty (TestTree, testGroup)
@@ -100,6 +103,10 @@ tests = testGroup "unit" [
   , testCase "withEmbeddedJSON" withEmbeddedJSONTest
   , testCase "SingleFieldCon" singleFieldCon
   , testCase "Ratio with denominator 0" ratioDenominator0
+  , testCase "Big scientific exponent" bigScientificExponent
+  , testCase "Big integer decoding" bigIntegerDecoding
+  , testCase "Big natural decading" bigNaturalDecoding
+  , testCase "Big integer key decoding" bigIntegerKeyDecoding
   ]
 
 roundTripCamel :: String -> Assertion
@@ -552,6 +559,36 @@ ratioDenominator0 =
     (Left "Error in $: Ratio denominator was 0")
     (eitherDecode "{ \"numerator\": 1, \"denominator\": 0 }" :: Either String Rational)
 
+bigScientificExponent :: Assertion
+bigScientificExponent =
+  assertEqual "Encoding an integral scientific with a large exponent should normalize it"
+    "1.0e2000"
+    (encode (scientific 1 2000 :: Scientific))
+
+bigIntegerDecoding :: Assertion
+bigIntegerDecoding =
+  assertEqual "Decoding an Integer with a large exponent should fail"
+    (Left "Error in $: expected a number with exponent <= 1024, encountered Number")
+    ((eitherDecode :: L.ByteString -> Either String Integer) "1e2000")
+
+bigNaturalDecoding :: Assertion
+bigNaturalDecoding =
+  assertEqual "Decoding a Natural with a large exponent should fail"
+    (Left "Error in $: expected a number with exponent <= 1024, encountered Number")
+    ((eitherDecode :: L.ByteString -> Either String Integer) "1e2000")
+
+bigIntegerKeyDecoding :: Assertion
+bigIntegerKeyDecoding =
+  assertEqual "Decoding an Integer key with a large exponent should fail"
+    (Left "Error in $['1e2000']: expected a number with exponent <= 1024, encountered Number")
+    ((eitherDecode :: L.ByteString -> Either String (HashMap Integer Value)) "{ \"1e2000\": null }")
+
+bigNaturalKeyDecoding :: Assertion
+bigNaturalKeyDecoding =
+  assertEqual "Decoding an Integer key with a large exponent should fail"
+    (Left "Error in $['1e2000']: expected a number with exponent <= 1024, encountered Number")
+    ((eitherDecode :: L.ByteString -> Either String (HashMap Natural Value)) "{ \"1e2000\": null }")
+
 deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
 
 deriveToJSON  defaultOptions ''Foo