git.iko.soy/typeable/aeson
on 0.3.2.4 help sign in
typeable/aeson/Data/Aeson/Parser.hs
150 lines 4.9 kB history raw
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
3-- |
4-- Module: Data.Aeson.Parser
5-- Copyright: (c) 2011 MailRank, Inc.
6-- License: Apache
7-- Maintainer: Bryan O'Sullivan <bos@mailrank.com>
8-- Stability: experimental
9-- Portability: portable
10--
11-- Efficiently and correctly parse a JSON string.
13module Data.Aeson.Parser
14 (
15 json
16 , value
17 ) where
19import Blaze.ByteString.Builder (fromByteString, toByteString)
20import Blaze.ByteString.Builder.Char.Utf8 (fromChar)
21import Blaze.ByteString.Builder.Word (fromWord8)
22import Control.Applicative as A
23import Data.Aeson.Types (Value(..))
24import Data.Attoparsec.Char8
25import Data.Bits ((.|.), shiftL)
26import Data.ByteString as B
27import Data.Char (chr)
28import Data.Map as Map
29import Data.Monoid (mappend, mempty)
30import Data.Text as T
31import Data.Text.Encoding (decodeUtf8)
32import Data.Vector as Vector hiding ((++))
33import Data.Word (Word8)
34import qualified Data.Attoparsec as A
35import qualified Data.Attoparsec.Zepto as Z
36import qualified Data.ByteString.Unsafe as B
38-- | Parse a top-level JSON value. This must be either an object or
39-- an array.
40json :: Parser Value
41json = do
42 c <- skipSpace *> anyChar
43 case c of
44 '{' -> object_
45 '[' -> array_
46 _ -> fail "root value is not an object or array"
48object_ :: Parser Value
49object_ = {-# SCC "object_" #-} do
50 skipSpace
51 let pair = do
52 a <- jstring <* skipSpace
53 b <- char ':' *> skipSpace *> value
54 return (a,b)
55 vals <- ((pair <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char '}'
56 return . Object $ Map.fromList vals
58array_ :: Parser Value
59array_ = {-# SCC "array_" #-} do
60 skipSpace
61 vals <- ((value <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char ']'
62 return . Array $ Vector.fromList vals
64-- | Parse any JSON value. Use 'json' in preference to this function
65-- if you are parsing data from an untrusted source.
66value :: Parser Value
67value = most <|> (Number <$> number)
68 where
69 most = do
70 c <- anyChar
71 case c of
72 '{' -> object_
73 '[' -> array_
74 '"' -> String <$> jstring_
75 'f' -> string "alse" *> pure (Bool False)
76 't' -> string "rue" *> pure (Bool True)
77 'n' -> string "ull" *> pure Null
78 _ -> fail "not a valid JSON value"
80doubleQuote, backslash :: Word8
81doubleQuote = 34
82backslash = 92
83{-# INLINE backslash #-}
84{-# INLINE doubleQuote #-}
86jstring :: Parser Text
87jstring = A.word8 doubleQuote *> jstring_
89-- | Parse a string without a leading quote.
90jstring_ :: Parser Text
91jstring_ = {-# SCC "jstring_" #-} do
92 s <- A.scan False $ \s c -> if s then Just False
93 else if c == doubleQuote
94 then Nothing
95 else Just (c == backslash)
96 _ <- A.word8 doubleQuote
97 if backslash `B.elem` s
98 then case Z.parse unescape s of
99 Right r -> return (decodeUtf8 r)
100 Left err -> fail err
101 else return (decodeUtf8 s)
102{-# INLINE jstring_ #-}
104unescape :: Z.Parser ByteString
105unescape = toByteString <$> go mempty where
106 go acc = do
107 h <- Z.takeWhile (/=backslash)
108 let rest = do
109 start <- Z.take 2
110 let !slash = B.unsafeHead start
111 !t = B.unsafeIndex start 1
112 escape = case B.findIndex (==t) "\"\\/ntbrfu" of
113 Just i -> i
114 _ -> 255
115 if slash /= backslash || escape == 255
116 then fail "invalid JSON escape sequence"
117 else do
118 let cont m = go (acc `mappend` fromByteString h `mappend` m)
119 {-# INLINE cont #-}
120 if t /= 117 -- 'u'
121 then cont (fromWord8 (B.unsafeIndex mapping escape))
122 else do
123 a <- hexQuad
124 if a < 0xd800 || a > 0xdfff
125 then cont (fromChar (chr a))
126 else do
127 b <- Z.string "\\u" *> hexQuad
128 if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff
129 then let !c = ((a - 0xd800) `shiftL` 10) +
130 (b - 0xdc00) + 0x10000
131 in cont (fromChar (chr c))
132 else fail "invalid UTF-16 surrogates"
133 done <- Z.atEnd
134 if done
135 then return (acc `mappend` fromByteString h)
136 else rest
137 mapping = "\"\\/\n\t\b\r\f"
139hexQuad :: Z.Parser Int
140hexQuad = do
141 s <- Z.take 4
142 let hex n | w >= 48 && w <= 57 = w - 48
143 | w >= 97 && w <= 122 = w - 87
144 | w >= 65 && w <= 90 = w - 55
145 | otherwise = 255
146 where w = fromIntegral $ B.unsafeIndex s n
147 a = hex 0; b = hex 1; c = hex 2; d = hex 3
148 if (a .|. b .|. c .|. d) /= 255
149 then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)
150 else fail "invalid hex escape"