diff --git a/Data/Aeson.hs b/Data/Aeson.hs --- a/Data/Aeson.hs +++ b/Data/Aeson.hs @@ -1,6 +1,6 @@ -- | -- Module: Data.Aeson --- Copyright: (c) 2011 Bryan O'Sullivan +-- Copyright: (c) 2011, 2012 Bryan O'Sullivan -- (c) 2011 MailRank, Inc. -- License: Apache -- Maintainer: Bryan O'Sullivan @@ -13,9 +13,30 @@ module Data.Aeson ( + -- * How to use this library + -- $use + + -- ** Working with the AST + -- $ast + + -- ** Decoding to a Haskell value + -- $haskell + + -- ** Decoding a mixed-type object + -- $mixed + + -- ** Automatically decoding data types + -- $typeable + + -- ** Pitfalls + -- $pitfalls + -- * Encoding and decoding + -- $encoding_and_decoding decode , decode' + , eitherDecode + , eitherDecode' , encode -- * Core JSON types , Value(..) @@ -28,6 +49,12 @@ , Result(..) , fromJSON , ToJSON(..) + -- * Inspecting @'Value's@ + , withObject + , withText + , withArray + , withNumber + , withBool -- * Constructors and accessors , (.=) , (.:) @@ -40,7 +67,7 @@ ) where import Data.Aeson.Encode (encode) -import Data.Aeson.Parser.Internal (decodeWith, json, json') +import Data.Aeson.Parser.Internal (decodeWith, eitherDecodeWith, json, json') import Data.Aeson.Types import qualified Data.ByteString.Lazy as L @@ -63,3 +90,229 @@ decode' :: (FromJSON a) => L.ByteString -> Maybe a decode' = decodeWith json' fromJSON {-# INLINE decode' #-} + +-- | Like 'decode' but returns an error message when decoding fails. +eitherDecode :: (FromJSON a) => L.ByteString -> Either String a +eitherDecode = eitherDecodeWith json fromJSON +{-# INLINE eitherDecode #-} + +-- | Like 'decode'' but returns an error message when decoding fails. +eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a +eitherDecode' = eitherDecodeWith json' fromJSON +{-# INLINE eitherDecode' #-} + +-- $use +-- +-- This section contains basic information on the different ways to +-- decode data using this library. These range from simple but +-- inflexible, to complex but flexible. +-- +-- The most common way to use the library is to define a data type, +-- corresponding to some JSON data you want to work with, and then +-- write either a 'FromJSON' instance, a to 'ToJSON' instance, or both +-- for that type. For example, given this JSON data: +-- +-- > { "name": "Joe", "age": 12 } +-- +-- we create a matching data type: +-- +-- > data Person = Person +-- > { name :: Text +-- > , age :: Int +-- > } deriving Show- +-- +-- To decode data, we need to define a 'FromJSON' instance: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > instance FromJSON Coord where +-- > parseJSON (Object v) = Person <$> +-- > v .: "name" <*> +-- > v .: "age" +-- > -- A non-Object value is of the wrong type, so fail. +-- > parseJSON _ = mzero +-- +-- We can now parse the JSON data like so: +-- +-- > >>> decode "{\"name\":\"Joe\",\"age\":12}" :: Maybe Person +-- > Just (Person {name = "Joe", age = 12}) +-- +-- To encode data, we need to define a 'ToJSON' instance: +-- +-- > instance ToJSON Person where +-- > toJSON (Person name age) = object ["name" .= name, "age" .= age] +-- +-- We can now encode a value like so: +-- +-- > >>> encode (Person {name = "Joe", age = 12}) +-- > "{\"name\":\"Joe\",\"age\":12}" +-- +-- There are predefined 'FromJSON' and 'ToJSON' instances for many +-- types. Here's an example using lists and 'Int's: +-- +-- > >>> decode "[1,2,3]" :: Maybe [Int] +-- > Just [1,2,3] +-- +-- And here's an example using the 'Data.Map.Map' type to get a map of +-- 'Int's. +-- +-- > >>> decode "{\"foo\":1,\"bar\":2}" :: Maybe (Map String Int) +-- > Just (fromList [("bar",2),("foo",1)]) + +-- While the notes below focus on decoding, you can apply almost the +-- same techniques to /encoding/ data. (The main difference is that +-- encoding always succeeds, but decoding has to handle the +-- possibility of failure, where an input doesn't match our +-- expectations.) +-- +-- See the documentation of 'FromJSON' and 'ToJSON' for some examples +-- of how you can automatically derive instances in some +-- circumstances. + +-- $ast +-- +-- Sometimes you want to work with JSON data directly, without first +-- converting it to a custom data type. This can be useful if you want +-- to e.g. convert JSON data to YAML data, without knowing what the +-- contents of the original JSON data was. The 'Value' type, which is +-- an instance of 'FromJSON', is used to represent an arbitrary JSON +-- AST (abstract syntax tree). Example usage: +-- +-- > >>> decode "{\"foo\": 123}" :: Maybe Value +-- > Just (Object (fromList [("foo",Number 123)])) +-- +-- > >>> decode "{\"foo\": [\"abc\",\"def\"]}" :: Maybe Value +-- > Just (Object (fromList [("foo",Array (fromList [String "abc",String "def"]))])) +-- +-- Once you have a 'Value' you can write functions to traverse it and +-- make arbitrary transformations. + +-- $haskell +-- +-- Any instance of 'FromJSON' can be specified (but see the +-- \"Pitfalls\" section here—"Data.Aeson#pitfalls"): +-- +-- > λ> decode "[1,2,3]" :: Maybe [Int] +-- > Just [1,2,3] +-- +-- Alternatively, there are instances for standard data types, so you +-- can use them directly. For example, use the 'Data.Map.Map' type to +-- get a map of 'Int's. +-- +-- > λ> :m + Data.Map +-- > λ> decode "{\"foo\":1,\"bar\":2}" :: Maybe (Map String Int) +-- > Just (fromList [("bar",2),("foo",1)]) + +-- $mixed +-- +-- The above approach with maps of course will not work for mixed-type +-- objects that don't follow a strict schema, but there are a couple +-- of approaches available for these. +-- +-- The 'Object' type contains JSON objects: +-- +-- > λ> decode "{\"name\":\"Dave\",\"age\":2}" :: Maybe Object +-- > Just (fromList) [("name",String "Dave"),("age",Number 2)] +-- +-- You can extract values from it with a parser using 'parse', +-- 'parseEither' or, in this example, 'parseMaybe': +-- +-- > λ> do result <- decode "{\"name\":\"Dave\",\"age\":2}" +-- > flip parseMaybe result $ \obj -> do +-- > age <- obj .: "age" +-- > name <- obj .: "name" +-- > return (name ++ ": " ++ show (age*2)) +-- > +-- > Just "Dave: 4" +-- +-- Considering that any type that implements 'FromJSON' can be used +-- here, this is quite a powerful way to parse JSON. See the +-- documentation in 'FromJSON' for how to implement this class for +-- your own data types. +-- +-- The downside is that you have to write the parser yourself; the +-- upside is that you have complete control over the way the JSON is +-- parsed. + +-- $typeable +-- +-- If you don't want fine control and would prefer the JSON be parsed +-- to your own data types automatically according to some reasonably +-- sensible isomorphic implementation, you can use the generic parser +-- based on 'Data.Typeable.Typeable' and 'Data.Data.Data'. Switch to +-- the 'Data.Aeson.Generic' module, and you can do the following: +-- +-- > λ> decode "[1]" :: Maybe [Int] +-- > Just [1] +-- > λ> :m + Data.Typeable Data.Data +-- > λ> :set -XDeriveDataTypeable +-- > λ> data Person = Person { personName :: String, personAge :: Int } deriving (Data,Typeable,Show) +-- > λ> encode Person { personName = "Chris", personAge = 123 } +-- > "{\"personAge\":123,\"personName\":\"Chris\"}" +-- > λ> decode "{\"personAge\":123,\"personName\":\"Chris\"}" :: Maybe Person +-- > Just (Person { +-- > personName = "Chris", personAge = 123 +-- > }) +-- +-- Be aware that the encoding may not always be what you'd naively +-- expect: +-- +-- > λ> data Foo = Foo Int Int deriving (Data,Typeable,Show) +-- > λ> encode (Foo 1 2) +-- > "[1,2]" +-- +-- With this approach, it's best to treat the +-- 'Data.Aeson.Generic.decode' and 'Data.Aeson.Generic.encode' +-- functions as an isomorphism, and not to rely upon (or care about) +-- the specific intermediate representation. + +-- $pitfalls +-- #pitfalls# +-- +-- Note that the JSON standard only allows arrays or objects of things +-- at the top-level. Since this library follows the standard, calling +-- 'decode' on an unsupported result type will typecheck, but will +-- always \"fail\": +-- +-- > >>> decode "1" :: Maybe Int +-- > Nothing +-- > >>> decode "1" :: Maybe String +-- > Nothing +-- +-- So stick to objects (e.g. maps in Haskell) or arrays (lists or +-- vectors in Haskell): +-- +-- > >>> decode "[1,2,3]" :: Maybe [Int] +-- > Just [1,2,3] +-- +-- When encoding to JSON you can encode anything that's an instance of +-- 'ToJSON', and this may include simple types. So beware that this +-- aspect of the API is not isomorphic. You can round-trip arrays and +-- maps, but not simple values: +-- +-- > >>> encode [1,2,3] +-- > "[1,2,3]" +-- > >>> decode (encode [1]) :: Maybe [Int] +-- > Just [1] +-- > >>> encode 1 +-- > "1" +-- > >>> decode (encode (1 :: Int)) :: Maybe Int +-- > Nothing +-- +-- Alternatively, see 'Data.Aeson.Parser.value' to parse non-top-level +-- JSON values. + +-- $encoding_and_decoding +-- +-- Encoding and decoding are each two-step processes. +-- +-- * To encode a value, it is first converted to an abstract syntax +-- tree (AST), using 'ToJSON'. This generic representation is then +-- encoded as bytes. +-- +-- * When decoding a value, the process is reversed: the bytes are +-- converted to an AST, then the 'FromJSON' class is used to convert +-- to the desired type. +-- +-- For convenience, the 'encode' and +-- 'decode' functions combine both steps for convenience. diff --git a/Data/Aeson/Encode.hs b/Data/Aeson/Encode.hs --- a/Data/Aeson/Encode.hs +++ b/Data/Aeson/Encode.hs @@ -2,7 +2,8 @@ -- | -- Module: Data.Aeson.Encode --- Copyright: (c) 2011 MailRank, Inc. +-- Copyright: (c) 2012 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. -- License: Apache -- Maintainer: Bryan O'Sullivan -- Stability: experimental @@ -62,15 +63,25 @@ string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"' where quote q = case T.uncons t of - Nothing -> fromText h + Nothing -> fromText h Just (!c,t') -> fromText h <> escape c <> quote t' where (h,t) = {-# SCC "break" #-} T.break isEscape q - isEscape c = c == '\"' || c == '\\' || c < '\x20' + isEscape c = c == '\"' || + c == '\\' || + c == '<' || + c == '>' || + c < '\x20' escape '\"' = "\\\"" escape '\\' = "\\\\" escape '\n' = "\\n" escape '\r' = "\\r" escape '\t' = "\\t" + + -- The following prevents untrusted JSON strings containing or --> + -- from causing an XSS vulnerability: + escape '<' = "\\u003c" + escape '>' = "\\u003e" + escape c | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h | otherwise = singleton c diff --git a/Data/Aeson/Functions.hs b/Data/Aeson/Functions.hs --- a/Data/Aeson/Functions.hs +++ b/Data/Aeson/Functions.hs @@ -1,6 +1,6 @@ -- | -- Module: Data.Aeson.Functions --- Copyright: (c) 2011 Bryan O'Sullivan +-- Copyright: (c) 2011, 2012 Bryan O'Sullivan -- (c) 2011 MailRank, Inc. -- License: Apache -- Maintainer: Bryan O'Sullivan diff --git a/Data/Aeson/Generic.hs b/Data/Aeson/Generic.hs --- a/Data/Aeson/Generic.hs +++ b/Data/Aeson/Generic.hs @@ -2,7 +2,7 @@ -- | -- Module: Data.Aeson.Generic --- Copyright: (c) 2011 Bryan O'Sullivan +-- Copyright: (c) 2011, 2012 Bryan O'Sullivan -- (c) 2011 MailRank, Inc. -- (c) 2008, 2009 Lennart Augustsson -- License: BSD3 @@ -290,6 +290,7 @@ decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0 (constrFields c0) where + go 0 c _ Null = construct c [] go 1 c [] jd = construct c [jd] -- unary constructor go _ c [] (Array js) = construct c (V.toList js) -- no field names -- FIXME? We could allow reading an array into a constructor diff --git a/Data/Aeson/Parser.hs b/Data/Aeson/Parser.hs --- a/Data/Aeson/Parser.hs +++ b/Data/Aeson/Parser.hs @@ -2,7 +2,8 @@ -- | -- Module: Data.Aeson.Parser --- Copyright: (c) 2011 MailRank, Inc. +-- Copyright: (c) 2012 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. -- License: Apache -- Maintainer: Bryan O'Sullivan -- Stability: experimental diff --git a/Data/Aeson/Parser/Internal.hs b/Data/Aeson/Parser/Internal.hs --- a/Data/Aeson/Parser/Internal.hs +++ b/Data/Aeson/Parser/Internal.hs @@ -2,7 +2,7 @@ -- | -- Module: Data.Aeson.Parser.Internal --- Copyright: (c) 2011 Bryan O'Sullivan +-- Copyright: (c) 2011, 2012 Bryan O'Sullivan -- (c) 2011 MailRank, Inc. -- License: Apache -- Maintainer: Bryan O'Sullivan @@ -23,6 +23,7 @@ , value' -- * Helpers , decodeWith + , eitherDecodeWith ) where import Blaze.ByteString.Builder (fromByteString, toByteString) @@ -237,6 +238,15 @@ _ -> Nothing _ -> Nothing {-# INLINE decodeWith #-} + +eitherDecodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Either String a +eitherDecodeWith p to s = + case L.parse p s of + L.Done _ v -> case to v of + Success a -> Right a + Error msg -> Left msg + L.Fail _ _ msg -> Left msg +{-# INLINE eitherDecodeWith #-} -- $lazy -- diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs --- a/Data/Aeson/TH.hs +++ b/Data/Aeson/TH.hs @@ -2,7 +2,7 @@ {-| Module: Data.Aeson.TH -Copyright: (c) 2011 Bryan O'Sullivan +Copyright: (c) 2011, 2012 Bryan O'Sullivan (c) 2011 MailRank, Inc. License: Apache Stability: experimental @@ -46,7 +46,7 @@ instance 'ToJSON' a => 'ToJSON' (D a) where 'toJSON' = - \value -> + \\value -> case value of Nullary -> 'object' [T.pack \"Nullary\" .= 'toJSON' ([] :: [()])] @@ -73,7 +73,7 @@ @ instance 'FromJSON' a => 'FromJSON' (D a) where 'parseJSON' = - \value -> + \\value -> case value of 'Object' obj -> case H.toList obj of @@ -234,7 +234,7 @@ -- @ -- instance 'ToJSON' Foo where -- 'toJSON' = --- \value -> case value of +-- \\value -> case value of -- Foo arg1 arg2 -> 'Array' $ 'V.create' $ do -- mv <- 'VM.unsafeNew' 2 -- 'VM.unsafeWrite' mv 0 ('toJSON' arg1) @@ -281,7 +281,7 @@ -- This will splice in the following code: -- -- @ --- \value -> case value of Foo arg1 -> 'toJSON' arg1 +-- \\value -> case value of Foo arg1 -> 'toJSON' arg1 -- @ mkToJSON :: (String -> String) -- ^ Function to change field names. -> Name -- ^ Name of the type to encode. @@ -406,7 +406,7 @@ -- @ -- instance 'FromJSON' Foo where -- 'parseJSON' = --- \value -> case value of +-- \\value -> case value of -- 'Array' arr -> -- if (V.length arr == 2) -- then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0) diff --git a/Data/Aeson/Types.hs b/Data/Aeson/Types.hs --- a/Data/Aeson/Types.hs +++ b/Data/Aeson/Types.hs @@ -2,7 +2,7 @@ -- | -- Module: Data.Aeson.Types --- Copyright: (c) 2011 Bryan O'Sullivan +-- Copyright: (c) 2011, 2012 Bryan O'Sullivan -- (c) 2011 MailRank, Inc. -- License: Apache -- Maintainer: Bryan O'Sullivan @@ -32,6 +32,14 @@ , parseEither , parseMaybe , ToJSON(..) + + -- * Inspecting @'Value's@ + , withObject + , withText + , withArray + , withNumber + , withBool + -- * Constructors and accessors , (.=) , (.:) diff --git a/Data/Aeson/Types/Class.hs b/Data/Aeson/Types/Class.hs --- a/Data/Aeson/Types/Class.hs +++ b/Data/Aeson/Types/Class.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances, OverloadedStrings, UndecidableInstances, ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} #ifdef GENERICS {-# LANGUAGE DefaultSignatures #-} @@ -8,7 +9,7 @@ -- | -- Module: Data.Aeson.Types.Class --- Copyright: (c) 2011 Bryan O'Sullivan +-- Copyright: (c) 2011, 2012 Bryan O'Sullivan -- (c) 2011 MailRank, Inc. -- License: Apache -- Maintainer: Bryan O'Sullivan @@ -30,6 +31,14 @@ #endif -- * Types , DotNetTime(..) + + -- * Inspecting @'Value's@ + , withObject + , withText + , withArray + , withNumber + , withBool + -- * Functions , fromJSON , (.:) @@ -39,18 +48,19 @@ , typeMismatch ) where -import Control.Applicative ((<$>), (<*>), pure) +import Control.Applicative ((<$>), (<*>), (<|>), pure, empty) import Data.Aeson.Functions import Data.Aeson.Types.Internal import Data.Attoparsec.Char8 (Number(..)) +import Data.Fixed import Data.Hashable (Hashable(..)) import Data.Int (Int8, Int16, Int32, Int64) import Data.Maybe (fromMaybe) -import Data.Monoid (Dual(..), First(..), Last(..)) +import Data.Monoid (Dual(..), First(..), Last(..), mappend) import Data.Ratio (Ratio) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8) -import Data.Time.Clock (UTCTime) +import Data.Time (UTCTime, ZonedTime(..), TimeZone(..)) import Data.Time.Format (FormatTime, formatTime, parseTime) import Data.Traversable (traverse) import Data.Typeable (Typeable) @@ -111,8 +121,8 @@ -- type which is an instance of 'Data'. -- -- * If your compiler has support for the @DeriveGeneric@ and --- @DefaultSignatures@ language extensions, @toJSON@ will have a default generic --- implementation. +-- @DefaultSignatures@ language extensions (GHC 7.2 and newer), +-- @toJSON@ will have a default generic implementation. -- -- To use the latter option, simply add a @deriving 'Generic'@ clause to your -- datatype and declare a @ToJSON@ instance for your datatype without giving a @@ -228,8 +238,7 @@ {-# INLINE toJSON #-} instance FromJSON Bool where - parseJSON (Bool b) = pure b - parseJSON v = typeMismatch "Bool" v + parseJSON = withBool "Bool" pure {-# INLINE parseJSON #-} instance ToJSON () where @@ -237,8 +246,10 @@ {-# INLINE toJSON #-} instance FromJSON () where - parseJSON (Array v) | V.null v = pure () - parseJSON v = typeMismatch "()" v + parseJSON = withArray "()" $ \v -> + if V.null v + then pure () + else fail "Expected an empty array" {-# INLINE parseJSON #-} instance ToJSON [Char] where @@ -246,8 +257,7 @@ {-# INLINE toJSON #-} instance FromJSON [Char] where - parseJSON (String t) = pure (T.unpack t) - parseJSON v = typeMismatch "String" v + parseJSON = withText "String" $ pure . T.unpack {-# INLINE parseJSON #-} instance ToJSON Char where @@ -255,9 +265,10 @@ {-# INLINE toJSON #-} instance FromJSON Char where - parseJSON (String t) - | T.compareLength t 1 == EQ = pure (T.head t) - parseJSON v = typeMismatch "Char" v + parseJSON = withText "Char" $ \t -> + if T.compareLength t 1 == EQ + then pure $ T.head t + else fail "Expected a string of length 1" {-# INLINE parseJSON #-} instance ToJSON Double where @@ -299,10 +310,21 @@ {-# INLINE toJSON #-} instance FromJSON (Ratio Integer) where + parseJSON = withNumber "Ration Integer" $ \n -> + pure $ case n of + D d -> toRational d + I i -> fromIntegral i + {-# INLINE parseJSON #-} + +instance HasResolution a => ToJSON (Fixed a) where + toJSON = Number . realToFrac + {-# INLINE toJSON #-} + +instance HasResolution a => FromJSON (Fixed a) where parseJSON (Number n) = pure $ case n of - D d -> toRational d + D d -> realToFrac d I i -> fromIntegral i - parseJSON v = typeMismatch "Ratio Integer" v + parseJSON v = typeMismatch "Fixed" v {-# INLINE parseJSON #-} instance ToJSON Int where @@ -314,8 +336,7 @@ {-# INLINE parseJSON #-} parseIntegral :: Integral a => Value -> Parser a -parseIntegral (Number n) = pure (floor n) -parseIntegral v = typeMismatch "Integral" v +parseIntegral = withNumber "Integral" $ pure . floor {-# INLINE parseIntegral #-} instance ToJSON Integer where @@ -403,8 +424,7 @@ {-# INLINE toJSON #-} instance FromJSON Text where - parseJSON (String t) = pure t - parseJSON v = typeMismatch "Text" v + parseJSON = withText "Text" pure {-# INLINE parseJSON #-} instance ToJSON LT.Text where @@ -412,8 +432,7 @@ {-# INLINE toJSON #-} instance FromJSON LT.Text where - parseJSON (String t) = pure (LT.fromStrict t) - parseJSON v = typeMismatch "Lazy Text" v + parseJSON = withText "Lazy Text" $ pure . LT.fromStrict {-# INLINE parseJSON #-} instance ToJSON B.ByteString where @@ -421,8 +440,7 @@ {-# INLINE toJSON #-} instance FromJSON B.ByteString where - parseJSON (String t) = pure . encodeUtf8 $ t - parseJSON v = typeMismatch "ByteString" v + parseJSON = withText "ByteString" $ pure . encodeUtf8 {-# INLINE parseJSON #-} instance ToJSON LB.ByteString where @@ -430,8 +448,7 @@ {-# INLINE toJSON #-} instance FromJSON LB.ByteString where - parseJSON (String t) = pure . lazy $ t - parseJSON v = typeMismatch "Lazy ByteString" v + parseJSON = withText "Lazy ByteString" $ pure . lazy {-# INLINE parseJSON #-} instance (ToJSON a) => ToJSON [a] where @@ -439,8 +456,7 @@ {-# INLINE toJSON #-} instance (FromJSON a) => FromJSON [a] where - parseJSON (Array a) = mapM parseJSON (V.toList a) - parseJSON v = typeMismatch "[a]" v + parseJSON = withArray "[a]" $ mapM parseJSON . V.toList {-# INLINE parseJSON #-} instance (ToJSON a) => ToJSON (Vector a) where @@ -448,8 +464,7 @@ {-# INLINE toJSON #-} instance (FromJSON a) => FromJSON (Vector a) where - parseJSON (Array a) = V.mapM parseJSON a - parseJSON v = typeMismatch "Vector a" v + parseJSON = withArray "Vector a" $ V.mapM parseJSON {-# INLINE parseJSON #-} vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value @@ -457,8 +472,7 @@ {-# INLINE vectorToJSON #-} vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a) -vectorParseJSON _ (Array a) = V.convert <$> V.mapM parseJSON a -vectorParseJSON s v = typeMismatch s v +vectorParseJSON s = withArray s $ fmap V.convert . V.mapM parseJSON {-# INLINE vectorParseJSON #-} instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where @@ -516,8 +530,8 @@ {-# INLINE toJSON #-} instance (FromJSON v) => FromJSON (M.Map Text v) where - parseJSON (Object o) = H.foldrWithKey M.insert M.empty <$> traverse parseJSON o - parseJSON v = typeMismatch "Map Text a" v + parseJSON = withObject "Map Text a" $ + fmap (H.foldrWithKey M.insert M.empty) . traverse parseJSON instance (ToJSON v) => ToJSON (M.Map LT.Text v) where toJSON = Object . mapHashKeyVal LT.toStrict toJSON @@ -548,8 +562,7 @@ {-# INLINE toJSON #-} instance (FromJSON v) => FromJSON (H.HashMap Text v) where - parseJSON (Object o) = traverse parseJSON o - parseJSON v = typeMismatch "HashMap Text a" v + parseJSON = withObject "HashMap Text a" $ traverse parseJSON instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where toJSON = Object . mapKeyVal LT.toStrict toJSON @@ -602,26 +615,53 @@ {-# INLINE toJSON #-} instance FromJSON DotNetTime where - parseJSON (String t) = - case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of - Just d -> pure (DotNetTime d) - _ -> fail "could not parse .NET time" - where (s,m) = T.splitAt (T.length t - 5) t + parseJSON = withText "DotNetTime" $ \t -> + let (s,m) = T.splitAt (T.length t - 5) t t' = T.concat [s,".",m] - parseJSON v = typeMismatch "DotNetTime" v + in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of + Just d -> pure (DotNetTime d) + _ -> fail "could not parse .NET time" {-# INLINE parseJSON #-} +instance ToJSON ZonedTime where + toJSON t = String $ pack $ formatTime defaultTimeLocale format t + where + format = "%FT%T" ++ milliseconds ++ tzFormat + milliseconds = take 4 $ formatTime defaultTimeLocale "%Q" t + tzFormat + | 0 == timeZoneMinutes (zonedTimeZone t) = "Z" + | otherwise = "%z" + +instance FromJSON ZonedTime where + parseJSON (String t) = + tryFormats alternateFormats + <|> fail "could not parse ECMA-262 ISO-8601 date" + where + tryFormat f = + case parseTime defaultTimeLocale f (unpack t) of + Just d -> pure d + Nothing -> empty + tryFormats = foldr1 (<|>) . map tryFormat + alternateFormats = + distributeList ["%Y", "%Y-%m", "%F"] + ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"] + + distributeList xs ys = + foldr (\x acc -> acc ++ distribute x ys) [] xs + distribute x = map (mappend x) + + parseJSON v = typeMismatch "ZonedTime" v + instance ToJSON UTCTime where toJSON t = String (pack (take 23 str ++ "Z")) where str = formatTime defaultTimeLocale "%FT%T%Q" t {-# INLINE toJSON #-} instance FromJSON UTCTime where - parseJSON (String t) = + parseJSON = withText "UTCTime" $ \t -> case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of Just d -> pure d _ -> fail "could not parse ISO-8601 date" - parseJSON v = typeMismatch "UTCTime" v {-# INLINE parseJSON #-} instance (ToJSON a, ToJSON b) => ToJSON (a,b) where @@ -633,14 +673,13 @@ {-# INLINE toJSON #-} instance (FromJSON a, FromJSON b) => FromJSON (a,b) where - parseJSON (Array ab) - | n == 2 = (,) <$> parseJSON (V.unsafeIndex ab 0) - <*> parseJSON (V.unsafeIndex ab 1) - | otherwise = fail $ "cannot unpack array of length " ++ - show n ++ " into a pair" - where - n = V.length ab - parseJSON v = typeMismatch "(a,b)" v + parseJSON = withArray "(a,b)" $ \ab -> + let n = V.length ab + in if n == 2 + then (,) <$> parseJSON (V.unsafeIndex ab 0) + <*> parseJSON (V.unsafeIndex ab 1) + else fail $ "cannot unpack array of length " ++ + show n ++ " into a pair" {-# INLINE parseJSON #-} instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where @@ -653,15 +692,14 @@ {-# INLINE toJSON #-} instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where - parseJSON (Array abc) - | n == 3 = (,,) <$> parseJSON (V.unsafeIndex abc 0) - <*> parseJSON (V.unsafeIndex abc 1) - <*> parseJSON (V.unsafeIndex abc 2) - | otherwise = fail $ "cannot unpack array of length " ++ - show n ++ " into a 3-tuple" - where - n = V.length abc - parseJSON v = typeMismatch "(a,b,c)" v + parseJSON = withArray "(a,b,c)" $ \abc -> + let n = V.length abc + in if n == 3 + then (,,) <$> parseJSON (V.unsafeIndex abc 0) + <*> parseJSON (V.unsafeIndex abc 1) + <*> parseJSON (V.unsafeIndex abc 2) + else fail $ "cannot unpack array of length " ++ + show n ++ " into a 3-tuple" {-# INLINE parseJSON #-} instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where @@ -675,16 +713,15 @@ {-# INLINE toJSON #-} instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where - parseJSON (Array abcd) - | n == 4 = (,,,) <$> parseJSON (V.unsafeIndex abcd 0) - <*> parseJSON (V.unsafeIndex abcd 1) - <*> parseJSON (V.unsafeIndex abcd 2) - <*> parseJSON (V.unsafeIndex abcd 3) - | otherwise = fail $ "cannot unpack array of length " ++ - show n ++ " into a 4-tuple" - where - n = V.length abcd - parseJSON v = typeMismatch "(a,b,c,d)" v + parseJSON = withArray "(a,b,c,d)" $ \abcd -> + let n = V.length abcd + in if n == 4 + then (,,,) <$> parseJSON (V.unsafeIndex abcd 0) + <*> parseJSON (V.unsafeIndex abcd 1) + <*> parseJSON (V.unsafeIndex abcd 2) + <*> parseJSON (V.unsafeIndex abcd 3) + else fail $ "cannot unpack array of length " ++ + show n ++ " into a 4-tuple" {-# INLINE parseJSON #-} instance ToJSON a => ToJSON (Dual a) where @@ -711,6 +748,41 @@ parseJSON = fmap Last . parseJSON {-# INLINE parseJSON #-} +-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@ +-- and fails using @'typeMismatch' expected@ otherwise. +withObject :: String -> (Object -> Parser a) -> Value -> Parser a +withObject _ f (Object obj) = f obj +withObject expected _ v = typeMismatch expected v +{-# INLINE withObject #-} + +-- | @withObject expected f value@ applies @f@ to the 'Text' when @value@ is a @String@ +-- and fails using @'typeMismatch' expected@ otherwise. +withText :: String -> (Text -> Parser a) -> Value -> Parser a +withText _ f (String txt) = f txt +withText expected _ v = typeMismatch expected v +{-# INLINE withText #-} + +-- | @withObject expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@ +-- and fails using @'typeMismatch' expected@ otherwise. +withArray :: String -> (Array -> Parser a) -> Value -> Parser a +withArray _ f (Array arr) = f arr +withArray expected _ v = typeMismatch expected v +{-# INLINE withArray #-} + +-- | @withObject expected f value@ applies @f@ to the 'Number' when @value@ is a @Number@ +-- and fails using @'typeMismatch' expected@ otherwise. +withNumber :: String -> (Number -> Parser a) -> Value -> Parser a +withNumber _ f (Number num) = f num +withNumber expected _ v = typeMismatch expected v +{-# INLINE withNumber #-} + +-- | @withObject 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 +withBool _ f (Bool arr) = f arr +withBool expected _ v = typeMismatch expected v +{-# INLINE withBool #-} + -- | Construct a 'Pair' from a key and a value. (.=) :: ToJSON a => Text -> a -> Pair name .= value = (name, toJSON value) @@ -754,7 +826,7 @@ -- from an object without affecting its validity and we know a default -- value to assign in that case. If the key and value are mandatory, -- use '(.:)' instead. --- +-- -- Example usage: -- -- @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\" diff --git a/Data/Aeson/Types/Generic.hs b/Data/Aeson/Types/Generic.hs --- a/Data/Aeson/Types/Generic.hs +++ b/Data/Aeson/Types/Generic.hs @@ -6,7 +6,7 @@ -- | -- Module: Data.Aeson.Types.Generic -- Copyright: (c) 2012 Bryan O'Sullivan --- (c) 2011 Bas Van Dijk +-- (c) 2011, 2012 Bas Van Dijk -- (c) 2011 MailRank, Inc. -- License: Apache -- Maintainer: Bryan O'Sullivan diff --git a/Data/Aeson/Types/Internal.hs b/Data/Aeson/Types/Internal.hs --- a/Data/Aeson/Types/Internal.hs +++ b/Data/Aeson/Types/Internal.hs @@ -2,7 +2,7 @@ -- | -- Module: Data.Aeson.Types.Internal --- Copyright: (c) 2011 Bryan O'Sullivan +-- Copyright: (c) 2011, 2012 Bryan O'Sullivan -- (c) 2011 MailRank, Inc. -- License: Apache -- Maintainer: Bryan O'Sullivan @@ -177,12 +177,16 @@ {-# INLINE fromString #-} instance Hashable Value where - hash (Object o) = H.foldl' hashWithSalt 0 o - hash (Array a) = V.foldl' hashWithSalt 1 a - hash (String s) = 2 `hashWithSalt` s - hash (Number n) = 3 `hashWithSalt` case n of I i -> hash i; D d -> hash d - hash (Bool b) = 4 `hashWithSalt` b - hash Null = 5 + hashWithSalt s (Object o) = H.foldl' hashWithSalt + (s `hashWithSalt` (0::Int)) o + hashWithSalt s (Array a) = V.foldl' hashWithSalt + (s `hashWithSalt` (1::Int)) a + hashWithSalt s (String str) = s `hashWithSalt` (2::Int) `hashWithSalt` str + hashWithSalt s (Number n) = 3 `hashWithSalt` + case n of I i -> hashWithSalt s i + D d -> hashWithSalt s d + hashWithSalt s (Bool b) = s `hashWithSalt` (4::Int) `hashWithSalt` b + hashWithSalt s Null = s `hashWithSalt` (5::Int) -- | The empty array. emptyArray :: Value diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,9 +1,9 @@ name: aeson -version: 0.6.0.2 +version: 0.6.1.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON -copyright: (c) 2011 Bryan O'Sullivan +copyright: (c) 2011, 2012 Bryan O'Sullivan (c) 2011 MailRank, Inc. author: Bryan O'Sullivan maintainer: Bryan O'Sullivan @@ -24,11 +24,6 @@ For release notes, see . - /Note/: if you use GHCi or Template Haskell, please see the - @README@ file for important details about building this package, - and other packages that depend on it: - - . Parsing performance on a late 2010 MacBook Pro (2.66GHz Core i7), for mostly-English tweets from Twitter's JSON search API: . @@ -159,7 +154,8 @@ template-haskell, test-framework, test-framework-quickcheck2, - text + text, + time source-repository head type: git diff --git a/release-notes.markdown b/release-notes.markdown --- a/release-notes.markdown +++ b/release-notes.markdown @@ -1,3 +1,23 @@ +# 0.6 series + +Much improved documentation. + +Angle brackets are now escaped in JSON strings, to help avoid XSS +attacks. + +Fixed up handling of nullary constructors when using generic encoding. + +Added ToJSON/FromJSON instances for: + +* The `Fixed` class + +* ISO-8601 dates: `UTCTime`, `ZonedTime`, and `TimeZone` + +Added accessor functions for inspecting `Value`s. + +Added `eitherDecode` function that returns an error message if +decoding fails. + # 0.5 to 0.6 This release introduces a slightly obscure, but diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, RecordWildCards, - ScopedTypeVariables #-} + ScopedTypeVariables, StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Control.Monad @@ -12,12 +12,13 @@ import Data.Text (Text) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary(..)) +import Test.QuickCheck (Arbitrary(..), choose, Gen) import qualified Data.Aeson.Generic as G import qualified Data.Attoparsec.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Text as T import qualified Data.Map as Map +import Data.Time (ZonedTime(..), LocalTime(..), TimeZone(..), hoursToTimeZone, Day(..), TimeOfDay(..)) encodeDouble :: Double -> Double -> Bool encodeDouble num denom @@ -61,6 +62,9 @@ Error _ -> False Success x' -> x == x' +regress_gh72 :: [(String, Maybe String)] -> Bool +regress_gh72 ys = G.decode (G.encode m) == Just m + where m = Map.fromList ys data Foo = Foo { fooInt :: Int @@ -100,6 +104,17 @@ instance Arbitrary Foo where arbitrary = liftM4 Foo arbitrary arbitrary arbitrary arbitrary +instance Arbitrary LocalTime where + arbitrary = return $ LocalTime (ModifiedJulianDay 1) (TimeOfDay 1 2 3) + +instance Arbitrary TimeZone where + arbitrary = do + offset <- choose (0,2) :: Gen Int + return $ hoursToTimeZone offset + +instance Arbitrary ZonedTime where + arbitrary = liftM2 ZonedTime arbitrary arbitrary + data UFoo = UFoo { _UFooInt :: Int , uFooInt :: Int @@ -112,8 +127,13 @@ main :: IO () main = defaultMain tests +deriving instance Eq ZonedTime + tests :: [Test] tests = [ + testGroup "regression" [ + testProperty "gh-72" regress_gh72 + ], testGroup "encode" [ testProperty "encodeDouble" encodeDouble , testProperty "encodeInteger" encodeInteger @@ -138,6 +158,7 @@ , testProperty "String" $ roundTripEq (""::String) , testProperty "Text" $ roundTripEq T.empty , testProperty "Foo" $ roundTripEq (undefined::Foo) + , testProperty "ZonedTime" $ roundTripEq (undefined::ZonedTime) ], testGroup "toFromJSON" [ testProperty "Integer" (toFromJSON :: Integer -> Bool)