@@ -33,15 +33,15 @@ import Data.Aeson.Parser
3333 ( json, jsonLast, jsonAccum, jsonNoDup
3434 , json', jsonLast', jsonAccum', jsonNoDup')
3535import Data.Aeson.Types
36− ( Options(..), Result(Success), ToJSON(..), Value(Array, Bool, Null, Object)
37− , camelTo, camelTo2, defaultOptions, formatPath, formatRelativePath
38− , omitNothingFields, parse)
36+ ( Options(..), Result(Success, Error), ToJSON(..)
37+ , Value(Array, Bool, Null, Number, Object, String), camelTo, camelTo2
38+ , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse)
3939import Data.Attoparsec.ByteString (Parser, parseOnly)
4040import Data.Char (toUpper)
4141import Data.Either.Compat (isLeft, isRight)
4242import Data.Hashable (hash)
4343import Data.HashMap.Strict (HashMap)
44−import Data.List (sort)
44+import Data.List (sort, isSuffixOf)
4545import Data.Maybe (fromMaybe)
4646import Data.Scientific (Scientific, scientific)
4747import Data.Tagged (Tagged(..))
@@ -112,6 +112,7 @@ tests = testGroup "unit" [
112112 , testGroup "SingleMaybeField" singleMaybeField
113113 , testCase "withEmbeddedJSON" withEmbeddedJSONTest
114114 , testCase "SingleFieldCon" singleFieldCon
115+ , testGroup "UnknownFields" unknownFields
115116 , testGroup "Ordering of object keys" keyOrdering
116117 , testCase "Ratio with denominator 0" ratioDenominator0
117118 , testCase "Rational parses number" rationalNumber
@@ -539,6 +540,7 @@ showOptions =
539540 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"
540541 ++ ", unwrapUnaryRecords = False"
541542 ++ ", tagSingleConstructors = False"
543+ ++ ", rejectUnknownFields = False"
542544 ++ "}")
543545 (show defaultOptions)
544546
@@ -583,6 +585,79 @@ singleFieldCon :: Assertion
583585singleFieldCon =
584586 assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0")
585587
588+newtype UnknownFields = UnknownFields { knownField :: Int }
589+ deriving (Eq, Show, Generic)
590+newtype UnknownFieldsTag = UnknownFieldsTag { tag :: Int }
591+ deriving (Eq, Show, Generic)
592+newtype UnknownFieldsUnaryTagged = UnknownFieldsUnaryTagged { knownFieldUnaryTagged :: Int }
593+ deriving (Eq, Show, Generic)
594+data UnknownFieldsSum
595+ = UnknownFields1 { knownField1 :: Int }
596+ | UnknownFields2 { knownField2 :: Int }
597+ deriving (Eq, Show, Generic)
598+
599+unknownFields :: [TestTree]
600+unknownFields = concat
601+ [ testsUnary
602+ "unary-unknown"
603+ (object [("knownField", Number 1), ("unknownField", Number 1)])
604+ (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFields)
605+ , testsUnary
606+ "unary-unknown-tag"
607+ (object [("knownField", Number 1), ("tag", String "UnknownFields")])
608+ (Error "nknown fields: [\"tag\"]" :: Result UnknownFields)
609+ , testsUnaryTag
610+ "unary-explicit-tag"
611+ (object [("tag", Number 1)])
612+ (Success $ UnknownFieldsTag 1)
613+ , testsSum
614+ "sum-tag"
615+ (object [("knownField1", Number 1), ("tag", String "UnknownFields1")])
616+ (Success $ UnknownFields1 1)
617+ , testsSum
618+ "sum-unknown-in-branch"
619+ (object [("knownField1", Number 1), ("knownField2", Number 1), ("tag", String "UnknownFields1")])
620+ (Error "nknown fields: [\"knownField2\"]" :: Result UnknownFieldsSum)
621+ , testsSum
622+ "sum-unknown"
623+ (object [("knownField1", Number 1), ("unknownField", Number 1), ("tag", String "UnknownFields1")])
624+ (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsSum)
625+ , testsTagged
626+ "unary-tagged"
627+ (object [("knownFieldUnaryTagged", Number 1), ("tag", String "UnknownFieldsUnaryTagged")])
628+ (Success $ UnknownFieldsUnaryTagged 1)
629+ , -- Just a case to verify that the tag isn't optional, this is likely already tested by other unit tests
630+ testsTagged
631+ "unary-tagged-notag"
632+ (object [("knownFieldUnaryTagged", Number 1)])
633+ (Error "key \"tag\" not found" :: Result UnknownFieldsUnaryTagged)
634+ , testsTagged
635+ "unary-tagged-unknown"
636+ (object [ ("knownFieldUnaryTagged", Number 1), ("unknownField", Number 1)
637+ , ("tag", String "UnknownFieldsUnaryTagged")])
638+ (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsUnaryTagged)
639+ ]
640+ where
641+ opts = defaultOptions{rejectUnknownFields=True}
642+ taggedOpts = opts{tagSingleConstructors=True}
643+ assertApprox :: (Show a, Eq a) => Result a -> Result a -> IO ()
644+ assertApprox (Error expected) (Error actual) | expected `isSuffixOf` actual = return ()
645+ assertApprox expected actual = assertEqual "fromJSON" expected actual
646+ testsBase :: (Show a, Eq a) => (Value -> Result a) -> (Value -> Result a)
647+ -> String -> Value -> Result a -> [TestTree]
648+ testsBase th g name value expected =
649+ [ testCase (name ++ "-th") $ assertApprox expected (th value)
650+ , testCase (name ++ "-generic") $ assertApprox expected (g value)
651+ ]
652+ testsUnary :: String -> Value -> Result UnknownFields -> [TestTree]
653+ testsUnary = testsBase fromJSON (parse (genericParseJSON opts))
654+ testsUnaryTag :: String -> Value -> Result UnknownFieldsTag -> [TestTree]
655+ testsUnaryTag = testsBase fromJSON (parse (genericParseJSON opts))
656+ testsSum :: String -> Value -> Result UnknownFieldsSum -> [TestTree]
657+ testsSum = testsBase fromJSON (parse (genericParseJSON opts))
658+ testsTagged :: String -> Value -> Result UnknownFieldsUnaryTagged -> [TestTree]
659+ testsTagged = testsBase fromJSON (parse (genericParseJSON taggedOpts))
660+
586661testParser :: (Eq a, Show a)
587662 => String -> Parser a -> S.ByteString -> Either String a -> TestTree
588663testParser name json_ s expected =
@@ -678,3 +753,8 @@ deriveToJSON defaultOptions ''Foo
678753deriveToJSON1 defaultOptions ''Foo
679754
680755deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField
756+
757+deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFields
758+deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsTag
759+deriveJSON defaultOptions{tagSingleConstructors=True,rejectUnknownFields=True} ''UnknownFieldsUnaryTagged
760+deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsSum