diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index 70a76cb7..03be2ed3 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 () @@ -366,7 +367,7 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs -- "type": "number" -- } -- ] --- } +-- }, -- "type": "array" -- } -- @@ -577,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 @@ -989,33 +990,37 @@ 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 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 & 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 @@ -1025,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..4066f26c 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) @@ -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/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 138cf498..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 @@ -205,7 +207,7 @@ personSchemaJSON = [aesonQQ| { "name": { "type": "string" }, "phone": { "type": "integer" }, - "email": { "type": "string" } + "email": { "type": "string", "nullable": true } }, "required": ["name", "phone"] } @@ -525,9 +527,8 @@ ispairSchemaJSON = [aesonQQ| "type": "array", "items": { "anyOf": [ - { "type": "null" }, { "type": "integer" }, - { "type": "string" } + { "type": "string", "nullable": true } ] }, "minItems": 2, @@ -578,6 +579,38 @@ pairwithrefSchemaJSON = [aesonQQ| } |] +-- ======================================================================== +-- PairWithNullRef (non-record product data type with nullable ref) +-- ======================================================================== +data PairWithNullRef = PairWithNullRef Integer (Maybe Point) + deriving (Show, Generic) + +instance ToJSON PairWithNullRef +instance ToSchema PairWithNullRef + +instance Arbitrary PairWithNullRef where + arbitrary = PairWithNullRef <$> arbitrary <*> arbitrary + +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) -- ======================================================================== @@ -585,7 +618,14 @@ pairwithrefSchemaJSON = [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 @@ -964,11 +1004,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/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) diff --git a/test/Data/OpenApi/SchemaSpec.hs b/test/Data/OpenApi/SchemaSpec.hs index 73893a4f..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 @@ -84,6 +85,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