@@ -0,0 +1,249 @@
1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2+
3+-- |
4+-- Module: Data.Aeson.Parser.Internal
5+-- Copyright: (c) 2011 MailRank, Inc.
6+-- License: Apache
7+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
8+-- Stability: experimental
9+-- Portability: portable
10+--
11+-- Efficiently and correctly parse a JSON string. The string must be
12+-- encoded as UTF-8.
13+
14+module Data.Aeson.Parser.Internal
15+ (
16+ -- * Lazy parsers
17+ json
18+ , value
19+ , jstring
20+ -- * Strict parsers
21+ , json'
22+ , value'
23+ -- * Helpers
24+ , decodeWith
25+ ) where
26+
27+import Blaze.ByteString.Builder (fromByteString, toByteString)
28+import Blaze.ByteString.Builder.Char.Utf8 (fromChar)
29+import Blaze.ByteString.Builder.Word (fromWord8)
30+import Control.Applicative as A
31+import Data.Aeson.Types (Result(..), Value(..))
32+import Data.Attoparsec.Char8 hiding (Result)
33+import Data.Bits ((.|.), shiftL)
34+import Data.ByteString as B
35+import Data.Char (chr)
36+import Data.Monoid (mappend, mempty)
37+import Data.Text as T
38+import Data.Text.Encoding (decodeUtf8)
39+import Data.Vector as Vector hiding ((++))
40+import Data.Word (Word8)
41+import qualified Data.Attoparsec as A
42+import qualified Data.Attoparsec.Lazy as L
43+import qualified Data.Attoparsec.Zepto as Z
44+import qualified Data.ByteString.Char8 as B8
45+import qualified Data.ByteString.Lazy as L
46+import qualified Data.ByteString.Unsafe as B
47+import qualified Data.HashMap.Strict as H
48+
49+-- | Parse a top-level JSON value. This must be either an object or
50+-- an array.
51+--
52+-- The conversion of parsed values to Haskell values is deferred.
53+-- This may improve performance if not all of the results of
54+-- conversions are needed, but at a cost in thunk allocation.
55+json :: Parser Value
56+json = json_ object_ array_
57+
58+-- | Parse a top-level JSON value. This must be either an object or
59+-- an array.
60+--
61+-- This is a strict version of 'json' which avoids building up thunks
62+-- during parsing; it performs all conversions immediately. Prefer
63+-- this version if most of the JSON data needs to be accessed.
64+json' :: Parser Value
65+json' = json_ object_' array_'
66+
67+json_ :: Parser Value -> Parser Value -> Parser Value
68+json_ obj ary = do
69+ w <- skipSpace *> A.satisfy (\w -> w == 123 || w == 91)
70+ if w == 123
71+ then obj
72+ else ary
73+{-# INLINE json_ #-}
74+
75+object_ :: Parser Value
76+object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value
77+
78+object_' :: Parser Value
79+object_' = {-# SCC "object_'" #-} do
80+ !vals <- objectValues jstring' value'
81+ return (Object vals)
82+ where
83+ jstring' = do
84+ !s <- jstring
85+ return s
86+
87+objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
88+objectValues str val = do
89+ skipSpace
90+ let pair = do
91+ a <- str <* skipSpace
92+ b <- char ':' *> skipSpace *> val
93+ return (a,b)
94+ vals <- ((pair <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char '}'
95+ return (H.fromList vals)
96+{-# INLINE objectValues #-}
97+
98+array_ :: Parser Value
99+array_ = {-# SCC "array_" #-} Array <$> arrayValues value
100+
101+array_' :: Parser Value
102+array_' = {-# SCC "array_'" #-} do
103+ !vals <- arrayValues value'
104+ return (Array vals)
105+
106+arrayValues :: Parser Value -> Parser (Vector Value)
107+arrayValues val = do
108+ skipSpace
109+ vals <- ((val <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char ']'
110+ return (Vector.fromList vals)
111+{-# INLINE arrayValues #-}
112+
113+-- | Parse any JSON value. You should usually 'json' in preference to
114+-- this function. This is only safe to use if you are parsing data
115+-- from an untrusted source.
116+value :: Parser Value
117+value = most <|> (Number <$> number)
118+ where
119+ most = do
120+ c <- satisfy (`B8.elem` "{[\"ftn")
121+ case c of
122+ '{' -> object_
123+ '[' -> array_
124+ '"' -> String <$> jstring_
125+ 'f' -> string "alse" *> pure (Bool False)
126+ 't' -> string "rue" *> pure (Bool True)
127+ 'n' -> string "ull" *> pure Null
128+ _ -> error "attoparsec panic! the impossible happened!"
129+
130+-- | Strict version of 'value'. See also 'json''.
131+value' :: Parser Value
132+value' = most <|> num
133+ where
134+ most = do
135+ c <- satisfy (`B8.elem` "{[\"ftn")
136+ case c of
137+ '{' -> object_'
138+ '[' -> array_'
139+ '"' -> do
140+ !s <- jstring_
141+ return (String s)
142+ 'f' -> string "alse" *> pure (Bool False)
143+ 't' -> string "rue" *> pure (Bool True)
144+ 'n' -> string "ull" *> pure Null
145+ _ -> error "attoparsec panic! the impossible happened!"
146+ num = do
147+ !n <- number
148+ return (Number n)
149+
150+doubleQuote, backslash :: Word8
151+doubleQuote = 34
152+backslash = 92
153+{-# INLINE backslash #-}
154+{-# INLINE doubleQuote #-}
155+
156+-- | Parse a quoted JSON string.
157+jstring :: Parser Text
158+jstring = A.word8 doubleQuote *> jstring_
159+
160+-- | Parse a string without a leading quote.
161+jstring_ :: Parser Text
162+jstring_ = {-# SCC "jstring_" #-} do
163+ s <- A.scan False $ \s c -> if s then Just False
164+ else if c == doubleQuote
165+ then Nothing
166+ else Just (c == backslash)
167+ _ <- A.word8 doubleQuote
168+ if backslash `B.elem` s
169+ then case Z.parse unescape s of
170+ Right r -> return (decodeUtf8 r)
171+ Left err -> fail err
172+ else return (decodeUtf8 s)
173+{-# INLINE jstring_ #-}
174+
175+unescape :: Z.Parser ByteString
176+unescape = toByteString <$> go mempty where
177+ go acc = do
178+ h <- Z.takeWhile (/=backslash)
179+ let rest = do
180+ start <- Z.take 2
181+ let !slash = B.unsafeHead start
182+ !t = B.unsafeIndex start 1
183+ escape = case B.findIndex (==t) "\"\\/ntbrfu" of
184+ Just i -> i
185+ _ -> 255
186+ if slash /= backslash || escape == 255
187+ then fail "invalid JSON escape sequence"
188+ else do
189+ let cont m = go (acc `mappend` fromByteString h `mappend` m)
190+ {-# INLINE cont #-}
191+ if t /= 117 -- 'u'
192+ then cont (fromWord8 (B.unsafeIndex mapping escape))
193+ else do
194+ a <- hexQuad
195+ if a < 0xd800 || a > 0xdfff
196+ then cont (fromChar (chr a))
197+ else do
198+ b <- Z.string "\\u" *> hexQuad
199+ if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff
200+ then let !c = ((a - 0xd800) `shiftL` 10) +
201+ (b - 0xdc00) + 0x10000
202+ in cont (fromChar (chr c))
203+ else fail "invalid UTF-16 surrogates"
204+ done <- Z.atEnd
205+ if done
206+ then return (acc `mappend` fromByteString h)
207+ else rest
208+ mapping = "\"\\/\n\t\b\r\f"
209+
210+hexQuad :: Z.Parser Int
211+hexQuad = do
212+ s <- Z.take 4
213+ let hex n | w >= 48 && w <= 57 = w - 48
214+ | w >= 97 && w <= 122 = w - 87
215+ | w >= 65 && w <= 90 = w - 55
216+ | otherwise = 255
217+ where w = fromIntegral $ B.unsafeIndex s n
218+ a = hex 0; b = hex 1; c = hex 2; d = hex 3
219+ if (a .|. b .|. c .|. d) /= 255
220+ then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)
221+ else fail "invalid hex escape"
222+
223+decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a
224+decodeWith p to s =
225+ case L.parse p s of
226+ L.Done _ v -> case to v of
227+ Success a -> Just a
228+ _ -> Nothing
229+ _ -> Nothing
230+{-# INLINE decodeWith #-}
231+
232+-- $lazy
233+--
234+-- The 'json' and 'value' parsers decouple identification from
235+-- conversion. Identification occurs immediately (so that an invalid
236+-- JSON document can be rejected as early as possible), but conversion
237+-- to a Haskell value is deferred until that value is needed.
238+--
239+-- This decoupling can be time-efficient if only a smallish subset of
240+-- elements in a JSON value need to be inspected, since the cost of
241+-- conversion is zero for uninspected elements. The trade off is an
242+-- increase in memory usage, due to allocation of thunks for values
243+-- that have not yet been converted.
244+
245+-- $strict
246+--
247+-- The 'json'' and 'value'' parsers combine identification with
248+-- conversion. They consume more CPU cycles up front, but have a
249+-- smaller memory footprint.