Merge pull request #3 from avandecreme/nullable

Add `nullable: true`  on optional fields

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.

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

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'@

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,14 +579,53 @@ 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)
 -- ========================================================================
 
 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)
 -- ========================================================================

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)

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