2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TemplateHaskell #-}
8-- For Data.Aeson.Types.camelTo
9{-# OPTIONS_GHC -fno-warn-deprecations #-}
20import Control.Monad (forM, forM_)
21import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject)
22import Data.Aeson.Internal (JSONPathElement(..), formatError)
23import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)
24import Data.Aeson.Text (encodeToTextBuilder)
25import Data.Aeson.Types (Options(..), Result(Success), ToJSON(..), Value(Null), camelTo, camelTo2, defaultOptions, omitNothingFields, parse)
26import Data.Char (toUpper)
27import Data.Either.Compat (isLeft, isRight)
28import Data.Hashable (hash)
29import Data.List (sort)
30import Data.Maybe (fromMaybe)
31import Data.Sequence (Seq)
32import Data.Tagged (Tagged(..))
33import Data.Text (Text)
34import Data.Time (UTCTime)
35import Data.Time.Format (parseTime)
36import Data.Time.Locale.Compat (defaultTimeLocale)
37import GHC.Generics (Generic)
39import System.Directory (getDirectoryContents)
40import System.FilePath ((</>), takeExtension, takeFileName)
41import Test.Framework (Test, testGroup)
42import Test.Framework.Providers.HUnit (testCase)
43import Test.HUnit (Assertion, assertBool, assertFailure, assertEqual)
44import Text.Printf (printf)
45import UnitTests.NullaryConstructors (nullaryConstructors)
46import qualified Data.ByteString.Base16.Lazy as LBase16
47import qualified Data.ByteString.Lazy.Char8 as L
48import qualified Data.HashSet as HashSet
49import qualified Data.Text.Lazy as LT
50import qualified Data.Text.Lazy.Builder as TLB
51import qualified Data.Text.Lazy.Encoding as LT
52import qualified Data.Text.Lazy.Encoding as TLE
53import qualified ErrorMessages
54import qualified SerializationFormatSpec
56-- Asserts that we can use both modules at once in the test suite.
57import Data.Aeson.Parser.UnescapeFFI ()
58import Data.Aeson.Parser.UnescapePure ()
61tests = testGroup "unit" [
62 testGroup "SerializationFormatSpec" SerializationFormatSpec.tests
63 , testGroup "ErrorMessages" ErrorMessages.tests
64 , testGroup "camelCase" [
65 testCase "camelTo" $ roundTripCamel "aName"
66 , testCase "camelTo" $ roundTripCamel "another"
67 , testCase "camelTo" $ roundTripCamel "someOtherName"
68 , testCase "camelTo" $
69 assertEqual "" "camel_apicase" (camelTo '_' "CamelAPICase")
70 , testCase "camelTo2" $ roundTripCamel2 "aName"
71 , testCase "camelTo2" $ roundTripCamel2 "another"
72 , testCase "camelTo2" $ roundTripCamel2 "someOtherName"
73 , testCase "camelTo2" $
74 assertEqual "" "camel_api_case" (camelTo2 '_' "CamelAPICase")
76 , testGroup "encoding" [
77 testCase "goodProducer" goodProducer
79 , testGroup "utctime" [
80 testCase "good" utcTimeGood
81 , testCase "bad" utcTimeBad
83 , testGroup "formatError" [
84 testCase "example 1" formatErrorExample
86 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark
87 , testGroup "JSONPath" $ fmap (testCase "-") jsonPath
88 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws
89 , testGroup "Issue #351" $ fmap (testCase "-") issue351
90 , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors
91 , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions
92 , testCase "PR #455" pr455
93 , testCase "Unescape string (PR #477)" unescapeString
94 , testCase "Show Options" showOptions
95 , testGroup "SingleMaybeField" singleMaybeField
98roundTripCamel :: String -> Assertion
99roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)
101roundTripCamel2 :: String -> Assertion
102roundTripCamel2 name = assertEqual "" name (camelFrom '_' $ camelTo2 '_' name)
104camelFrom :: Char -> String -> String
105camelFrom c s = let (p:ps) = split c s
106 in concat $ p : map capitalize ps
108 split c' s' = map L.unpack $ L.split c' $ L.pack s'
109 capitalize t = toUpper (head t) : tail t
112data Wibble = Wibble {
113 wibbleString :: String
115 } deriving (Generic, Show, Eq)
117instance FromJSON Wibble
119instance ToJSON Wibble where
120 toJSON = genericToJSON defaultOptions
121 toEncoding = genericToEncoding defaultOptions
123-- Test that if we put a bomb in a data structure, but only demand
124-- part of it via lazy encoding, we do not unexpectedly fail.
125goodProducer :: Assertion
126goodProducer = assertEqual "partial encoding should not explode on undefined"
127 '{' (L.head (encode wibble))
130 wibbleString = replicate k 'a'
135 arch32bit = (maxBound :: Int) == 2147483647
137-- Test decoding various UTC time formats
139-- Note: the incomplete pattern matches for UTCTimes are completely
140-- intentional. The test expects these parses to succeed. If the
141-- pattern matches fails, there's a bug in either the test or in aeson
142-- and needs to be investigated.
143utcTimeGood :: Assertion
145 let ts1 = "2015-01-01T12:13:00.00Z" :: LT.Text
146 let ts2 = "2015-01-01T12:13:00Z" :: LT.Text
147 -- 'T' between date and time is not required, can be space
148 let ts3 = "2015-01-03 12:13:00.00Z" :: LT.Text
149 let ts4 = "2015-01-03 12:13:00.125Z" :: LT.Text
150 let (Just (t1 :: UTCTime)) = parseWithAeson ts1
151 let (Just (t2 :: UTCTime)) = parseWithAeson ts2
152 let (Just (t3 :: UTCTime)) = parseWithAeson ts3
153 let (Just (t4 :: UTCTime)) = parseWithAeson ts4
154 assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts1) t1
155 assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts2) t2
156 assertEqual "utctime" (parseWithRead "%F %T%QZ" ts3) t3
157 assertEqual "utctime" (parseWithRead "%F %T%QZ" ts4) t4
158 -- Time zones. Both +HHMM and +HH:MM are allowed for timezone
159 -- offset, and MM may be omitted.
160 let ts5 = "2015-01-01T12:30:00.00+00" :: LT.Text
161 let ts6 = "2015-01-01T12:30:00.00+01:15" :: LT.Text
162 let ts7 = "2015-01-01T12:30:00.00-02" :: LT.Text
163 let ts8 = "2015-01-01T22:00:00.00-03" :: LT.Text
164 let ts9 = "2015-01-01T22:00:00.00-04:30" :: LT.Text
165 let (Just (t5 :: UTCTime)) = parseWithAeson ts5
166 let (Just (t6 :: UTCTime)) = parseWithAeson ts6
167 let (Just (t7 :: UTCTime)) = parseWithAeson ts7
168 let (Just (t8 :: UTCTime)) = parseWithAeson ts8
169 let (Just (t9 :: UTCTime)) = parseWithAeson ts9
170 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T12:30:00.00Z") t5
171 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T11:15:00.00Z") t6
172 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t7
173 -- ts8 wraps around to the next day in UTC
174 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T01:00:00Z") t8
175 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T02:30:00Z") t9
177 -- Seconds in Time can be omitted
178 let ts10 = "2015-01-03T12:13Z" :: LT.Text
179 let ts11 = "2015-01-03 12:13Z" :: LT.Text
180 let ts12 = "2015-01-01T12:30-02" :: LT.Text
181 let (Just (t10 :: UTCTime)) = parseWithAeson ts10
182 let (Just (t11 :: UTCTime)) = parseWithAeson ts11
183 let (Just (t12 :: UTCTime)) = parseWithAeson ts12
184 assertEqual "utctime" (parseWithRead "%FT%H:%MZ" ts10) t10
185 assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11
186 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12
189 parseWithRead :: String -> LT.Text -> UTCTime
191 fromMaybe (error "parseTime input malformed") . parseTime defaultTimeLocale f . LT.unpack $ s
192 parseWithAeson :: LT.Text -> Maybe UTCTime
193 parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""]
195-- Test that a few non-timezone qualified timestamp formats get
196-- rejected if decoding to UTCTime.
197utcTimeBad :: Assertion
199 verifyFailParse "2000-01-01T12:13:00" -- missing Zulu time not allowed (some TZ required)
200 verifyFailParse "2000-01-01 12:13:00" -- missing Zulu time not allowed (some TZ required)
201 verifyFailParse "2000-01-01" -- date only not OK
202 verifyFailParse "2000-01-01Z" -- date only not OK
203 verifyFailParse "2015-01-01T12:30:00.00+00Z" -- no Zulu if offset given
204 verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given
205 verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits
206 verifyFailParse "2015-01-03 12:13.000Z" -- decimal at the end, but no seconds
208 verifyFailParse (s :: LT.Text) =
209 let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] in
210 assertEqual "verify failure" Nothing dec
212-- Non identifier keys should be escaped & enclosed in brackets
213formatErrorExample :: Assertion
215 let rhs = formatError [Index 0, Key "foo", Key "bar", Key "a.b.c", Key "", Key "'\\", Key "end"] "error msg"
216 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"
217 in assertEqual "formatError example" lhs rhs
219------------------------------------------------------------------------------
220-- Comparison (.:?) and (.:!)
221------------------------------------------------------------------------------
223newtype T1 = T1 (Maybe Int) deriving (Eq, Show)
224newtype T2 = T2 (Maybe Int) deriving (Eq, Show)
225newtype T3 = T3 (Maybe Int) deriving (Eq, Show)
227instance FromJSON T1 where parseJSON = fmap T1 . withObject "T1" (.: "value")
228instance FromJSON T2 where parseJSON = fmap T2 . withObject "T2" (.:? "value")
229instance FromJSON T3 where parseJSON = fmap T3 . withObject "T3" (.:! "value")
231dotColonMark :: [Assertion]
233 assertEqual ".: not-present" Nothing (decode ex1 :: Maybe T1)
234 , assertEqual ".: 42" (Just (T1 (Just 42))) (decode ex2 :: Maybe T1)
235 , assertEqual ".: null" (Just (T1 Nothing)) (decode ex3 :: Maybe T1)
237 , assertEqual ".:? not-present" (Just (T2 Nothing)) (decode ex1 :: Maybe T2)
238 , assertEqual ".:? 42" (Just (T2 (Just 42))) (decode ex2 :: Maybe T2)
239 , assertEqual ".:? null" (Just (T2 Nothing)) (decode ex3 :: Maybe T2)
241 , assertEqual ".:! not-present" (Just (T3 Nothing)) (decode ex1 :: Maybe T3)
242 , assertEqual ".:! 42" (Just (T3 (Just 42))) (decode ex2 :: Maybe T3)
243 , assertEqual ".:! null" Nothing (decode ex3 :: Maybe T3)
246 ex2 = "{\"value\": 42 }"
247 ex3 = "{\"value\": null }"
249------------------------------------------------------------------------------
250-- These tests check that JSONPath is tracked correctly
251-----------------------------------------------------------------------------
253jsonPath :: [Assertion]
257 (Left "Error in $[1].Left[1]: expected Bool, encountered Number")
258 (eitherDecode "[1,{\"Left\":[2,3]}]"
259 :: Either String (Int, Either (Int, Bool) ()))
261 , assertEqual "Seq a"
262 (Left "Error in $[2]: expected Int, encountered Boolean")
263 (eitherDecode "[0,1,true]" :: Either String (Seq Int))
264 , assertEqual "Wibble"
265 (Left "Error in $.wibbleInt: expected Int, encountered Boolean")
266 (eitherDecode "{\"wibbleString\":\"\",\"wibbleInt\":true}"
267 :: Either String Wibble)
270------------------------------------------------------------------------------
271-- Check that the hashes of two equal Value are the same
272------------------------------------------------------------------------------
274hashableLaws :: [Assertion]
276 assertEqual "Hashable Object" (hash a) (hash b)
279 a = object ["223" .= False, "807882556" .= True]
280 b = object ["807882556" .= True, "223" .= False]
282-------------------------------------------------------------------------------
284-------------------------------------------------------------------------------
286newtype MyText = MyText Text
287 deriving (FromJSONKey)
289newtype MyText' = MyText' Text
291instance FromJSONKey MyText' where
292 fromJSONKey = fmap MyText' fromJSONKey
293 fromJSONKeyList = error "not used"
295fromJSONKeyAssertions :: [Assertion]
296fromJSONKeyAssertions =
297 [ assertIsCoerce "Text" (fromJSONKey :: FromJSONKeyFunction Text)
298 , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text))
299 , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText)
301#if __GLASGOW_HASKELL__ >= 710
302 , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText')
306 assertIsCoerce _ (FromJSONKeyCoerce _) = pure ()
307 assertIsCoerce n _ = assertFailure n
309#if __GLASGOW_HASKELL__ >= 710
310 assertIsCoerce' _ (FromJSONKeyCoerce _) = pure ()
311 assertIsCoerce' n _ = pickWithRules (assertFailure n) (pure ())
313-- | Pick the first when RULES are enabled, e.g. optimisations are on
315 :: a -- ^ Pick this when RULES are on
316 -> a -- ^ use this otherwise
319{-# NOINLINE pickWithRules #-}
320{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-}
323------------------------------------------------------------------------------
325------------------------------------------------------------------------------
327-- A regression test for: https://github.com/bos/aeson/issues/351
328overlappingRegression :: FromJSON a => L.ByteString -> [a]
329overlappingRegression bs = fromMaybe [] $ decode bs
331issue351 :: [Assertion]
333 assertEqual "Int" ([1, 2, 3] :: [Int]) $ overlappingRegression "[1, 2, 3]"
334 , assertEqual "Char" ("abc" :: String) $ overlappingRegression "\"abc\""
335 , assertEqual "Char" ("" :: String) $ overlappingRegression "[\"a\", \"b\", \"c\"]"
338------------------------------------------------------------------------------
339-- Comparison between bytestring and text encoders
340------------------------------------------------------------------------------
344 enc <- encoderComparisonTests
348encoderComparisonTests :: IO Test
349encoderComparisonTests = do
350 encoderTests <- forM testFiles $ \file0 -> do
351 let file = "benchmarks/json-data/" ++ file0
352 return $ testCase file $ do
353 inp <- L.readFile file
354 case eitherDecode inp of
355 Left err -> assertFailure $ "Decoding failure: " ++ err
356 Right val -> assertEqual "" (encode val) (encodeViaText val)
357 return $ testGroup "encoders" encoderTests
359 encodeViaText :: Value -> L.ByteString
361 TLE.encodeUtf8 . TLB.toLazyText . encodeToTextBuilder . toJSON
378-- A regression test for: https://github.com/bos/aeson/issues/293
379data MyRecord = MyRecord {_field1 :: Maybe Int, _field2 :: Maybe Bool}
381data MyRecord2 = MyRecord2 {_field3 :: Maybe Int, _field4 :: Maybe Bool}
384instance ToJSON MyRecord2
385instance FromJSON MyRecord2
387-- A regression test for: https://github.com/bos/aeson/pull/477
388unescapeString :: Assertion
390 assertEqual "Basic escaping"
391 (Right ("\" / \\ \b \f \n \r \t" :: String))
392 (eitherDecode "\"\\\" \\/ \\\\ \\b \\f \\n \\r \\t\"")
394 forM_ [minBound .. maxBound :: Char] $ \ c ->
395 let s = LT.pack [c] in
396 assertEqual (printf "UTF-16 encoded '\\x%X'" c)
397 (Right s) (eitherDecode $ utf16Char s)
399 utf16Char = formatString . LBase16.encode . LT.encodeUtf16BE
401 | L.length s == 4 = L.concat ["\"\\u", s, "\""]
403 L.concat ["\"\\u", L.take 4 s, "\\u", L.drop 4 s, "\""]
404 | otherwise = error "unescapeString: can't happen"
408jsonTestSuiteTest :: FilePath -> Test
409jsonTestSuiteTest path = testCase fileName $ do
410 payload <- L.readFile path
411 let result = eitherDecode payload :: Either String Value
412 assertBool fileName $ case take 2 fileName of
413 "i_" -> isRight result
414 "n_" -> isLeft result
415 "y_" -> isRight result
416 _ -> isRight result -- test_transform tests have inconsistent names
418 fileName = takeFileName path
420-- Build a collection of tests based on the current contents of the
421-- JSONTestSuite test directories.
423jsonTestSuite :: IO Test
425 let suitePath = "tests/JSONTestSuite"
426 let suites = ["test_parsing", "test_transform"]
427 testPaths <- fmap (sort . concat) . forM suites $ \suite -> do
428 let dir = suitePath </> suite
429 entries <- getDirectoryContents dir
430 let ok name = takeExtension name == ".json" &&
431 not (name `HashSet.member` blacklist)
432 return . map (dir </>) . filter ok $ entries
433 return $ testGroup "JSONTestSuite" $ map jsonTestSuiteTest testPaths
435-- The set expected-to-be-failing JSONTestSuite tests.
436-- Not all of these failures are genuine bugs.
437-- Of those that are bugs, not all are worth fixing.
439blacklist :: HashSet.HashSet String
440-- blacklist = HashSet.empty
441blacklist = _blacklist
443_blacklist :: HashSet.HashSet String
444_blacklist = HashSet.fromList [
445 "i_object_key_lone_2nd_surrogate.json"
446 , "i_string_1st_surrogate_but_2nd_missing.json"
447 , "i_string_1st_valid_surrogate_2nd_invalid.json"
448 , "i_string_UTF-16LE_with_BOM.json"
449 , "i_string_UTF-16_invalid_lonely_surrogate.json"
450 , "i_string_UTF-16_invalid_surrogate.json"
451 , "i_string_UTF-8_invalid_sequence.json"
452 , "i_string_incomplete_surrogate_and_escape_valid.json"
453 , "i_string_incomplete_surrogate_pair.json"
454 , "i_string_incomplete_surrogates_escape_valid.json"
455 , "i_string_invalid_lonely_surrogate.json"
456 , "i_string_invalid_surrogate.json"
457 , "i_string_inverted_surrogates_U+1D11E.json"
458 , "i_string_lone_second_surrogate.json"
459 , "i_string_not_in_unicode_range.json"
460 , "i_string_truncated-utf-8.json"
461 , "i_structure_UTF-8_BOM_empty_object.json"
462 , "n_string_unescaped_crtl_char.json"
463 , "n_string_unescaped_newline.json"
464 , "n_string_unescaped_tab.json"
465 , "string_1_escaped_invalid_codepoint.json"
466 , "string_1_invalid_codepoint.json"
467 , "string_1_invalid_codepoints.json"
468 , "string_2_escaped_invalid_codepoints.json"
469 , "string_2_invalid_codepoints.json"
470 , "string_3_escaped_invalid_codepoints.json"
471 , "string_3_invalid_codepoints.json"
472 , "y_string_utf16BE_no_BOM.json"
473 , "y_string_utf16LE_no_BOM.json"
476-- A regression test for: https://github.com/bos/aeson/pull/455
477data Foo a = FooNil | FooCons (Foo Int)
480pr455 = assertEqual "FooCons FooNil"
481 (toJSON foo) (liftToJSON undefined undefined foo)
486showOptions :: Assertion
491 ++ "fieldLabelModifier =~ \"exampleField\""
492 ++ ", constructorTagModifier =~ \"ExampleConstructor\""
493 ++ ", allNullaryToStringTag = True"
494 ++ ", omitNothingFields = False"
495 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
496 ++ ", unwrapUnaryRecords = False"
497 ++ ", tagSingleConstructors = False"
499 (show defaultOptions)
501newtype SingleMaybeField = SingleMaybeField { smf :: Maybe Int }
502 deriving (Eq, Show, Generic)
504singleMaybeField :: [Test]
506 (gName, gToJSON, gToEncoding, gFromJSON) <-
507 [ ("generic", genericToJSON opts, genericToEncoding opts, parse (genericParseJSON opts))
508 , ("th", toJSON, toEncoding, fromJSON) ]
511 assertEqual "toJSON" Null (gToJSON v)
512 assertEqual "toEncoding" (toEncoding (gToJSON v)) (gToEncoding v)
513 assertEqual "fromJSON" (Success v) (gFromJSON Null)
515 v = SingleMaybeField Nothing
516 opts = defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True}
518deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
520deriveToJSON defaultOptions ''Foo
521deriveToJSON1 defaultOptions ''Foo
523deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list