git.iko.soy/typeable/aeson
on 1.1.1.0 help sign in
typeable/aeson/tests/UnitTests.hs
489 lines 19 kB history raw
1{-# LANGUAGE CPP #-}
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 #-}
11module UnitTests
12 (
13 ioTests
14 , tests
15 ) where
17import Prelude ()
18import Prelude.Compat
20import Control.Monad (forM, forM_)
21import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, 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(..), ToJSON(..), Value, camelTo, camelTo2, defaultOptions, omitNothingFields)
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)
38import Instances ()
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 ()
60tests :: Test
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")
75 ]
76 , testGroup "encoding" [
77 testCase "goodProducer" $ goodProducer
78 ]
79 , testGroup "utctime" [
80 testCase "good" $ utcTimeGood
81 , testCase "bad" $ utcTimeBad
82 ]
83 , testGroup "formatError" [
84 testCase "example 1" $ formatErrorExample
85 ]
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 ]
96roundTripCamel :: String -> Assertion
97roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)
99roundTripCamel2 :: String -> Assertion
100roundTripCamel2 name = assertEqual "" name (camelFrom '_' $ camelTo2 '_' name)
102camelFrom :: Char -> String -> String
103camelFrom c s = let (p:ps) = split c s
104 in concat $ p : map capitalize ps
105 where
106 split c' s' = map L.unpack $ L.split c' $ L.pack s'
107 capitalize t = toUpper (head t) : tail t
110data Wibble = Wibble {
111 wibbleString :: String
112 , wibbleInt :: Int
113 } deriving (Generic, Show, Eq)
115instance FromJSON Wibble
117instance ToJSON Wibble where
118 toJSON = genericToJSON defaultOptions
119 toEncoding = genericToEncoding defaultOptions
121-- Test that if we put a bomb in a data structure, but only demand
122-- part of it via lazy encoding, we do not unexpectedly fail.
123goodProducer :: Assertion
124goodProducer = assertEqual "partial encoding should not explode on undefined"
125 '{' (L.head (encode wibble))
126 where
127 wibble = Wibble {
128 wibbleString = replicate k 'a'
129 , wibbleInt = 1
130 }
131 k | arch32bit = 4047
132 | otherwise = 4030
133 arch32bit = (maxBound :: Int) == 2147483647
135-- Test decoding various UTC time formats
136--
137-- Note: the incomplete pattern matches for UTCTimes are completely
138-- intentional. The test expects these parses to succeed. If the
139-- pattern matches fails, there's a bug in either the test or in aeson
140-- and needs to be investigated.
141utcTimeGood :: Assertion
142utcTimeGood = do
143 let ts1 = "2015-01-01T12:13:00.00Z" :: LT.Text
144 let ts2 = "2015-01-01T12:13:00Z" :: LT.Text
145 -- 'T' between date and time is not required, can be space
146 let ts3 = "2015-01-03 12:13:00.00Z" :: LT.Text
147 let ts4 = "2015-01-03 12:13:00.125Z" :: LT.Text
148 let (Just (t1 :: UTCTime)) = parseWithAeson ts1
149 let (Just (t2 :: UTCTime)) = parseWithAeson ts2
150 let (Just (t3 :: UTCTime)) = parseWithAeson ts3
151 let (Just (t4 :: UTCTime)) = parseWithAeson ts4
152 assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts1) t1
153 assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts2) t2
154 assertEqual "utctime" (parseWithRead "%F %T%QZ" ts3) t3
155 assertEqual "utctime" (parseWithRead "%F %T%QZ" ts4) t4
156 -- Time zones. Both +HHMM and +HH:MM are allowed for timezone
157 -- offset, and MM may be omitted.
158 let ts5 = "2015-01-01T12:30:00.00+00" :: LT.Text
159 let ts6 = "2015-01-01T12:30:00.00+01:15" :: LT.Text
160 let ts7 = "2015-01-01T12:30:00.00-02" :: LT.Text
161 let ts8 = "2015-01-01T22:00:00.00-03" :: LT.Text
162 let ts9 = "2015-01-01T22:00:00.00-04:30" :: LT.Text
163 let (Just (t5 :: UTCTime)) = parseWithAeson ts5
164 let (Just (t6 :: UTCTime)) = parseWithAeson ts6
165 let (Just (t7 :: UTCTime)) = parseWithAeson ts7
166 let (Just (t8 :: UTCTime)) = parseWithAeson ts8
167 let (Just (t9 :: UTCTime)) = parseWithAeson ts9
168 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T12:30:00.00Z") t5
169 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T11:15:00.00Z") t6
170 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t7
171 -- ts8 wraps around to the next day in UTC
172 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T01:00:00Z") t8
173 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T02:30:00Z") t9
175 -- Seconds in Time can be omitted
176 let ts10 = "2015-01-03T12:13Z" :: LT.Text
177 let ts11 = "2015-01-03 12:13Z" :: LT.Text
178 let ts12 = "2015-01-01T12:30-02" :: LT.Text
179 let (Just (t10 :: UTCTime)) = parseWithAeson ts10
180 let (Just (t11 :: UTCTime)) = parseWithAeson ts11
181 let (Just (t12 :: UTCTime)) = parseWithAeson ts12
182 assertEqual "utctime" (parseWithRead "%FT%H:%MZ" ts10) t10
183 assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11
184 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12
186 where
187 parseWithRead :: String -> LT.Text -> UTCTime
188 parseWithRead f s =
189 case parseTime defaultTimeLocale f . LT.unpack $ s of
190 Nothing -> error "parseTime input malformed"
191 Just t -> t
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
198utcTimeBad = do
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
207 where
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
214formatErrorExample =
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]
232dotColonMark = [
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)
244 ]
245 where ex1 = "{}"
246 ex2 = "{\"value\": 42 }"
247 ex3 = "{\"value\": null }"
249------------------------------------------------------------------------------
250-- These tests check that JSONPath is tracked correctly
251-----------------------------------------------------------------------------
253jsonPath :: [Assertion]
254jsonPath = [
255 -- issue #356
256 assertEqual "Either"
257 (Left "Error in $[1].Left[1]: expected Bool, encountered Number")
258 (eitherDecode "[1,{\"Left\":[2,3]}]"
259 :: Either String (Int, Either (Int, Bool) ()))
260 -- issue #358
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)
268 ]
270------------------------------------------------------------------------------
271-- Check that the hashes of two equal Value are the same
272------------------------------------------------------------------------------
274hashableLaws :: [Assertion]
275hashableLaws = [
276 assertEqual "Hashable Object" (hash a) (hash b)
277 ]
278 where
279 a = object ["223" .= False, "807882556" .= True]
280 b = object ["807882556" .= True, "223" .= False]
282-------------------------------------------------------------------------------
283-- ToJSONKey
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')
303#endif
304 ]
305 where
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
314pickWithRules
315 :: a -- ^ Pick this when RULES are on
316 -> a -- ^ use this otherwise
317 -> a
318pickWithRules _ = id
319{-# NOINLINE pickWithRules #-}
320{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-}
321#endif
323------------------------------------------------------------------------------
324-- Regressions
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]
332issue351 = [
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\"]"
336 ]
338------------------------------------------------------------------------------
339-- Comparison between bytestring and text encoders
340------------------------------------------------------------------------------
342ioTests :: IO [Test]
343ioTests = do
344 enc <- encoderComparisonTests
345 js <- jsonTestSuite
346 return [enc, js]
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
358 where
359 encodeViaText :: Value -> L.ByteString
360 encodeViaText =
361 TLE.encodeUtf8 . TLB.toLazyText . encodeToTextBuilder . toJSON
363 testFiles =
364 [ "example.json"
365 , "integers.json"
366 , "jp100.json"
367 , "numbers.json"
368 , "twitter10.json"
369 , "twitter20.json"
370 , "geometry.json"
371 , "jp10.json"
372 , "jp50.json"
373 , "twitter1.json"
374 , "twitter100.json"
375 , "twitter50.json"
376 ]
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}
382 deriving Generic
384instance ToJSON MyRecord2
385instance FromJSON MyRecord2
387-- A regression test for: https://github.com/bos/aeson/pull/477
388unescapeString :: Assertion
389unescapeString = do
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)
398 where
399 utf16Char = formatString . LBase16.encode . LT.encodeUtf16BE
400 formatString s
401 | L.length s == 4 = L.concat ["\"\\u", s, "\""]
402 | L.length s == 8 =
403 L.concat ["\"\\u", L.take 4 s, "\\u", L.drop 4 s, "\""]
404 | otherwise = error "unescapeString: can't happen"
406-- JSONTestSuite
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
417 where
418 fileName = takeFileName path
420-- Build a collection of tests based on the current contents of the
421-- JSONTestSuite test directories.
423jsonTestSuite :: IO Test
424jsonTestSuite = do
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"
474 ]
476-- A regression test for: https://github.com/bos/aeson/pull/455
477data Foo a = FooNil | FooCons (Foo Int)
479pr455 :: Assertion
480pr455 = assertEqual "FooCons FooNil"
481 (toJSON foo) (liftToJSON undefined undefined foo)
482 where
483 foo :: Foo Int
484 foo = FooCons FooNil
486deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
488deriveToJSON defaultOptions ''Foo
489deriveToJSON1 defaultOptions ''Foo