Merge pull request #774 from mbj/fix/reject-unknown-fields-with-field-label-modifier

Fix reject unknown fields with field label modifier

Author: bergmark

Data/Aeson/TH.hs

@@ -939,7 +939,7 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
           if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id
       knownFields = appE [|H.fromList|] $ listE $
           map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $
-              tagFieldNameAppender $ map nameBase fields
+              tagFieldNameAppender $ map (fieldLabel opts) fields
       checkUnknownRecords =
           caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields)
               [ match (listP []) (normalB [|return ()|]) []

Data/Aeson/Types/FromJSON.hs

@@ -1260,15 +1260,15 @@ instance (ProductFromJSON arity f, ProductSize f
 --------------------------------------------------------------------------------
 
 class FieldNames f where
-    fieldNames :: f a -> [Text] -> [Text]
+    fieldNames :: f a -> [String] -> [String]
 
 instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where
     fieldNames _ =
       fieldNames (undefined :: a x) .
       fieldNames (undefined :: b y)
 
 instance (Selector s) => FieldNames (S1 s f) where
-    fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)
+    fieldNames _ = (selName (undefined :: M1 _i s _f _p) :)
 
 class RecordFromJSON arity f where
     recordParseJSON
@@ -1282,9 +1282,10 @@ instance ( FieldNames f
         \obj -> checkUnknown obj >> recordParseJSON' p obj
         where
             knownFields :: H.HashMap Text ()
-            knownFields = H.fromList $ map (,()) $
-                fieldNames (undefined :: f a)
-                [pack (tagFieldName (sumEncoding opts)) | fromTaggedSum]
+            knownFields = H.fromList $ map ((,()) . pack) $
+                [tagFieldName (sumEncoding opts) | fromTaggedSum] <>
+                (fieldLabelModifier opts <$> fieldNames (undefined :: f a) [])
+
             checkUnknown =
                 if not (rejectUnknownFields opts)
                 then \_ -> return ()

changelog.md

@@ -1,5 +1,8 @@
 For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md).
 
+## 1.5.0.0
+* Fix bug in `rejectUnknownFields` not respecting `fieldLabelModifier`, thanks to Markus Schirp.
+
 #### 1.4.7.1
 
 * GHC 8.10 compatibility, thanks to Ryan Scott.

tests/ErrorMessages.hs

@@ -31,6 +31,7 @@ tests :: [TestTree]
 tests =
   [ aesonGoldenTest "simple" "tests/golden/simple.expected" output
   , aesonGoldenTest "generic" "tests/golden/generic.expected" (outputGeneric G)
+  , aesonGoldenTest "generic" "tests/golden/th.expected" (outputGeneric TH)
   ]
 
 output :: Output
@@ -140,7 +141,7 @@ outputGeneric choice = concat
       (select
         thSomeTypeParseJSONRejectUnknownFields
         gSomeTypeParseJSONRejectUnknownFields)
-      [ "{\"tag\": \"record\", \"testOne\": 1.0, \"testZero\": 1}"
+      [ "{\"tag\": \"record\", \"testone\": 1.0, \"testZero\": 1}"
       , "{\"testZero\": 1}"
       , "{\"tag\": \"record\", \"testone\": true, \"testtwo\": null, \"testthree\": null}"
       ]

tests/golden/generic.expected

@@ -34,7 +34,7 @@ Error in $: not enough input. Expecting json list value
 SomeType (reject unknown fields)
 Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testZero"]
 Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found
-Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testtwo","testone","testthree"]
+Error in $.testone: parsing Double failed, unexpected Boolean
 Foo (reject unknown fields)
 Error in $: parsing Types.Foo(Foo) failed, unknown fields: ["tag"]
 Foo (reject unknown fields, tagged single)

tests/golden/th.expected

@@ -0,0 +1,48 @@
+OneConstructor
+Error in $: When parsing the constructor OneConstructor of type Types.OneConstructor expected Array but got String.
+Error in $: When parsing the constructor OneConstructor of type Types.OneConstructor expected an empty Array but got Array of length 1.
+Nullary
+Error in $: When parsing Types.Nullary expected a String with the tag of a constructor but got X.
+Error in $: When parsing Types.Nullary expected String but got Array.
+SomeType (tagged)
+Error in $: parsing Int failed, expected Number, but encountered Boolean
+Error in $: key "contents" not found
+Error in $: When parsing the record record of type Types.SomeType the key testone was not present.
+Error in $.testone: parsing Double failed, unexpected Boolean
+Error in $: When parsing Types.SomeType expected an Object with a tag field where the value is one of [nullary, unary, product, record, list], but got X.
+Error in $: key "tag" not found
+Error in $: When parsing Types.SomeType expected Object but got Array.
+SomeType (single-field)
+Error in $: parsing Int failed, expected Number, but encountered Object
+Error in $: parsing Int failed, expected Number, but encountered Array
+Error in $: When parsing Types.SomeType expected an Object with a single tag/contents pair where the tag is one of [nullary, unary, product, record, list], but got X.
+Error in $: When parsing Types.SomeType expected an Object with a single tag/contents pair but got 2 pairs.
+Error in $: When parsing Types.SomeType expected an Object with a single tag/contents pair but got 0 pairs.
+Error in $: When parsing Types.SomeType expected Object but got Array.
+Error in $: not enough input. Expecting ':'
+Error in $: not enough input. Expecting object value
+Error in $: not enough input. Expecting ',' or '}'
+SomeType (two-element array)
+Error in $: parsing Int failed, expected Number, but encountered Boolean
+Error in $: When parsing the constructor Record of type Types.SomeType expected Object but got Null.
+Error in $: When parsing Types.SomeType expected a 2-element Array with a tag and contents element where the tag is one of [nullary, unary, product, record, list], but got X.
+Error in $: When parsing Types.SomeType expected an Array of 2 elements where the first element is a String but got Null at the first element.
+Error in $: When parsing Types.SomeType expected an Array of 2 elements but got 0 elements
+Error in $: When parsing Types.SomeType expected Array but got Object.
+Error in $: not enough input. Expecting ',' or ']'
+Error in $: not enough input. Expecting json list value
+SomeType (reject unknown fields)
+Error in $: Unknown fields: ["testZero"]
+Error in $: key "tag" not found
+Error in $.testone: parsing Double failed, unexpected Boolean
+Foo (reject unknown fields)
+Error in $: Unknown fields: ["tag"]
+Foo (reject unknown fields, tagged single)
+Error in $: Unknown fields: ["unknownField"]
+EitherTextInt
+Error in $: When parsing the constructor NoneNullary of type Types.EitherTextInt expected String but got String.
+Error in $: When parsing the constructor NoneNullary of type Types.EitherTextInt expected String but got Array.
+Product2 Int Bool
+Error in $: expected Bool, but encountered Null
+Error in $: When parsing the constructor Product2 of type Types.Product2 expected Array of length 2 but got Array of length 0.
+Error in $: When parsing the constructor Product2 of type Types.Product2 expected Array but got Object.