diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,7 @@ +Version 0.11 + * Limit floating-point range to that of Double to avoid allocation + overflows when constructing Rationals + Version 0.10 * Use MonadFail, so that it works with GHC 8.8 diff --git a/Text/JSON.hs b/Text/JSON.hs --- a/Text/JSON.hs +++ b/Text/JSON.hs @@ -45,7 +45,7 @@ import Data.Int import Data.Word -import qualified Control.Monad.Fail as Fail +import Control.Monad.Fail (MonadFail (..)) import Control.Monad(liftM,ap,MonadPlus(..)) import Control.Applicative @@ -141,7 +141,7 @@ Ok a >>= f = f a Error x >>= _ = Error x -instance Fail.MonadFail Result where +instance MonadFail Result where fail x = Error x -- | Convenient error generation diff --git a/Text/JSON/Parsec.hs b/Text/JSON/Parsec.hs --- a/Text/JSON/Parsec.hs +++ b/Text/JSON/Parsec.hs @@ -78,9 +78,11 @@ p_number :: CharParser () Rational p_number = tok $ do s <- getInput - case readSigned readFloat s of - [(n,s1)] -> n <$$ setInput s1 - _ -> mzero + case (reads s, readSigned readFloat s) of + ([(x,_)], _) + | isInfinite (x :: Double) -> fail "number out of range" + (_, [(y,s')]) -> y <$$ setInput s' + _ -> mzero "number" p_js_string :: CharParser () JSString p_js_string = toJSString <$$> p_string diff --git a/Text/JSON/ReadP.hs b/Text/JSON/ReadP.hs --- a/Text/JSON/ReadP.hs +++ b/Text/JSON/ReadP.hs @@ -70,7 +70,17 @@ where p_field = (,) <$$> (p_string <** token (char ':')) <**> p_value p_number :: ReadP Rational -p_number = readS_to_P (readSigned readFloat) +p_number = readS_to_P safeRationalReads + +-- reading into a Double with reads is safe for huge floating-point literals +-- this will allow all floating-point literals that are small enough to fit +-- into a Double (and are thus compatible with most other json implementations) +-- to be parsed here without opening us to oversized Rational allocations +safeRationalReads :: ReadS Rational +safeRationalReads str = + case reads str of + [(d,_)] | not (isInfinite (d :: Double)) -> readSigned readFloat str + _ -> [] p_js_string :: ReadP JSString p_js_string = toJSString <$$> p_string diff --git a/Text/JSON/String.hs b/Text/JSON/String.hs --- a/Text/JSON/String.hs +++ b/Text/JSON/String.hs @@ -30,17 +30,18 @@ , showJSTopType ) where +import Prelude hiding (fail) import Text.JSON.Types (JSValue(..), JSString, toJSString, fromJSString, JSObject, toJSObject, fromJSObject) import Control.Monad (liftM, ap) -import qualified Control.Monad.Fail as Fail +import Control.Monad.Fail (MonadFail (..)) import Control.Applicative((<$>)) import qualified Control.Applicative as A import Data.Char (isSpace, isDigit, digitToInt) import Data.Ratio (numerator, denominator, (%)) -import Numeric (readHex, readDec, showHex) +import Numeric (readHex, readDec, showHex, readSigned, readFloat) -- ----------------------------------------------------------------- -- | Parsing JSON @@ -59,7 +60,7 @@ Left err -> Left err Right (a,s1) -> un (f a) s1) -instance Fail.MonadFail GetJSON where +instance MonadFail GetJSON where fail x = GetJSON (\_ -> Left x) -- | Run a JSON reader on an input String, returning some Haskell value. @@ -152,50 +153,12 @@ readJSRational :: GetJSON Rational readJSRational = do cs <- getInput - case cs of - '-' : ds -> negate <$> pos ds - _ -> pos cs - - where - pos [] = fail $ "Unable to parse JSON Rational: " ++ context [] - pos (c:cs) = - case c of - '0' -> frac 0 cs - _ - | not (isDigit c) -> fail $ "Unable to parse JSON Rational: " ++ context cs - | otherwise -> readDigits (digitToIntI c) cs - - readDigits acc [] = frac (fromInteger acc) [] - readDigits acc (x:xs) - | isDigit x = let acc' = 10*acc + digitToIntI x in - acc' `seq` readDigits acc' xs - | otherwise = frac (fromInteger acc) (x:xs) - - frac n ('.' : ds) = - case span isDigit ds of - ([],_) -> setInput ds >> return n - (as,bs) -> let x = read as :: Integer - y = 10 ^ (fromIntegral (length as) :: Integer) - in exponent' (n + (x % y)) bs - frac n cs = exponent' n cs - - exponent' n (c:cs) - | c == 'e' || c == 'E' = (n*) <$> exp_num cs - exponent' n cs = setInput cs >> return n - - exp_num :: String -> GetJSON Rational - exp_num ('+':cs) = exp_digs cs - exp_num ('-':cs) = recip <$> exp_digs cs - exp_num cs = exp_digs cs - - exp_digs :: String -> GetJSON Rational - exp_digs cs = case readDec cs of - [(a,ds)] -> do setInput ds - return (fromIntegral ((10::Integer) ^ (a::Integer))) - _ -> fail $ "Unable to parse JSON exponential: " ++ context cs - - digitToIntI :: Char -> Integer - digitToIntI ch = fromIntegral (digitToInt ch) + case (reads cs, readSigned readFloat cs) of + ([(x,_)], _) + | isInfinite (x :: Double) -> + fail ("JSON Rational out of range: " ++ context cs) + (_, [(y,cs')]) -> setInput cs' >> return y + _ -> fail ("Unable to parse JSON Rational: " ++ context cs) -- | Read a list in JSON format diff --git a/json.cabal b/json.cabal --- a/json.cabal +++ b/json.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.4 name: json -version: 0.10 +version: 0.11 synopsis: Support for serialising Haskell to and from JSON description: JSON (JavaScript Object Notation) is a lightweight data-interchange @@ -11,15 +12,15 @@ This library provides a parser and pretty printer for converting between Haskell values and JSON. category: Web -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Galois Inc. maintainer: Iavor S. Diatchki (iavor.diatchki@gmail.com) Copyright: (c) 2007-2018 Galois Inc. -cabal-version: >= 1.6 build-type: Simple -extra-source-files: +extra-doc-files: CHANGES +extra-source-files: tests/GenericTest.hs tests/HUnit.hs tests/Makefile @@ -86,6 +87,7 @@ description: Encode Haskell maps as JSON dicts library + default-language: Haskell2010 exposed-modules: Text.JSON, Text.JSON.Types, Text.JSON.String, @@ -94,12 +96,12 @@ if flag(split-base) if flag(generic) - build-depends: base >=4 && <5, syb >= 0.3.3 + build-depends: base >=4.9 && <5, syb >= 0.3.3 exposed-modules: Text.JSON.Generic Cpp-Options: -DBASE_4 else - build-depends: base >= 3 + build-depends: base >= 3 && <4 build-depends: array, containers, bytestring, mtl, text