'rejectUnknownFields'

Author: stevladimir

src/Data/OpenApi/Internal/Schema.hs

@@ -1041,6 +1041,7 @@ gproductSchema opts proxy = do
       & minItems ?~ sz
     _ -> mempty
       & type_ ?~ OpenApiObject
+      & additionalProperties .~ noAdditionalProperties opts
       & properties .~ foldl' (flip insProp) mempty recordFields
       & required .~ requiredProps
 
@@ -1113,6 +1114,7 @@ gsumConToSchemaWith ref opts _ = case schema of
           -- If it is not a record, we need to put subschema into "contents" field.
           _ | not isRecord -> Inline $ mempty
             & type_ ?~ OpenApiObject
+            & additionalProperties .~ noAdditionalProperties opts
             & required .~ [T.pack tagField]
             & properties . at (T.pack tagField) ?~ tagString
               -- If constructor is nullary, there is no content.
@@ -1124,6 +1126,7 @@ gsumConToSchemaWith ref opts _ = case schema of
           _ -> Inline $ mempty
             & allOf ?~ [Inline $ mempty
               & type_ ?~ OpenApiObject
+              & additionalProperties .~ noAdditionalProperties opts
               & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField])
               & properties . at (T.pack tagField) ?~ tagString]
             & if isRecord
@@ -1132,6 +1135,8 @@ gsumConToSchemaWith ref opts _ = case schema of
       UntaggedValue -> refOrEnum -- Aeson encodes nullary constructors as strings in this case.
       ObjectWithSingleField -> Inline $ mempty
         & type_ ?~ OpenApiObject
+        -- This is how "aeson" behaves
+        & additionalProperties ?~ AdditionalPropertiesAllowed False
         & required .~ [tag]
         & properties . at tag ?~ refOrNullary
       TwoElemArray -> Inline $ mempty
@@ -1192,6 +1197,13 @@ instance {-# OVERLAPPABLE #-} AllNullaryConstructors (C1 c f) where
 instance {-# OVERLAPPING #-} (Constructor c) => AllNullaryConstructors (C1 c U1) where
   nullaryConstructorsNames _ = Just [conName $ Proxy3 @c @_ @_]
 
+noAdditionalProperties :: SchemaOptions -> Maybe AdditionalProperties
+noAdditionalProperties opts = do
+  -- Missing 'additionalProperties' serve as set to 'true',
+  -- so we set this only when 'rejectUnknownFields' is 'false'.
+  guard $ rejectUnknownFields opts
+  Just $ AdditionalPropertiesAllowed False
+
 {- $setup
 >>> import Data.OpenApi
 >>> import Data.Aeson (encode)

src/Data/OpenApi/Internal/Schema/Validation.hs

@@ -412,21 +412,14 @@ validateObject o = withSchema $ \sch ->
 
     validateProps = withSchema $ \sch -> do
       for_ (objectToList o) $ \(keyToText -> k, v) ->
-        case v of
-          Null | not (k `elem` (sch ^. required)) -> valid  -- null is fine for non-required property
-          _ ->
-            case InsOrdHashMap.lookup k (sch ^. properties) of
-              Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
-              Just s  -> validateWithSchemaRef s v
+        case InsOrdHashMap.lookup k (sch ^. properties) of
+          Nothing -> checkMissing valid additionalProperties $ validateAdditional k v
+          Just s  -> validateWithSchemaRef s v
 
     validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid
     validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"
     validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v
 
-    unknownProperty :: Text -> Validation s a
-    unknownProperty pname = invalid $
-      "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"
-
 validateEnum :: Value -> Validation Schema ()
 validateEnum val = do
   check enum_ $ \xs ->

src/Data/OpenApi/SchemaOptions.hs

@@ -27,6 +27,7 @@ data SchemaOptions = SchemaOptions
     -- | Encode types with a single constructor as sums,
     -- so that `allNullaryToStringTag` and `sumEncoding` apply.
   , tagSingleConstructors :: Bool
+  , rejectUnknownFields :: Bool
   }
 
 -- | Default encoding @'SchemaOptions'@.
@@ -54,11 +55,12 @@ defaultSchemaOptions = fromAesonOptions Aeson.defaultOptions
 -- * 'unwrapUnaryRecords'
 -- * 'sumEncoding'
 -- * 'tagSingleConstructors'
+-- * 'rejectUnknownFields'
 --
 -- Note that these fields have no effect on `SchemaOptions`:
 --
 -- * 'Aeson.omitNothingFields'
--- * 'Aeson.rejectUnknownFields'
+-- * 'Aeson.allowOmittedFields' (introduced in @aeson-2.2@)
 --
 -- The rest is defined as in 'defaultSchemaOptions'.
 --
@@ -73,4 +75,5 @@ fromAesonOptions opts = SchemaOptions
   , unwrapUnaryRecords     = Aeson.unwrapUnaryRecords     opts
   , sumEncoding            = Aeson.sumEncoding            opts
   , tagSingleConstructors  = Aeson.tagSingleConstructors  opts
+  , rejectUnknownFields    = Aeson.rejectUnknownFields    opts
   }

test/Data/OpenApi/CommonTestTypes.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -1102,3 +1103,68 @@ unsignedIntsSchemaJSON = [aesonQQ|
   "required": ["uint32", "uint64"]
 }
 |]
