1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveGeneric #-} 3{-# LANGUAGE GeneralizedNewtypeDeriving #-} 4{-# LANGUAGE NoImplicitPrelude #-} 5{-# LANGUAGE OverloadedStrings #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7{-# LANGUAGE TemplateHaskell #-} 8{-# LANGUAGE TypeFamilies #-} 9{-# LANGUAGE QuasiQuotes #-} 10 11-- For Data.Aeson.Types.camelTo 12{-# OPTIONS_GHC -fno-warn-deprecations #-} 13 14#if MIN_VERSION_base(4,9,0) 15{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} 16#endif 17 18module UnitTests 19 ( 20 ioTests 21 , tests 22 , withEmbeddedJSONTest 23 ) where 24 25import Prelude.Compat 26 27import Control.Monad (forM, forM_) 28import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON) 29import Data.Aeson.Internal (JSONPathElement(..), formatError) 30import Data.Aeson.QQ.Simple (aesonQQ) 31import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1) 32import Data.Aeson.Text (encodeToTextBuilder) 33import Data.Aeson.Parser 34 ( json, jsonLast, jsonAccum, jsonNoDup 35 , json', jsonLast', jsonAccum', jsonNoDup') 36import Data.Aeson.Types 37 ( Options(..), Result(Success, Error), ToJSON(..) 38 , Value(Array, Bool, Null, Number, Object, String), camelTo, camelTo2 39 , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse) 40import Data.Attoparsec.ByteString (Parser, parseOnly) 41import Data.Char (toUpper) 42import Data.Either.Compat (isLeft, isRight) 43import Data.Hashable (hash) 44import Data.HashMap.Strict (HashMap) 45import Data.List (sort, isSuffixOf) 46import Data.Maybe (fromMaybe) 47import Data.Scientific (Scientific, scientific) 48import Data.Tagged (Tagged(..)) 49import Data.Text (Text) 50import Data.Time (UTCTime) 51import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale) 52import GHC.Generics (Generic) 53import Instances () 54import Numeric.Natural (Natural) 55import System.Directory (getDirectoryContents) 56import System.FilePath ((</>), takeExtension, takeFileName) 57import Test.Tasty (TestTree, testGroup) 58import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, assertEqual, testCase, (@?=)) 59import Text.Printf (printf) 60import UnitTests.NullaryConstructors (nullaryConstructors) 61import qualified Data.ByteString as S 62import qualified Data.ByteString.Base16.Lazy as LBase16 63import qualified Data.ByteString.Lazy.Char8 as L 64import qualified Data.HashSet as HashSet 65import qualified Data.HashMap.Lazy as HashMap 66import qualified Data.Text.Lazy as LT 67import qualified Data.Text.Lazy.Builder as TLB 68import qualified Data.Text.Lazy.Encoding as LT 69import qualified Data.Text.Lazy.Encoding as TLE 70import qualified Data.Vector as Vector 71import qualified ErrorMessages 72import qualified SerializationFormatSpec 73 74-- Asserts that we can use both modules at once in the test suite. 75import Data.Aeson.Parser.UnescapeFFI () 76import Data.Aeson.Parser.UnescapePure () 77 78tests :: TestTree 79tests = testGroup "unit" [ 80 testGroup "SerializationFormatSpec" SerializationFormatSpec.tests 81 , testGroup "ErrorMessages" ErrorMessages.tests 82 , testGroup "camelCase" [ 83 testCase "camelTo" $ roundTripCamel "aName" 84 , testCase "camelTo" $ roundTripCamel "another" 85 , testCase "camelTo" $ roundTripCamel "someOtherName" 86 , testCase "camelTo" $ 87 assertEqual "" "camel_apicase" (camelTo '_' "CamelAPICase") 88 , testCase "camelTo2" $ roundTripCamel2 "aName" 89 , testCase "camelTo2" $ roundTripCamel2 "another" 90 , testCase "camelTo2" $ roundTripCamel2 "someOtherName" 91 , testCase "camelTo2" $ 92 assertEqual "" "camel_api_case" (camelTo2 '_' "CamelAPICase") 93 ] 94 , testGroup "encoding" [ 95 testCase "goodProducer" goodProducer 96 ] 97 , testGroup "utctime" [ 98 testCase "good" utcTimeGood 99 , testCase "bad" utcTimeBad 100 ] 101 , testGroup "formatError" [ 102 testCase "example 1" formatErrorExample 103 ] 104 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark 105 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws 106 , testGroup "Object construction" $ fmap (testCase "-") objectConstruction 107 , testGroup "Issue #351" $ fmap (testCase "-") issue351 108 , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors 109 , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions 110 , testCase "PR #455" pr455 111 , testCase "Unescape string (PR #477)" unescapeString 112 , testCase "Show Options" showOptions 113 , testGroup "SingleMaybeField" singleMaybeField 114 , testCase "withEmbeddedJSON" withEmbeddedJSONTest 115 , testCase "SingleFieldCon" singleFieldCon 116 , testGroup "UnknownFields" unknownFields 117 , testGroup "Ordering of object keys" keyOrdering 118 , testCase "Ratio with denominator 0" ratioDenominator0 119 , testCase "Rational parses number" rationalNumber 120 , testCase "Big rational" bigRationalDecoding 121 , testCase "Small rational" smallRationalDecoding 122 , testCase "Big scientific exponent" bigScientificExponent 123 , testCase "Big integer decoding" bigIntegerDecoding 124 , testCase "Big natural decading" bigNaturalDecoding 125 , testCase "Big integer key decoding" bigIntegerKeyDecoding 126 , testGroup "QQ.Simple" 127 [ testCase "example" $ 128 assertEqual "" (object ["foo" .= True]) [aesonQQ| {"foo": true } |] 129 ] 130 ] 131 132roundTripCamel :: String -> Assertion 133roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name) 134 135roundTripCamel2 :: String -> Assertion 136roundTripCamel2 name = assertEqual "" name (camelFrom '_' $ camelTo2 '_' name) 137 138camelFrom :: Char -> String -> String 139camelFrom c s = let (p:ps) = split c s 140 in concat $ p : map capitalize ps 141 where 142 split c' s' = map L.unpack $ L.split c' $ L.pack s' 143 capitalize t = toUpper (head t) : tail t 144 145 146data Wibble = Wibble { 147 wibbleString :: String 148 , wibbleInt :: Int 149 } deriving (Generic, Show, Eq) 150 151instance FromJSON Wibble 152 153instance ToJSON Wibble where 154 toJSON = genericToJSON defaultOptions 155 toEncoding = genericToEncoding defaultOptions 156 157-- Test that if we put a bomb in a data structure, but only demand 158-- part of it via lazy encoding, we do not unexpectedly fail. 159goodProducer :: Assertion 160goodProducer = assertEqual "partial encoding should not explode on undefined" 161 '{' (L.head (encode wibble)) 162 where 163 wibble = Wibble { 164 wibbleString = replicate k 'a' 165 , wibbleInt = 1 166 } 167 k | arch32bit = 4047 168 | otherwise = 4030 169 arch32bit = (maxBound :: Int) == 2147483647 170 171-- Test decoding various UTC time formats 172-- 173-- Note: the incomplete pattern matches for UTCTimes are completely 174-- intentional. The test expects these parses to succeed. If the 175-- pattern matches fails, there's a bug in either the test or in aeson 176-- and needs to be investigated. 177utcTimeGood :: Assertion 178utcTimeGood = do 179 let ts1 = "2015-01-01T12:13:00.00Z" :: LT.Text 180 let ts2 = "2015-01-01T12:13:00Z" :: LT.Text 181 -- 'T' between date and time is not required, can be space 182 let ts3 = "2015-01-03 12:13:00.00Z" :: LT.Text 183 let ts4 = "2015-01-03 12:13:00.125Z" :: LT.Text 184 let (Just (t1 :: UTCTime)) = parseWithAeson ts1 185 let (Just (t2 :: UTCTime)) = parseWithAeson ts2 186 let (Just (t3 :: UTCTime)) = parseWithAeson ts3 187 let (Just (t4 :: UTCTime)) = parseWithAeson ts4 188 assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts1) t1 189 assertEqual "utctime" (parseWithRead "%FT%T%QZ" ts2) t2 190 assertEqual "utctime" (parseWithRead "%F %T%QZ" ts3) t3 191 assertEqual "utctime" (parseWithRead "%F %T%QZ" ts4) t4 192 -- Time zones. Both +HHMM and +HH:MM are allowed for timezone 193 -- offset, and MM may be omitted. 194 let ts5 = "2015-01-01T12:30:00.00+00" :: LT.Text 195 let ts6 = "2015-01-01T12:30:00.00+01:15" :: LT.Text 196 let ts7 = "2015-01-01T12:30:00.00-02" :: LT.Text 197 let ts8 = "2015-01-01T22:00:00.00-03" :: LT.Text 198 let ts9 = "2015-01-01T22:00:00.00-04:30" :: LT.Text 199 let (Just (t5 :: UTCTime)) = parseWithAeson ts5 200 let (Just (t6 :: UTCTime)) = parseWithAeson ts6 201 let (Just (t7 :: UTCTime)) = parseWithAeson ts7 202 let (Just (t8 :: UTCTime)) = parseWithAeson ts8 203 let (Just (t9 :: UTCTime)) = parseWithAeson ts9 204 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T12:30:00.00Z") t5 205 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T11:15:00.00Z") t6 206 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t7 207 -- ts8 wraps around to the next day in UTC 208 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T01:00:00Z") t8 209 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-02T02:30:00Z") t9 210 211 -- Seconds in Time can be omitted 212 let ts10 = "2015-01-03T12:13Z" :: LT.Text 213 let ts11 = "2015-01-03 12:13Z" :: LT.Text 214 let ts12 = "2015-01-01T12:30-02" :: LT.Text 215 let (Just (t10 :: UTCTime)) = parseWithAeson ts10 216 let (Just (t11 :: UTCTime)) = parseWithAeson ts11 217 let (Just (t12 :: UTCTime)) = parseWithAeson ts12 218 assertEqual "utctime" (parseWithRead "%FT%H:%MZ" ts10) t10 219 assertEqual "utctime" (parseWithRead "%F %H:%MZ" ts11) t11 220 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-01-01T14:30:00Z") t12 221 222 -- leap seconds are included correctly 223 let ts13 = "2015-08-23T23:59:60.128+00" :: LT.Text 224 let (Just (t13 :: UTCTime)) = parseWithAeson ts13 225 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-08-23T23:59:60.128Z") t13 226 let ts14 = "2015-08-23T23:59:60.999999999999+00" :: LT.Text 227 let (Just (t14 :: UTCTime)) = parseWithAeson ts14 228 assertEqual "utctime" (parseWithRead "%FT%T%QZ" "2015-08-23T23:59:60.999999999999Z") t14 229 230 where 231 parseWithRead :: String -> LT.Text -> UTCTime 232 parseWithRead f s = 233 fromMaybe (error "parseTime input malformed") . parseTimeM True defaultTimeLocale f . LT.unpack $ s 234 parseWithAeson :: LT.Text -> Maybe UTCTime 235 parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] 236 237-- Test that a few non-timezone qualified timestamp formats get 238-- rejected if decoding to UTCTime. 239utcTimeBad :: Assertion 240utcTimeBad = do 241 verifyFailParse "2000-01-01T12:13:00" -- missing Zulu time not allowed (some TZ required) 242 verifyFailParse "2000-01-01 12:13:00" -- missing Zulu time not allowed (some TZ required) 243 verifyFailParse "2000-01-01" -- date only not OK 244 verifyFailParse "2000-01-01Z" -- date only not OK 245 verifyFailParse "2015-01-01T12:30:00.00+00Z" -- no Zulu if offset given 246 verifyFailParse "2015-01-01T12:30:00.00+00:00Z" -- no Zulu if offset given 247 verifyFailParse "2015-01-03 12:13:00.Z" -- decimal at the end but no digits 248 verifyFailParse "2015-01-03 12:13.000Z" -- decimal at the end, but no seconds 249 verifyFailParse "2015-01-03 23:59:61Z" -- exceeds allowed seconds per day 250 where 251 verifyFailParse (s :: LT.Text) = 252 let (dec :: Maybe UTCTime) = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""] in 253 assertEqual "verify failure" Nothing dec 254 255-- Non identifier keys should be escaped & enclosed in brackets 256formatErrorExample :: Assertion 257formatErrorExample = 258 let rhs = formatError [Index 0, Key "foo", Key "bar", Key "a.b.c", Key "", Key "'\\", Key "end"] "error msg" 259 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg" 260 in assertEqual "formatError example" lhs rhs 261 262formatPathExample :: Assertion 263formatPathExample = 264 let rhs = formatPath [Key "x", Index 0] 265 lhs = "$.x[0]" 266 in assertEqual "formatPath example" lhs rhs 267 268formatRelativePathExample :: Assertion 269formatRelativePathExample = 270 let rhs = formatPath [Key "x", Index 0] 271 lhs = ".x[0]" 272 in assertEqual "formatRelativePath example" lhs rhs 273 274------------------------------------------------------------------------------ 275-- Comparison (.:?) and (.:!) 276------------------------------------------------------------------------------ 277 278newtype T1 = T1 (Maybe Int) deriving (Eq, Show) 279newtype T2 = T2 (Maybe Int) deriving (Eq, Show) 280newtype T3 = T3 (Maybe Int) deriving (Eq, Show) 281 282instance FromJSON T1 where parseJSON = fmap T1 . withObject "T1" (.: "value") 283instance FromJSON T2 where parseJSON = fmap T2 . withObject "T2" (.:? "value") 284instance FromJSON T3 where parseJSON = fmap T3 . withObject "T3" (.:! "value") 285 286dotColonMark :: [Assertion] 287dotColonMark = [ 288 assertEqual ".: not-present" Nothing (decode ex1 :: Maybe T1) 289 , assertEqual ".: 42" (Just (T1 (Just 42))) (decode ex2 :: Maybe T1) 290 , assertEqual ".: null" (Just (T1 Nothing)) (decode ex3 :: Maybe T1) 291 292 , assertEqual ".:? not-present" (Just (T2 Nothing)) (decode ex1 :: Maybe T2) 293 , assertEqual ".:? 42" (Just (T2 (Just 42))) (decode ex2 :: Maybe T2) 294 , assertEqual ".:? null" (Just (T2 Nothing)) (decode ex3 :: Maybe T2) 295 296 , assertEqual ".:! not-present" (Just (T3 Nothing)) (decode ex1 :: Maybe T3) 297 , assertEqual ".:! 42" (Just (T3 (Just 42))) (decode ex2 :: Maybe T3) 298 , assertEqual ".:! null" Nothing (decode ex3 :: Maybe T3) 299 ] 300 where ex1 = "{}" 301 ex2 = "{\"value\": 42 }" 302 ex3 = "{\"value\": null }" 303 304------------------------------------------------------------------------------ 305-- Check that the hashes of two equal Value are the same 306------------------------------------------------------------------------------ 307 308hashableLaws :: [Assertion] 309hashableLaws = [ 310 assertEqual "Hashable Object" (hash a) (hash b) 311 ] 312 where 313 a = object ["223" .= False, "807882556" .= True] 314 b = object ["807882556" .= True, "223" .= False] 315 316------------------------------------------------------------------------------ 317-- Check that an alternative way to construct objects works 318------------------------------------------------------------------------------ 319 320objectConstruction :: [Assertion] 321objectConstruction = [ 322 assertEqual "Equal objects constructed differently" recommended notRecommended 323 ] 324 where 325 recommended = object ["foo" .= True, "bar" .= (-1 :: Int)] 326 notRecommended = Object (mconcat ["foo" .= True, "bar" .= (-1 :: Int)]) 327 328------------------------------------------------------------------------------- 329-- ToJSONKey 330------------------------------------------------------------------------------- 331 332newtype MyText = MyText Text 333 deriving (FromJSONKey) 334 335newtype MyText' = MyText' Text 336 337instance FromJSONKey MyText' where 338 fromJSONKey = fmap MyText' fromJSONKey 339 fromJSONKeyList = error "not used" 340 341fromJSONKeyAssertions :: [Assertion] 342fromJSONKeyAssertions = 343 [ assertIsCoerce "Text" (fromJSONKey :: FromJSONKeyFunction Text) 344 , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text)) 345 , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText) 346 347#if __GLASGOW_HASKELL__ >= 710 348 , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText') 349#endif 350 ] 351 where 352 assertIsCoerce _ (FromJSONKeyCoerce _) = pure () 353 assertIsCoerce n _ = assertFailure n 354 355#if __GLASGOW_HASKELL__ >= 710 356 assertIsCoerce' _ (FromJSONKeyCoerce _) = pure () 357 assertIsCoerce' n _ = pickWithRules (assertFailure n) (pure ()) 358 359-- | Pick the first when RULES are enabled, e.g. optimisations are on 360pickWithRules 361 :: a -- ^ Pick this when RULES are on 362 -> a -- ^ use this otherwise 363 -> a 364pickWithRules _ = id 365{-# NOINLINE pickWithRules #-} 366{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-} 367#endif 368 369------------------------------------------------------------------------------ 370-- Regressions 371------------------------------------------------------------------------------ 372 373-- A regression test for: https://github.com/bos/aeson/issues/351 374overlappingRegression :: FromJSON a => L.ByteString -> [a] 375overlappingRegression bs = fromMaybe [] $ decode bs 376 377issue351 :: [Assertion] 378issue351 = [ 379 assertEqual "Int" ([1, 2, 3] :: [Int]) $ overlappingRegression "[1, 2, 3]" 380 , assertEqual "Char" ("abc" :: String) $ overlappingRegression "\"abc\"" 381 , assertEqual "Char" ("" :: String) $ overlappingRegression "[\"a\", \"b\", \"c\"]" 382 ] 383 384------------------------------------------------------------------------------ 385-- Comparison between bytestring and text encoders 386------------------------------------------------------------------------------ 387 388ioTests :: IO [TestTree] 389ioTests = do 390 enc <- encoderComparisonTests 391 js <- jsonTestSuite 392 return [enc, js] 393 394encoderComparisonTests :: IO TestTree 395encoderComparisonTests = do 396 encoderTests <- forM testFiles $ \file0 -> do 397 let file = "benchmarks/json-data/" ++ file0 398 return $ testCase file $ do 399 inp <- L.readFile file 400 case eitherDecode inp of 401 Left err -> assertFailure $ "Decoding failure: " ++ err 402 Right val -> assertEqual "" (encode val) (encodeViaText val) 403 return $ testGroup "encoders" encoderTests 404 where 405 encodeViaText :: Value -> L.ByteString 406 encodeViaText = 407 TLE.encodeUtf8 . TLB.toLazyText . encodeToTextBuilder . toJSON 408 409 testFiles = 410 [ "example.json" 411 , "integers.json" 412 , "jp100.json" 413 , "numbers.json" 414 , "twitter10.json" 415 , "twitter20.json" 416 , "geometry.json" 417 , "jp10.json" 418 , "jp50.json" 419 , "twitter1.json" 420 , "twitter100.json" 421 , "twitter50.json" 422 ] 423 424-- A regression test for: https://github.com/bos/aeson/issues/293 425data MyRecord = MyRecord {_field1 :: Maybe Int, _field2 :: Maybe Bool} 426 427data MyRecord2 = MyRecord2 {_field3 :: Maybe Int, _field4 :: Maybe Bool} 428 deriving Generic 429 430instance ToJSON MyRecord2 431instance FromJSON MyRecord2 432 433-- A regression test for: https://github.com/bos/aeson/pull/477 434unescapeString :: Assertion 435unescapeString = do 436 assertEqual "Basic escaping" 437 (Right ("\" / \\ \b \f \n \r \t" :: String)) 438 (eitherDecode "\"\\\" \\/ \\\\ \\b \\f \\n \\r \\t\"") 439 440 forM_ [minBound .. maxBound :: Char] $ \ c -> 441 let s = LT.pack [c] in 442 assertEqual (printf "UTF-16 encoded '\\x%X'" c) 443 (Right s) (eitherDecode $ utf16Char s) 444 where 445 utf16Char = formatString . LBase16.encode . LT.encodeUtf16BE 446 formatString s 447 | L.length s == 4 = L.concat ["\"\\u", s, "\""] 448 | L.length s == 8 = 449 L.concat ["\"\\u", L.take 4 s, "\\u", L.drop 4 s, "\""] 450 | otherwise = error "unescapeString: can't happen" 451 452-- JSONTestSuite 453 454jsonTestSuiteTest :: FilePath -> TestTree 455jsonTestSuiteTest path = testCase fileName $ do 456 payload <- L.readFile path 457 let result = eitherDecode payload :: Either String Value 458 assertBool fileName $ case take 2 fileName of 459 "i_" -> isRight result 460 "n_" -> isLeft result 461 "y_" -> isRight result 462 _ -> isRight result -- test_transform tests have inconsistent names 463 where 464 fileName = takeFileName path 465 466-- Build a collection of tests based on the current contents of the 467-- JSONTestSuite test directories. 468 469jsonTestSuite :: IO TestTree 470jsonTestSuite = do 471 let suitePath = "tests/JSONTestSuite" 472 let suites = ["test_parsing", "test_transform"] 473 testPaths <- fmap (sort . concat) . forM suites $ \suite -> do 474 let dir = suitePath </> suite 475 entries <- getDirectoryContents dir 476 let ok name = takeExtension name == ".json" && 477 not (name `HashSet.member` blacklist) 478 return . map (dir </>) . filter ok $ entries 479 return $ testGroup "JSONTestSuite" $ map jsonTestSuiteTest testPaths 480 481-- The set expected-to-be-failing JSONTestSuite tests. 482-- Not all of these failures are genuine bugs. 483-- Of those that are bugs, not all are worth fixing. 484 485blacklist :: HashSet.HashSet String 486-- blacklist = HashSet.empty 487blacklist = _blacklist 488 489_blacklist :: HashSet.HashSet String 490_blacklist = HashSet.fromList [ 491 "i_object_key_lone_2nd_surrogate.json" 492 , "i_string_1st_surrogate_but_2nd_missing.json" 493 , "i_string_1st_valid_surrogate_2nd_invalid.json" 494 , "i_string_UTF-16LE_with_BOM.json" 495 , "i_string_UTF-16_invalid_lonely_surrogate.json" 496 , "i_string_UTF-16_invalid_surrogate.json" 497 , "i_string_UTF-8_invalid_sequence.json" 498 , "i_string_incomplete_surrogate_and_escape_valid.json" 499 , "i_string_incomplete_surrogate_pair.json" 500 , "i_string_incomplete_surrogates_escape_valid.json" 501 , "i_string_invalid_lonely_surrogate.json" 502 , "i_string_invalid_surrogate.json" 503 , "i_string_inverted_surrogates_U+1D11E.json" 504 , "i_string_lone_second_surrogate.json" 505 , "i_string_not_in_unicode_range.json" 506 , "i_string_truncated-utf-8.json" 507 , "i_structure_UTF-8_BOM_empty_object.json" 508 , "n_string_unescaped_crtl_char.json" 509 , "n_string_unescaped_newline.json" 510 , "n_string_unescaped_tab.json" 511 , "string_1_escaped_invalid_codepoint.json" 512 , "string_1_invalid_codepoint.json" 513 , "string_1_invalid_codepoints.json" 514 , "string_2_escaped_invalid_codepoints.json" 515 , "string_2_invalid_codepoints.json" 516 , "string_3_escaped_invalid_codepoints.json" 517 , "string_3_invalid_codepoints.json" 518 , "y_string_utf16BE_no_BOM.json" 519 , "y_string_utf16LE_no_BOM.json" 520 ] 521 522-- A regression test for: https://github.com/bos/aeson/pull/455 523data Foo a = FooNil | FooCons (Foo Int) 524 525pr455 :: Assertion 526pr455 = assertEqual "FooCons FooNil" 527 (toJSON foo) (liftToJSON undefined undefined foo) 528 where 529 foo :: Foo Int 530 foo = FooCons FooNil 531 532showOptions :: Assertion 533showOptions = 534 assertEqual 535 "Show Options" 536 ( "Options {" 537 ++ "fieldLabelModifier =~ \"exampleField\"" 538 ++ ", constructorTagModifier =~ \"ExampleConstructor\"" 539 ++ ", allNullaryToStringTag = True" 540 ++ ", omitNothingFields = False" 541 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}" 542 ++ ", unwrapUnaryRecords = False" 543 ++ ", tagSingleConstructors = False" 544 ++ ", rejectUnknownFields = False" 545 ++ "}") 546 (show defaultOptions) 547 548newtype SingleMaybeField = SingleMaybeField { smf :: Maybe Int } 549 deriving (Eq, Show, Generic) 550 551singleMaybeField :: [TestTree] 552singleMaybeField = do 553 (gName, gToJSON, gToEncoding, gFromJSON) <- 554 [ ("generic", genericToJSON opts, genericToEncoding opts, parse (genericParseJSON opts)) 555 , ("th", toJSON, toEncoding, fromJSON) ] 556 return $ 557 testCase gName $ do 558 assertEqual "toJSON" Null (gToJSON v) 559 assertEqual "toEncoding" (toEncoding (gToJSON v)) (gToEncoding v) 560 assertEqual "fromJSON" (Success v) (gFromJSON Null) 561 where 562 v = SingleMaybeField Nothing 563 opts = defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} 564 565 566newtype EmbeddedJSONTest = EmbeddedJSONTest Int 567 deriving (Eq, Show) 568 569instance FromJSON EmbeddedJSONTest where 570 parseJSON = 571 withObject "Object" $ \o -> 572 EmbeddedJSONTest <$> (o .: "prop" >>= withEmbeddedJSON "Quoted Int" parseJSON) 573 574withEmbeddedJSONTest :: Assertion 575withEmbeddedJSONTest = 576 assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}") 577 578-- Regression test for https://github.com/bos/aeson/issues/627 579newtype SingleFieldCon = SingleFieldCon Int deriving (Eq, Show, Generic) 580 581instance FromJSON SingleFieldCon where 582 parseJSON = genericParseJSON defaultOptions{unwrapUnaryRecords=True} 583 -- This option should have no effect on this type 584 585singleFieldCon :: Assertion 586singleFieldCon = 587 assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0") 588 589newtype UnknownFields = UnknownFields { knownField :: Int } 590 deriving (Eq, Show, Generic) 591newtype UnknownFieldsTag = UnknownFieldsTag { tag :: Int } 592 deriving (Eq, Show, Generic) 593newtype UnknownFieldsUnaryTagged = UnknownFieldsUnaryTagged { knownFieldUnaryTagged :: Int } 594 deriving (Eq, Show, Generic) 595data UnknownFieldsSum 596 = UnknownFields1 { knownField1 :: Int } 597 | UnknownFields2 { knownField2 :: Int } 598 deriving (Eq, Show, Generic) 599 600unknownFields :: [TestTree] 601unknownFields = concat 602 [ testsUnary 603 "unary-unknown" 604 (object [("knownField", Number 1), ("unknownField", Number 1)]) 605 (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFields) 606 , testsUnary 607 "unary-unknown-tag" 608 (object [("knownField", Number 1), ("tag", String "UnknownFields")]) 609 (Error "nknown fields: [\"tag\"]" :: Result UnknownFields) 610 , testsUnaryTag 611 "unary-explicit-tag" 612 (object [("tag", Number 1)]) 613 (Success $ UnknownFieldsTag 1) 614 , testsSum 615 "sum-tag" 616 (object [("knownField1", Number 1), ("tag", String "UnknownFields1")]) 617 (Success $ UnknownFields1 1) 618 , testsSum 619 "sum-unknown-in-branch" 620 (object [("knownField1", Number 1), ("knownField2", Number 1), ("tag", String "UnknownFields1")]) 621 (Error "nknown fields: [\"knownField2\"]" :: Result UnknownFieldsSum) 622 , testsSum 623 "sum-unknown" 624 (object [("knownField1", Number 1), ("unknownField", Number 1), ("tag", String "UnknownFields1")]) 625 (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsSum) 626 , testsTagged 627 "unary-tagged" 628 (object [("knownFieldUnaryTagged", Number 1), ("tag", String "UnknownFieldsUnaryTagged")]) 629 (Success $ UnknownFieldsUnaryTagged 1) 630 , -- Just a case to verify that the tag isn't optional, this is likely already tested by other unit tests 631 testsTagged 632 "unary-tagged-notag" 633 (object [("knownFieldUnaryTagged", Number 1)]) 634 (Error "key \"tag\" not found" :: Result UnknownFieldsUnaryTagged) 635 , testsTagged 636 "unary-tagged-unknown" 637 (object [ ("knownFieldUnaryTagged", Number 1), ("unknownField", Number 1) 638 , ("tag", String "UnknownFieldsUnaryTagged")]) 639 (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsUnaryTagged) 640 ] 641 where 642 opts = defaultOptions{rejectUnknownFields=True} 643 taggedOpts = opts{tagSingleConstructors=True} 644 assertApprox :: (Show a, Eq a) => Result a -> Result a -> IO () 645 assertApprox (Error expected) (Error actual) | expected `isSuffixOf` actual = return () 646 assertApprox expected actual = assertEqual "fromJSON" expected actual 647 testsBase :: (Show a, Eq a) => (Value -> Result a) -> (Value -> Result a) 648 -> String -> Value -> Result a -> [TestTree] 649 testsBase th g name value expected = 650 [ testCase (name ++ "-th") $ assertApprox expected (th value) 651 , testCase (name ++ "-generic") $ assertApprox expected (g value) 652 ] 653 testsUnary :: String -> Value -> Result UnknownFields -> [TestTree] 654 testsUnary = testsBase fromJSON (parse (genericParseJSON opts)) 655 testsUnaryTag :: String -> Value -> Result UnknownFieldsTag -> [TestTree] 656 testsUnaryTag = testsBase fromJSON (parse (genericParseJSON opts)) 657 testsSum :: String -> Value -> Result UnknownFieldsSum -> [TestTree] 658 testsSum = testsBase fromJSON (parse (genericParseJSON opts)) 659 testsTagged :: String -> Value -> Result UnknownFieldsUnaryTagged -> [TestTree] 660 testsTagged = testsBase fromJSON (parse (genericParseJSON taggedOpts)) 661 662testParser :: (Eq a, Show a) 663 => String -> Parser a -> S.ByteString -> Either String a -> TestTree 664testParser name json_ s expected = 665 testCase name (parseOnly json_ s @?= expected) 666 667keyOrdering :: [TestTree] 668keyOrdering = 669 [ testParser "json" json 670 "{\"k\":true,\"k\":false}" $ 671 Right (Object (HashMap.fromList [("k", Bool True)])) 672 , testParser "jsonLast" jsonLast 673 "{\"k\":true,\"k\":false}" $ 674 Right (Object (HashMap.fromList [("k", Bool False)])) 675 , testParser "jsonAccum" jsonAccum 676 "{\"k\":true,\"k\":false}" $ 677 Right (Object (HashMap.fromList [("k", Array (Vector.fromList [Bool True, Bool False]))])) 678 , testParser "jsonNoDup" jsonNoDup 679 "{\"k\":true,\"k\":false}" $ 680 Left "Failed reading: found duplicate key: \"k\"" 681 682 , testParser "json'" json' 683 "{\"k\":true,\"k\":false}" $ 684 Right (Object (HashMap.fromList [("k", Bool True)])) 685 , testParser "jsonLast'" jsonLast' 686 "{\"k\":true,\"k\":false}" $ 687 Right (Object (HashMap.fromList [("k", Bool False)])) 688 , testParser "jsonAccum'" jsonAccum' 689 "{\"k\":true,\"k\":false}" $ 690 Right (Object (HashMap.fromList [("k", Array (Vector.fromList [Bool True, Bool False]))])) 691 , testParser "jsonNoDup'" jsonNoDup' 692 "{\"k\":true,\"k\":false}" $ 693 Left "Failed reading: found duplicate key: \"k\"" 694 ] 695 696ratioDenominator0 :: Assertion 697ratioDenominator0 = 698 assertEqual "Ratio with denominator 0" 699 (Left "Error in $: Ratio denominator was 0") 700 (eitherDecode "{ \"numerator\": 1, \"denominator\": 0 }" :: Either String Rational) 701 702rationalNumber :: Assertion 703rationalNumber = 704 assertEqual "Ratio with denominator 0" 705 (Right 1.37) 706 (eitherDecode "1.37" :: Either String Rational) 707 708bigRationalDecoding :: Assertion 709bigRationalDecoding = 710 assertEqual "Decoding an Integer with a large exponent should fail" 711 (Left "Error in $: parsing Ratio failed, found a number with exponent 2000, but it must not be greater than 1024 or less than -1024") 712 ((eitherDecode :: L.ByteString -> Either String Rational) "1e2000") 713 714smallRationalDecoding :: Assertion 715smallRationalDecoding = 716 assertEqual "Decoding an Integer with a large exponent should fail" 717 (Left "Error in $: parsing Ratio failed, found a number with exponent -2000, but it must not be greater than 1024 or less than -1024") 718 ((eitherDecode :: L.ByteString -> Either String Rational) "1e-2000") 719 720 721bigScientificExponent :: Assertion 722bigScientificExponent = 723 assertEqual "Encoding an integral scientific with a large exponent should normalize it" 724 "1.0e2000" 725 (encode (scientific 1 2000 :: Scientific)) 726 727bigIntegerDecoding :: Assertion 728bigIntegerDecoding = 729 assertEqual "Decoding an Integer with a large exponent should fail" 730 (Left "Error in $: parsing Integer failed, found a number with exponent 2000, but it must not be greater than 1024") 731 ((eitherDecode :: L.ByteString -> Either String Integer) "1e2000") 732 733bigNaturalDecoding :: Assertion 734bigNaturalDecoding = 735 assertEqual "Decoding a Natural with a large exponent should fail" 736 (Left "Error in $: parsing Natural failed, found a number with exponent 2000, but it must not be greater than 1024") 737 ((eitherDecode :: L.ByteString -> Either String Natural) "1e2000") 738 739bigIntegerKeyDecoding :: Assertion 740bigIntegerKeyDecoding = 741 assertEqual "Decoding an Integer key with a large exponent should fail" 742 (Left "Error in $['1e2000']: parsing Integer failed, found a number with exponent 2000, but it must not be greater than 1024") 743 ((eitherDecode :: L.ByteString -> Either String (HashMap Integer Value)) "{ \"1e2000\": null }") 744 745bigNaturalKeyDecoding :: Assertion 746bigNaturalKeyDecoding = 747 assertEqual "Decoding an Integer key with a large exponent should fail" 748 (Left "Error in $['1e2000']: found a number with exponent 2000, but it must not be greater than 1024") 749 ((eitherDecode :: L.ByteString -> Either String (HashMap Natural Value)) "{ \"1e2000\": null }") 750 751-- A regression test for: https://github.com/bos/aeson/issues/757 752type family Fam757 :: * -> * 753type instance Fam757 = Maybe 754newtype Newtype757 a = MkNewtype757 (Fam757 a) 755 756deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord 757 758deriveToJSON defaultOptions ''Foo 759deriveToJSON1 defaultOptions ''Foo 760 761deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField 762 763deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFields 764deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsTag 765deriveJSON defaultOptions{tagSingleConstructors=True,rejectUnknownFields=True} ''UnknownFieldsUnaryTagged 766deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsSum 767 768deriveToJSON1 defaultOptions ''Newtype757 769