Bring ToSchema in line with aeson

openapi3.cabal

@@ -136,6 +136,7 @@ test-suite spec
     hspec-discover:hspec-discover >=2.5.5 && <2.12
 
   other-modules:
+    GenericsSpec
     SpecCommon
     Data.OpenApiSpec
     Data.OpenApi.CommonTestTypes

src/Data/OpenApi.hs

@@ -372,7 +372,7 @@ import Data.OpenApi.Internal
 -- >>> instance ToSchema Error
 -- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Error)
 -- {
---     "oneOf": [
+--     "anyOf": [
 --         {
 --             "properties": {
 --                 "tag": {

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

@@ -28,8 +28,8 @@ import           Prelude                             ()
 import           Prelude.Compat
 
 import           Control.Applicative
-import           Control.Lens                        hiding (allOf)
-import           Control.Monad                       (forM, forM_, when)
+import           Control.Lens                        hiding (allOf, anyOf)
+import           Control.Monad                       (foldM, forM, forM_, when)
 
 import           Data.Aeson                          hiding (Result)
 #if MIN_VERSION_aeson(2,0,0)
@@ -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 ->
@@ -481,15 +474,19 @@ inferParamSchemaTypes sch = concat
   ]
 
 validateSchemaType :: Value -> Validation Schema ()
-validateSchemaType val = withSchema $ \sch ->
+validateSchemaType val = withSchema $ \sch -> do
+  let validateSub var = (True <$ validateWithSchemaRef var val) <|> (return False)
   case sch of
     (view oneOf -> Just variants) -> do
-      res <- forM variants $ \var ->
-        (True <$ validateWithSchemaRef var val) <|> (return False)
+      res <- forM variants validateSub
       case length $ filter id res of
         0 -> invalid $ "Value not valid under any of 'oneOf' schemas: " ++ show val
         1 -> valid
         _ -> invalid $ "Value matches more than one of 'oneOf' schemas: " ++ show val
+    (view anyOf -> Just variants) -> do
+      res <- foldM (\res var -> if res then pure res else validateSub var) False variants
+      if res then valid else
+        invalid $ "Value does not match any of 'anyOf' schemas: " ++ show val
     (view allOf -> Just variants) -> do
       -- Default semantics for Validation Monad will abort when at least one
       -- variant does not match.

src/Data/OpenApi/SchemaOptions.hs

@@ -24,6 +24,10 @@ data SchemaOptions = SchemaOptions
   , unwrapUnaryRecords :: Bool
     -- | Specifies how to encode constructors of a sum datatype.
   , sumEncoding :: Aeson.SumEncoding
+    -- | Encode types with a single constructor as sums,
+    -- so that `allNullaryToStringTag` and `sumEncoding` apply.
+  , tagSingleConstructors :: Bool
+  , rejectUnknownFields :: Bool
   }
 
 -- | Default encoding @'SchemaOptions'@.
@@ -39,14 +43,7 @@ data SchemaOptions = SchemaOptions
 -- }
 -- @
 defaultSchemaOptions :: SchemaOptions
-defaultSchemaOptions = SchemaOptions
-  { fieldLabelModifier = id
-  , constructorTagModifier = id
-  , datatypeNameModifier = id
-  , allNullaryToStringTag = True
-  , unwrapUnaryRecords = False
-  , sumEncoding = Aeson.defaultTaggedObject
-  }
+defaultSchemaOptions = fromAesonOptions Aeson.defaultOptions
 
 -- | Convert 'Aeson.Options' to 'SchemaOptions'.
 --
@@ -56,21 +53,27 @@ defaultSchemaOptions = SchemaOptions
 -- * 'constructorTagModifier'
 -- * 'allNullaryToStringTag'
 -- * 'unwrapUnaryRecords'
+-- * 'sumEncoding'
+-- * 'tagSingleConstructors'
+-- * 'rejectUnknownFields'
 --
 -- Note that these fields have no effect on `SchemaOptions`:
 --
 -- * 'Aeson.omitNothingFields'
--- * 'Aeson.tagSingleConstructors'
+-- * 'Aeson.allowOmittedFields' (introduced in @aeson-2.2@)
 --
 -- The rest is defined as in 'defaultSchemaOptions'.
 --
 -- @since 2.2.1
 --
 fromAesonOptions :: Aeson.Options -> SchemaOptions
-fromAesonOptions opts = defaultSchemaOptions
+fromAesonOptions opts = SchemaOptions
   { fieldLabelModifier     = Aeson.fieldLabelModifier     opts
   , constructorTagModifier = Aeson.constructorTagModifier opts
+  , datatypeNameModifier   = id
   , allNullaryToStringTag  = Aeson.allNullaryToStringTag  opts
   , 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 #-}
 
@@ -7,7 +8,9 @@ module Data.OpenApi.CommonTestTypes where
 import           Prelude               ()
 import           Prelude.Compat
 
-import           Data.Aeson            (ToJSON (..), ToJSONKey (..), Value)
+import           Data.Aeson            (FromJSON(..), ToJSON (..), ToJSONKey (..), Value)
+import qualified Data.Aeson            as Aeson
+import qualified Data.Aeson.Types      as Aeson
 import           Data.Aeson.QQ.Simple
 import           Data.Aeson.Types      (toJSONKeyText)
 import           Data.Char
@@ -28,14 +31,49 @@ data Unit = Unit deriving (Generic)
 instance ToParamSchema Unit
 instance ToSchema Unit
 
-unitSchemaJSON :: Value
-unitSchemaJSON = [aesonQQ|
+unitParamSchemaJSON :: Value
+unitParamSchemaJSON = [aesonQQ|
 {
   "type": "string",
   "enum": ["Unit"]
 }
 |]
 
+unitSchemaJSON :: Value
+unitSchemaJSON = [aesonQQ|
+{
+  "type": "array",
+  "items": {},
+  "maxItems": 0,
+  "example": []
+}
+|]
+
+data UnitTagged = UnitTagged
+  deriving (Generic)
+
+instance ToSchema UnitTagged where
+  declareNamedSchema = genericDeclareNamedSchema
+    defaultSchemaOptions{Data.OpenApi.tagSingleConstructors = True}
+
+instance FromJSON UnitTagged where
+  parseJSON = Aeson.genericParseJSON Aeson.defaultOptions{Aeson.tagSingleConstructors = True}
+
+instance ToJSON UnitTagged where
+  toJSON = Aeson.genericToJSON Aeson.defaultOptions{Aeson.tagSingleConstructors = True}
+
+unitTaggedSchemaJSON :: Value
+unitTaggedSchemaJSON = [aesonQQ|
+{
+  "enum":
+    [
+      "UnitTagged"
+    ],
+   "type": "string"
+}
+|]
+
+
 -- ========================================================================
 -- Color (enum)
 -- ========================================================================
@@ -278,7 +316,7 @@ instance ToSchema Character
 characterSchemaJSON :: Value
 characterSchemaJSON = [aesonQQ|
 {
-  "oneOf": [
+  "anyOf": [
     {
       "required": [
         "tag",
@@ -329,7 +367,7 @@ characterSchemaJSON = [aesonQQ|
 characterInlinedSchemaJSON :: Value
 characterInlinedSchemaJSON = [aesonQQ|
 {
-  "oneOf": [
+  "anyOf": [
     {
       "required": [
         "tag",
@@ -415,7 +453,7 @@ characterInlinedSchemaJSON = [aesonQQ|
 characterInlinedPlayerSchemaJSON :: Value
 characterInlinedPlayerSchemaJSON = [aesonQQ|
 {
-  "oneOf": [
+  "anyOf": [
     {
       "required": [
         "tag",
@@ -644,7 +682,7 @@ instance ToSchema Light where
 lightSchemaJSON :: Value
 lightSchemaJSON = [aesonQQ|
 {
-  "oneOf": [
+  "anyOf": [
     {
       "required": [
         "tag"
@@ -726,7 +764,7 @@ lightSchemaJSON = [aesonQQ|
 lightInlinedSchemaJSON :: Value
 lightInlinedSchemaJSON = [aesonQQ|
 {
-  "oneOf": [
+  "anyOf": [
     {
       "required": [
         "tag"
@@ -935,7 +973,7 @@ predicateSchemaDeclareJSON = [aesonQQ|
 [
   {
     "Predicate": {
-      "oneOf": [
+      "anyOf": [
         {
           "properties": {
             "contents": { "$ref": "#/components/schemas/Noun" },
@@ -976,7 +1014,7 @@ predicateSchemaDeclareJSON = [aesonQQ|
       "type": "object"
     },
     "Modifier": {
-      "oneOf": [
+      "anyOf": [
         {
           "properties": {
             "contents": { "$ref": "#/components/schemas/Noun" },
@@ -1065,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/ParamSchemaSpec.hs

@@ -27,7 +27,7 @@ checkToParamSchema proxy js = (toParamSchema proxy :: Schema) <=> js
 spec :: Spec
 spec = do
   describe "Generic ToParamSchema" $ do
-    context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON
+    context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitParamSchemaJSON
     context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON
     context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON
     context "Unary records" $ do

test/Data/OpenApi/Schema/GeneratorSpec.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedLists   #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports    #-}
@@ -90,6 +91,8 @@ spec = do
     prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)
     prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)
     prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)
+    prop "SingleUnary" $ shouldValidate (Proxy :: Proxy (SingleUnary Int))
+    prop "SingleUnaryTagged" $ shouldValidate (Proxy :: Proxy (SingleUnaryTagged Int))
 
 -- =============================
 -- Data types and bunk instances
@@ -166,3 +169,22 @@ instance ToSchema WrongPropType where
         & type_ ?~ OpenApiObject
         & properties .~ [("propE", boolSchema)]
         & required .~ ["propE"]
+
+data SingleUnary a = SingleUnary a
+  deriving (Show, Generic)
+
+instance (FromJSON a) => FromJSON (SingleUnary a)
+instance (ToSchema a) => ToSchema (SingleUnary a)
+
+data SingleUnaryTagged a = SingleUnaryTagged a
+  deriving (Show, Generic)
+
+instance (FromJSON a) => FromJSON (SingleUnaryTagged a) where
+  parseJSON = genericParseJSON
+    defaultOptions{Data.Aeson.tagSingleConstructors = True}
+instance (ToJSON a) => ToJSON (SingleUnaryTagged a) where
+  toJSON = genericToJSON
+    defaultOptions{Data.Aeson.tagSingleConstructors = True}
+instance (ToSchema a) => ToSchema (SingleUnaryTagged a) where
+  declareNamedSchema = genericDeclareNamedSchema
+    defaultSchemaOptions{Data.OpenApi.tagSingleConstructors = True}