+
+-- ========================================================================
+-- AdditionalProperties
+-- ========================================================================
+
+data AdditionalPropertiesYes = AdditionalPropertiesYes
+  { prop1 :: Bool
+  , prop2 :: Int
+  } deriving (Generic)
+instance ToSchema AdditionalPropertiesYes
+
+additionalPropYesSchema :: Value
+additionalPropYesSchema = [aesonQQ|
+{
+    "type": "object",
+    "properties": {
+        "prop1": {
+            "type": "boolean"
+        },
+        "prop2": {
+            "maximum": 9223372036854775807,
+            "minimum": -9223372036854775808,
+            "type": "integer"
+        }
+    },
+    "required": [
+        "prop1",
+        "prop2"
+    ]
+}
+|]
+
+data AdditionalPropertiesNo = AdditionalPropertiesNo
+  { prop1 :: Bool
+  , prop2 :: Int
+  } deriving (Generic)
+instance ToSchema AdditionalPropertiesNo where
+  declareNamedSchema = genericDeclareNamedSchema
+    defaultSchemaOptions{Data.OpenApi.rejectUnknownFields = True}
+
+additionalPropNoSchema :: Value
+additionalPropNoSchema = [aesonQQ|
+{
+    "type": "object",
+    "properties": {
+        "prop1": {
+            "type": "boolean"
+        },
+        "prop2": {
+            "maximum": 9223372036854775807,
+            "minimum": -9223372036854775808,
+            "type": "integer"
+        }
+    },
+    "required": [
+        "prop1",
+        "prop2"
+    ],
+    "additionalProperties": false
+}
+|]
+
+--------------------------
+--------------------------
+--------------------------

test/Data/OpenApi/Schema/ValidationSpec.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Data.OpenApi.Schema.ValidationSpec where
 
@@ -40,6 +41,8 @@ import           Data.OpenApi
 import           Data.OpenApi.Declare
 import           Data.OpenApi.Aeson.Compat (stringToKey)
 
+import           Data.OpenApi.CommonTestTypes
+  (AdditionalPropertiesYes, AdditionalPropertiesNo)
 import           Test.Hspec
 import           Test.Hspec.QuickCheck
 import           Test.QuickCheck
@@ -49,11 +52,17 @@ shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
 shouldValidate _ x = validateToJSON x == []
 
 shouldValidateValue :: (ToSchema a) => Proxy a -> Value -> Expectation
-shouldValidateValue px val = do
+shouldValidateValue px val = case validateValue px val of
+  [] -> pure ()
+  errors -> expectationFailure $ unlines errors
+
+shouldNotValidateValue :: (ToSchema a) => Proxy a -> Value -> [String] -> Expectation
+shouldNotValidateValue px val = shouldMatchList (validateValue px val)
+
+validateValue :: (ToSchema a) => Proxy a -> Value -> [String]
+validateValue px val =
   let (defs, sch) = runDeclare (declareSchema px) mempty
-  case validateJSON defs sch val of
-    [] -> pure ()
-    errors -> expectationFailure $ unlines errors
+  in validateJSON defs sch val
 
 shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool
 shouldNotValidate f = not . null . validateJSON defs sch . f
@@ -123,7 +132,19 @@ spec = do
     prop "invalidColorToJSON"         $ shouldNotValidate invalidColorToJSON
     prop "invalidPaintToJSON"         $ shouldNotValidate invalidPaintToJSON
     prop "invalidLightToJSON"         $ shouldNotValidate invalidLightToJSON
-    prop "invalidButtonImagesToJSON"  $ shouldNotValidate invalidButtonImagesToJSON
+    describe "rejectUnknownFields" $ do
+      let val = [aesonQQ|
+        {
+          "prop1" : true,
+          "prop2" : 1,
+          "prop3" : null
+        }
+        |]
+      it "disabled" $
+        shouldValidateValue (Proxy @AdditionalPropertiesYes) val
+      it "enabled" $
+        shouldNotValidateValue (Proxy @AdditionalPropertiesNo) val
+          ["additionalProperties=false but extra property \"prop3\" found"]
 
 main :: IO ()
 main = hspec spec

test/Data/OpenApi/SchemaSpec.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE QuasiQuotes #-}
 module Data.OpenApi.SchemaSpec where
 
@@ -115,6 +116,9 @@ spec = do
   describe "Bounded Enum key mapping" $ do
     context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON
     context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON
+  describe "rejectUnknownFields" $ do
+    describe "disabled" $ checkToSchema (Proxy @AdditionalPropertiesYes) additionalPropYesSchema
+    describe "enabled" $ checkToSchema (Proxy @AdditionalPropertiesNo) additionalPropNoSchema
 
 main :: IO ()
 main = hspec spec