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