Skip to content
Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
418 lines (375 sloc) 13.2 KB
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
#if MIN_VERSION_ghc_prim(0,3,1)
{-# LANGUAGE MagicHash #-}
#endif
-- |
-- Module: Data.Aeson.Parser.Internal
-- Copyright: (c) 2011-2016 Bryan O'Sullivan
-- (c) 2011 MailRank, Inc.
-- License: BSD3
-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
-- Stability: experimental
-- Portability: portable
--
-- Efficiently and correctly parse a JSON string. The string must be
-- encoded as UTF-8.
module Data.Aeson.Parser.Internal
(
-- * Lazy parsers
json, jsonEOF
, value
, jstring
, jstring_
, scientific
-- * Strict parsers
, json', jsonEOF'
, value'
-- * Helpers
, decodeWith
, decodeStrictWith
, eitherDecodeWith
, eitherDecodeStrictWith
) where
import Prelude.Compat
import Control.Applicative ((<|>))
import Control.Monad (void, when)
import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))
import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Vector as Vector (Vector, empty, fromListN, reverse)
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.Lazy as L
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Lazy as L
import qualified Data.HashMap.Strict as H
import qualified Data.Scientific as Sci
import Data.Aeson.Parser.Unescape (unescapeText)
#if MIN_VERSION_ghc_prim(0,3,1)
import GHC.Base (Int#, (==#), isTrue#, word2Int#, orI#, andI#)
import GHC.Word (Word8(W8#))
import qualified Data.Text.Encoding as TE
#endif
#define BACKSLASH 92
#define CLOSE_CURLY 125
#define CLOSE_SQUARE 93
#define COMMA 44
#define DOUBLE_QUOTE 34
#define OPEN_CURLY 123
#define OPEN_SQUARE 91
#define C_0 48
#define C_9 57
#define C_A 65
#define C_F 70
#define C_a 97
#define C_f 102
#define C_n 110
#define C_t 116
-- | Parse a top-level JSON value.
--
-- The conversion of a parsed value to a Haskell value is deferred
-- until the Haskell value is needed. This may improve performance if
-- only a subset of the results of conversions are needed, but at a
-- cost in thunk allocation.
--
-- This function is an alias for 'value'. In aeson 0.8 and earlier, it
-- parsed only object or array types, in conformance with the
-- now-obsolete RFC 4627.
json :: Parser Value
json = value
-- | Parse a top-level JSON value.
--
-- This is a strict version of 'json' which avoids building up thunks
-- during parsing; it performs all conversions immediately. Prefer
-- this version if most of the JSON data needs to be accessed.
--
-- This function is an alias for 'value''. In aeson 0.8 and earlier, it
-- parsed only object or array types, in conformance with the
-- now-obsolete RFC 4627.
json' :: Parser Value
json' = value'
object_ :: Parser Value
object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value
object_' :: Parser Value
object_' = {-# SCC "object_'" #-} do
!vals <- objectValues jstring' value'
return (Object vals)
where
jstring' = do
!s <- jstring
return s
objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
objectValues str val = do
skipSpace
w <- A.peekWord8'
if w == CLOSE_CURLY
then A.anyWord8 >> return H.empty
else loop []
where
-- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'
-- and it's much faster because it's doing in place update to the 'HashMap'!
loop acc = do
k <- str <* skipSpace <* char ':'
v <- val <* skipSpace
ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_CURLY
let acc' = (k, v) : acc
if ch == COMMA
then skipSpace >> loop acc'
else return (H.fromList acc')
{-# INLINE objectValues #-}
array_ :: Parser Value
array_ = {-# SCC "array_" #-} Array <$> arrayValues value
array_' :: Parser Value
array_' = {-# SCC "array_'" #-} do
!vals <- arrayValues value'
return (Array vals)
arrayValues :: Parser Value -> Parser (Vector Value)
arrayValues val = do
skipSpace
w <- A.peekWord8'
if w == CLOSE_SQUARE
then A.anyWord8 >> return Vector.empty
else loop [] 1
where
loop acc !len = do
v <- val <* skipSpace
ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_SQUARE
if ch == COMMA
then skipSpace >> loop (v:acc) (len+1)
else return (Vector.reverse (Vector.fromListN len (v:acc)))
{-# INLINE arrayValues #-}
-- | Parse any JSON value. You should usually 'json' in preference to
-- this function, as this function relaxes the object-or-array
-- requirement of RFC 4627.
--
-- In particular, be careful in using this function if you think your
-- code might interoperate with Javascript. A na&#xef;ve Javascript
-- library that parses JSON data using @eval@ is vulnerable to attack
-- unless the encoded data represents an object or an array. JSON
-- implementations in other languages conform to that same restriction
-- to preserve interoperability and security.
value :: Parser Value
value = do
skipSpace
w <- A.peekWord8'
case w of
DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)
OPEN_CURLY -> A.anyWord8 *> object_
OPEN_SQUARE -> A.anyWord8 *> array_
C_f -> string "false" *> pure (Bool False)
C_t -> string "true" *> pure (Bool True)
C_n -> string "null" *> pure Null
_ | w >= 48 && w <= 57 || w == 45
-> Number <$> scientific
| otherwise -> fail "not a valid json value"
-- | Strict version of 'value'. See also 'json''.
value' :: Parser Value
value' = do
skipSpace
w <- A.peekWord8'
case w of
DOUBLE_QUOTE -> do
!s <- A.anyWord8 *> jstring_
return (String s)
OPEN_CURLY -> A.anyWord8 *> object_'
OPEN_SQUARE -> A.anyWord8 *> array_'
C_f -> string "false" *> pure (Bool False)
C_t -> string "true" *> pure (Bool True)
C_n -> string "null" *> pure Null
_ | w >= 48 && w <= 57 || w == 45
-> do
!n <- scientific
return (Number n)
| otherwise -> fail "not a valid json value"
-- | Parse a quoted JSON string.
jstring :: Parser Text
jstring = A.word8 DOUBLE_QUOTE *> jstring_
-- | Parse a string without a leading quote.
jstring_ :: Parser Text
{-# INLINE jstring_ #-}
jstring_ = {-# SCC "jstring_" #-} do
#if MIN_VERSION_ghc_prim(0,3,1)
(s, S _ escaped) <- A.runScanner startState go <* A.anyWord8
-- We escape only if there are
-- non-ascii (over 7bit) characters or backslash present.
--
-- Note: if/when text will have fast ascii -> text conversion
-- (e.g. uses utf8 encoding) we can have further speedup.
if isTrue# escaped
then case unescapeText s of
Right r -> return r
Left err -> fail $ show err
else return (TE.decodeUtf8 s)
where
startState = S 0# 0#
go (S skip escaped) (W8# c)
| isTrue# skip = Just (S 0# escaped')
| isTrue# (w ==# 34#) = Nothing -- double quote
| otherwise = Just (S skip' escaped')
where
w = word2Int# c
skip' = w ==# 92# -- backslash
escaped' = escaped
`orI#` (w `andI#` 0x80# ==# 0x80#) -- c >= 0x80
`orI#` skip'
`orI#` (w `andI#` 0x1f# ==# w) -- c < 0x20
data S = S Int# Int#
#else
s <- A.scan startState go <* A.anyWord8
case unescapeText s of
Right r -> return r
Left err -> fail $ show err
where
startState = False
go a c
| a = Just False
| c == DOUBLE_QUOTE = Nothing
| otherwise = let a' = c == backslash
in Just a'
where backslash = BACKSLASH
#endif
decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a
decodeWith p to s =
case L.parse p s of
L.Done _ v -> case to v of
Success a -> Just a
_ -> Nothing
_ -> Nothing
{-# INLINE decodeWith #-}
decodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString
-> Maybe a
decodeStrictWith p to s =
case either Error to (A.parseOnly p s) of
Success a -> Just a
_ -> Nothing
{-# INLINE decodeStrictWith #-}
eitherDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString
-> Either (JSONPath, String) a
eitherDecodeWith p to s =
case L.parse p s of
L.Done _ v -> case to v of
ISuccess a -> Right a
IError path msg -> Left (path, msg)
L.Fail _ _ msg -> Left ([], msg)
{-# INLINE eitherDecodeWith #-}
eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString
-> Either (JSONPath, String) a
eitherDecodeStrictWith p to s =
case either (IError []) to (A.parseOnly p s) of
ISuccess a -> Right a
IError path msg -> Left (path, msg)
{-# INLINE eitherDecodeStrictWith #-}
-- $lazy
--
-- The 'json' and 'value' parsers decouple identification from
-- conversion. Identification occurs immediately (so that an invalid
-- JSON document can be rejected as early as possible), but conversion
-- to a Haskell value is deferred until that value is needed.
--
-- This decoupling can be time-efficient if only a smallish subset of
-- elements in a JSON value need to be inspected, since the cost of
-- conversion is zero for uninspected elements. The trade off is an
-- increase in memory usage, due to allocation of thunks for values
-- that have not yet been converted.
-- $strict
--
-- The 'json'' and 'value'' parsers combine identification with
-- conversion. They consume more CPU cycles up front, but have a
-- smaller memory footprint.
-- | Parse a top-level JSON value followed by optional whitespace and
-- end-of-input. See also: 'json'.
jsonEOF :: Parser Value
jsonEOF = json <* skipSpace <* endOfInput
-- | Parse a top-level JSON value followed by optional whitespace and
-- end-of-input. See also: 'json''.
jsonEOF' :: Parser Value
jsonEOF' = json' <* skipSpace <* endOfInput
-- | The only valid whitespace in a JSON document is space, newline,
-- carriage return, and tab.
skipSpace :: Parser ()
skipSpace = A.skipWhile $ \w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09
{-# INLINE skipSpace #-}
------------------ Copy-pasted and adapted from attoparsec ------------------
-- A strict pair
data SP = SP !Integer {-# UNPACK #-}!Int
decimal0 :: Parser Integer
decimal0 = do
let zero = 48
digits <- A.takeWhile1 isDigit_w8
if B.length digits > 1 && B.unsafeHead digits == zero
then fail "leading zero"
else return (bsToInteger digits)
-- | Parse a JSON number.
scientific :: Parser Scientific
scientific = do
let minus = 45
plus = 43
sign <- A.peekWord8'
let !positive = sign == plus || sign /= minus
when (sign == plus || sign == minus) $
void A.anyWord8
n <- decimal0
let f fracDigits = SP (B.foldl' step n fracDigits)
(negate $ B.length fracDigits)
step a w = a * 10 + fromIntegral (w - 48)
dotty <- A.peekWord8
-- '.' -> ascii 46
SP c e <- case dotty of
Just 46 -> A.anyWord8 *> (f <$> A.takeWhile1 isDigit_w8)
_ -> pure (SP n 0)
let !signedCoeff | positive = c
| otherwise = -c
let littleE = 101
bigE = 69
(A.satisfy (\ex -> ex == littleE || ex == bigE) *>
fmap (Sci.scientific signedCoeff . (e +)) (signed decimal)) <|>
return (Sci.scientific signedCoeff e)
{-# INLINE scientific #-}
------------------ Copy-pasted and adapted from base ------------------------
bsToInteger :: B.ByteString -> Integer
bsToInteger bs
| l > 40 = valInteger 10 l [ fromIntegral (w - 48) | w <- B.unpack bs ]
| otherwise = bsToIntegerSimple bs
where
l = B.length bs
bsToIntegerSimple :: B.ByteString -> Integer
bsToIntegerSimple = B.foldl' step 0 where
step a b = a * 10 + fromIntegral (b - 48) -- 48 = '0'
-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b
-- digits are combined into a single radix b^2 digit. This process is
-- repeated until we are left with a single digit. This algorithm
-- performs well only on large inputs, so we use the simple algorithm
-- for smaller inputs.
valInteger :: Integer -> Int -> [Integer] -> Integer
valInteger = go
where
go :: Integer -> Int -> [Integer] -> Integer
go _ _ [] = 0
go _ _ [d] = d
go b l ds
| l > 40 = b' `seq` go b' l' (combine b ds')
| otherwise = valSimple b ds
where
-- ensure that we have an even number of digits
-- before we call combine:
ds' = if even l then ds else 0 : ds
b' = b * b
l' = (l + 1) `quot` 2
combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)
where
d = d1 * b + d2
combine _ [] = []
combine _ [_] = errorWithoutStackTrace "this should not happen"
-- The following algorithm is only linear for types whose Num operations
-- are in constant time.
valSimple :: Integer -> [Integer] -> Integer
valSimple base = go 0
where
go r [] = r
go r (d : ds) = r' `seq` go r' ds
where
r' = r * base + fromIntegral d
You can’t perform that action at this time.