From b0b23305a281544e39df3da445dfab941cffc692 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20Vandecr=C3=A8me?= Date: Wed, 8 Feb 2023 17:58:30 +0100 Subject: [PATCH 1/3] Add `nullable: true` on optional fields --- src/Data/OpenApi/Internal/Schema.hs | 11 ++++++++- test/Data/OpenApi/CommonTestTypes.hs | 35 +++++++++++++++++++++++++--- test/Data/OpenApi/SchemaSpec.hs | 1 + 3 files changed, 43 insertions(+), 4 deletions(-) diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index 70a76cb7..2d4ec8b3 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -20,6 +20,7 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For TypeErrors {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# LANGUAGE LambdaCase #-} module Data.OpenApi.Internal.Schema where import Prelude () @@ -1009,7 +1010,15 @@ addItem add x j@(Just (OpenApiItemsObject ref)) withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema withFieldSchema opts _ isRequiredField schema = do - ref <- gdeclareSchemaRef opts (Proxy :: Proxy f) + let setNullable = if isRequiredField + then id + else \case + ref@(Ref _) -> Inline $ mempty & anyOf ?~ [ ref + , Inline $ mempty & nullable ?~ True + & type_ ?~ OpenApiObject + ] + Inline s -> Inline $ s & nullable ?~ True + ref <- setNullable <$> gdeclareSchemaRef opts (Proxy :: Proxy f) return $ if T.null fname then schema diff --git a/test/Data/OpenApi/CommonTestTypes.hs b/test/Data/OpenApi/CommonTestTypes.hs index 138cf498..b90e79a3 100644 --- a/test/Data/OpenApi/CommonTestTypes.hs +++ b/test/Data/OpenApi/CommonTestTypes.hs @@ -205,7 +205,7 @@ personSchemaJSON = [aesonQQ| { "name": { "type": "string" }, "phone": { "type": "integer" }, - "email": { "type": "string" } + "email": { "type": "string", "nullable": true } }, "required": ["name", "phone"] } @@ -527,7 +527,7 @@ ispairSchemaJSON = [aesonQQ| "anyOf": [ { "type": "null" }, { "type": "integer" }, - { "type": "string" } + { "type": "string", "nullable": true } ] }, "minItems": 2, @@ -964,11 +964,40 @@ singleMaybeFieldSchemaJSON = [aesonQQ| "type": "object", "properties": { - "singleMaybeField": { "type": "string" } + "singleMaybeField": { "type": "string", "nullable": true } } } |] +-- ======================================================================== +-- Painter (record with an optional reference) +-- ======================================================================== + +data Painter = Painter { painterName :: String + , favoriteColor :: Maybe Color + } + deriving (Generic) + +instance ToSchema Painter + +painterSchemaJSON :: Value +painterSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "painterName": { "type": "string" }, + "favoriteColor": { + "anyOf": [ + { "$ref": "#/components/schemas/Color" }, + { "type": "object", "nullable": true } + ] + } + }, + "required": ["painterName"] +} +|] + -- ======================================================================== -- Natural Language (single field data with recursive fields) -- ======================================================================== diff --git a/test/Data/OpenApi/SchemaSpec.hs b/test/Data/OpenApi/SchemaSpec.hs index 73893a4f..29e382fd 100644 --- a/test/Data/OpenApi/SchemaSpec.hs +++ b/test/Data/OpenApi/SchemaSpec.hs @@ -84,6 +84,7 @@ spec = do context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON + context "Painter (record with an optional reference)" $ checkToSchema (Proxy :: Proxy Painter) painterSchemaJSON context "Natural Language (single field data with recursive fields)" $ checkToSchemaDeclare (Proxy :: Proxy Predicate) predicateSchemaDeclareJSON context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON From e3fc8020c5608965e7e74edea6b3943a3c0a4716 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20Vandecr=C3=A8me?= Date: Thu, 9 Feb 2023 11:29:00 +0100 Subject: [PATCH 2/3] Simplify tuples with nullable element schema generation --- src/Data/OpenApi/Internal/Schema.hs | 27 +++++++---------- .../OpenApi/Internal/Schema/Validation.hs | 2 +- src/Data/OpenApi/Schema/Validation.hs | 2 +- test/Data/OpenApi/CommonTestTypes.hs | 29 ++++++++++++++++++- test/Data/OpenApi/SchemaSpec.hs | 1 + 5 files changed, 42 insertions(+), 19 deletions(-) diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index 2d4ec8b3..03be2ed3 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -367,7 +367,7 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs -- "type": "number" -- } -- ] --- } +-- }, -- "type": "array" -- } -- @@ -578,7 +578,7 @@ sketchStrictSchema = go . toJSON & type_ ?~ OpenApiArray & maxItems ?~ fromIntegral sz & minItems ?~ fromIntegral sz - & items ?~ OpenApiItemsArray (map (Inline . go) (V.toList xs)) + & items ?~ OpenApiItemsObject (Inline $ mempty & anyOf ?~ (map (Inline . go) (V.toList xs))) & uniqueItems ?~ allUnique & enum_ ?~ [js] where @@ -990,22 +990,19 @@ gdeclareSchemaRef opts proxy = do return $ Ref (Reference name) _ -> Inline <$> gdeclareSchema opts proxy -addItem :: (Referenced Schema -> [Referenced Schema] -> [Referenced Schema]) - -> Referenced Schema - -> Maybe OpenApiItems - -> Maybe OpenApiItems -addItem _ x Nothing = Just (OpenApiItemsArray [x]) -addItem add x (Just (OpenApiItemsArray xs)) = case xs of +addItem :: Referenced Schema -> Maybe OpenApiItems -> Maybe OpenApiItems +addItem x Nothing = Just (OpenApiItemsArray [x]) +addItem x (Just (OpenApiItemsArray xs)) = case xs of [] -> Just $ OpenApiItemsObject x [x'] | x == x' -> Just $ OpenApiItemsObject x _ | x `elem` xs -> Just $ OpenApiItemsObject $ Inline $ mempty & anyOf ?~ xs - _ -> Just $ OpenApiItemsObject $ Inline $ mempty & anyOf ?~ (add x xs) -addItem add x (Just (OpenApiItemsObject (Inline s))) = - let appendMaybe = Just . maybe [x] (\xs -> if x `elem` xs then xs else add x xs) + _ -> Just $ OpenApiItemsObject $ Inline $ mempty & anyOf ?~ (xs ++ [x]) +addItem x (Just (OpenApiItemsObject (Inline s))) = + let appendMaybe = Just . maybe [x] (\xs -> if x `elem` xs then xs else xs ++ [x]) in Just $ OpenApiItemsObject $ Inline $ s & anyOf %~ appendMaybe -addItem add x j@(Just (OpenApiItemsObject ref)) +addItem x j@(Just (OpenApiItemsObject ref)) | x == ref = j - | otherwise = Just $ OpenApiItemsObject $ Inline $ mempty & anyOf ?~ (add x [ref]) + | otherwise = Just $ OpenApiItemsObject $ Inline $ mempty & anyOf ?~ [ref, x] withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema @@ -1023,8 +1020,7 @@ withFieldSchema opts _ isRequiredField schema = do if T.null fname then schema & type_ ?~ OpenApiArray - & items %~ (if isRequiredField then id else addItem (:) nullSchema) - & items %~ addItem (\x xs -> xs ++ [x]) ref + & items %~ addItem ref & maxItems %~ Just . maybe 1 (+1) -- increment maxItems & minItems %~ Just . maybe 1 (+1) -- increment minItems else schema @@ -1034,7 +1030,6 @@ withFieldSchema opts _ isRequiredField schema = do then required %~ (++ [fname]) else id where - nullSchema = Inline $ mempty & type_ ?~ OpenApiNull fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p))) -- | Optional record fields. diff --git a/src/Data/OpenApi/Internal/Schema/Validation.hs b/src/Data/OpenApi/Internal/Schema/Validation.hs index 293b3736..9efff0fb 100644 --- a/src/Data/OpenApi/Internal/Schema/Validation.hs +++ b/src/Data/OpenApi/Internal/Schema/Validation.hs @@ -35,7 +35,7 @@ import Data.Aeson hiding (Result) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as KeyMap #endif -import Data.Foldable (asum, for_, sequenceA_, +import Data.Foldable (for_, sequenceA_, traverse_) #if !MIN_VERSION_aeson(2,0,0) import Data.HashMap.Strict (HashMap) diff --git a/src/Data/OpenApi/Schema/Validation.hs b/src/Data/OpenApi/Schema/Validation.hs index 9728ceef..f123b926 100644 --- a/src/Data/OpenApi/Schema/Validation.hs +++ b/src/Data/OpenApi/Schema/Validation.hs @@ -75,7 +75,7 @@ import Data.OpenApi.Internal.Schema.Validation -- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String]) -- ["expected JSON value of type OpenApiString"] -- >>> validateToJSON (123, Nothing :: Maybe String) --- ["expected JSON value of type OpenApiString"] +-- ["Value not valid under any of 'anyOf' schemas: Null"] -- -- However, when @'Maybe' a@ is a type of a record field, -- validation takes @'required'@ property of the @'Schema'@ diff --git a/test/Data/OpenApi/CommonTestTypes.hs b/test/Data/OpenApi/CommonTestTypes.hs index b90e79a3..7b510f84 100644 --- a/test/Data/OpenApi/CommonTestTypes.hs +++ b/test/Data/OpenApi/CommonTestTypes.hs @@ -525,7 +525,6 @@ ispairSchemaJSON = [aesonQQ| "type": "array", "items": { "anyOf": [ - { "type": "null" }, { "type": "integer" }, { "type": "string", "nullable": true } ] @@ -578,6 +577,34 @@ pairwithrefSchemaJSON = [aesonQQ| } |] +-- ======================================================================== +-- PairWithNullRef (non-record product data type with nullable ref) +-- ======================================================================== +data PairWithNullRef = PairWithNullRef Integer (Maybe Point) + deriving (Generic) + +instance ToSchema PairWithNullRef + +pairwithnullrefSchemaJSON :: Value +pairwithnullrefSchemaJSON = [aesonQQ| +{ + "type": "array", + "items": { + "anyOf": [ + { "type": "integer" }, + { + "anyOf": [ + { "$ref": "#/components/schemas/Point"} , + { "type": "object", "nullable": true } + ] + } + ] + }, + "minItems": 2, + "maxItems": 2 +} +|] + -- ======================================================================== -- Point (record data type with custom fieldLabelModifier) -- ======================================================================== diff --git a/test/Data/OpenApi/SchemaSpec.hs b/test/Data/OpenApi/SchemaSpec.hs index 29e382fd..fd34e251 100644 --- a/test/Data/OpenApi/SchemaSpec.hs +++ b/test/Data/OpenApi/SchemaSpec.hs @@ -71,6 +71,7 @@ spec = do context "Either String Int" $ checkToSchema (Proxy :: Proxy EitherStringInt) eitherSchemaJSON context "ISHomogeneousPair" $ checkToSchema (Proxy :: Proxy ISHomogeneousPair) ishomogeneouspairSchemaJSON context "PairWithRef" $ checkToSchema (Proxy :: Proxy PairWithRef) pairwithrefSchemaJSON + context "PairWithNullRef" $ checkToSchema (Proxy :: Proxy PairWithNullRef) pairwithnullrefSchemaJSON context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON context "Point5 (many field record)" $ do checkToSchema (Proxy :: Proxy Point5) point5SchemaJSON From 3e14430f4d874d88736dbab098c98047aca6917a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antoine=20Vandecr=C3=A8me?= Date: Thu, 9 Feb 2023 12:34:39 +0100 Subject: [PATCH 3/3] Fix validation when nullable is set --- .../OpenApi/Internal/Schema/Validation.hs | 3 +++ test/Data/OpenApi/CommonTestTypes.hs | 19 ++++++++++++++++--- test/Data/OpenApi/Schema/ValidationSpec.hs | 2 ++ 3 files changed, 21 insertions(+), 3 deletions(-) diff --git a/src/Data/OpenApi/Internal/Schema/Validation.hs b/src/Data/OpenApi/Internal/Schema/Validation.hs index 9efff0fb..4066f26c 100644 --- a/src/Data/OpenApi/Internal/Schema/Validation.hs +++ b/src/Data/OpenApi/Internal/Schema/Validation.hs @@ -501,6 +501,9 @@ validateSchemaType val = withSchema $ \sch -> _ -> case (sch ^. type_, val) of + -- Type must be set for nullable to have effect + -- See https://github.com/OAI/OpenAPI-Specification/blob/main/versions/3.0.3.md#fixed-fields-20 + (Just _, Null) | sch ^. nullable == Just True -> valid (Just OpenApiNull, Null) -> valid (Just OpenApiBoolean, Bool _) -> valid (Just OpenApiInteger, Number n) -> validateInteger n diff --git a/test/Data/OpenApi/CommonTestTypes.hs b/test/Data/OpenApi/CommonTestTypes.hs index 7b510f84..04681d7b 100644 --- a/test/Data/OpenApi/CommonTestTypes.hs +++ b/test/Data/OpenApi/CommonTestTypes.hs @@ -7,8 +7,9 @@ module Data.OpenApi.CommonTestTypes where import Prelude () import Prelude.Compat -import Data.Aeson (ToJSON (..), ToJSONKey (..), Value) +import Data.Aeson (ToJSON (..), ToJSONKey (..), Value, genericToJSON) import Data.Aeson.QQ.Simple +import qualified Data.Aeson as Aeson import Data.Aeson.Types (toJSONKeyText) import Data.Char import Data.Map (Map) @@ -17,6 +18,7 @@ import Data.Set (Set) import qualified Data.Text as Text import Data.Word import GHC.Generics +import Test.QuickCheck (Arbitrary (..)) import Data.OpenApi @@ -581,10 +583,14 @@ pairwithrefSchemaJSON = [aesonQQ| -- PairWithNullRef (non-record product data type with nullable ref) -- ======================================================================== data PairWithNullRef = PairWithNullRef Integer (Maybe Point) - deriving (Generic) + deriving (Show, Generic) +instance ToJSON PairWithNullRef instance ToSchema PairWithNullRef +instance Arbitrary PairWithNullRef where + arbitrary = PairWithNullRef <$> arbitrary <*> arbitrary + pairwithnullrefSchemaJSON :: Value pairwithnullrefSchemaJSON = [aesonQQ| { @@ -612,7 +618,14 @@ pairwithnullrefSchemaJSON = [aesonQQ| data Point = Point { pointX :: Double , pointY :: Double - } deriving (Generic) + } deriving (Show, Generic) + +instance ToJSON Point where + toJSON = genericToJSON Aeson.defaultOptions + { Aeson.fieldLabelModifier = map toLower . drop (length "point") } + +instance Arbitrary Point where + arbitrary = Point <$> arbitrary <*> arbitrary instance ToSchema Point where declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions diff --git a/test/Data/OpenApi/Schema/ValidationSpec.hs b/test/Data/OpenApi/Schema/ValidationSpec.hs index 8e92576f..24a89e62 100644 --- a/test/Data/OpenApi/Schema/ValidationSpec.hs +++ b/test/Data/OpenApi/Schema/ValidationSpec.hs @@ -36,6 +36,7 @@ import GHC.Generics import Data.OpenApi import Data.OpenApi.Declare import Data.OpenApi.Aeson.Compat (stringToKey) +import Data.OpenApi.CommonTestTypes (PairWithNullRef) import Test.Hspec import Test.Hspec.QuickCheck @@ -93,6 +94,7 @@ spec = do prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int])) prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int)) prop "(String, Paint)" $ shouldValidate (Proxy :: Proxy (String, Paint)) + prop "PairWithNullRef" $ shouldValidate (Proxy :: Proxy PairWithNullRef) prop "Person" $ shouldValidate (Proxy :: Proxy Person) prop "Color" $ shouldValidate (Proxy :: Proxy Color) prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)