Fix schema for Maybe

src/Data/OpenApi/Internal/Schema.hs

@@ -624,7 +624,9 @@ instance ToSchema Float       where declareNamedSchema = plain . paramSchemaToSc
 instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
 
 instance ToSchema a => ToSchema (Maybe a) where
-  declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
+  declareNamedSchema _ = do
+    ref <- declareSchemaRef (Proxy @a)
+    pure $ unnamed $ mempty & oneOf ?~ [Inline $ mempty & type_ ?~ OpenApiNull, ref]
 
 instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where
   -- To match Aeson instance
@@ -1017,10 +1019,7 @@ instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (
 instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
   gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
 
-instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
-  gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
-
-instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
+instance ToSchema c => GToSchema (K1 i c) where
   gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
 
 instance ( GSumToSchema f

src/Data/OpenApi/Schema/Validation.hs

@@ -34,10 +34,13 @@ import Data.OpenApi.Internal.Schema.Validation
 -- $setup
 -- >>> import Control.Lens
 -- >>> import Data.Aeson
+-- >>> import Data.Aeson.QQ.Simple
 -- >>> import Data.Proxy
 -- >>> import Data.OpenApi
+-- >>> import Data.OpenApi.Declare
 -- >>> import GHC.Generics
 -- >>> :set -XDeriveGeneric
+-- >>> :set -XQuasiQuotes
 
 -- $howto
 --
@@ -67,24 +70,18 @@ import Data.OpenApi.Internal.Schema.Validation
 
 -- $maybe
 --
--- Because @'Maybe' a@ has the same schema as @a@, validation
--- generally fails for @null@ JSON:
---
--- >>> validateToJSON (Nothing :: Maybe String)
--- ["expected JSON value of type OpenApiString"]
--- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])
--- ["expected JSON value of type OpenApiString"]
--- >>> validateToJSON (123, Nothing :: Maybe String)
--- ["expected JSON value of type OpenApiString"]
---
--- However, when @'Maybe' a@ is a type of a record field,
--- validation takes @'required'@ property of the @'Schema'@
--- into account:
+-- The behavior is in line with "aeson" behavior for derived instances.
+-- When @'Maybe' a@ is a type of a record field,
+-- validation accepts both ommited field and null as a field value:
 --
 -- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic
 -- >>> instance ToJSON Person
 -- >>> instance ToSchema Person
--- >>> validateToJSON (Person "Nick" (Just 24))
+-- >>> let (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy Person)) mempty
+-- >>> let validate = validateJSON defs sch
+-- >>> validate [aesonQQ|{"name" : "Nick", "age" : 18}|]
+-- []
+-- >>> validate [aesonQQ|{"name" : "Nick", "email" : null}|]
 -- []
--- >>> validateToJSON (Person "Nick" Nothing)
+-- >>> validate [aesonQQ|{"name" : "Nick"}|]
 -- []

test/Data/OpenApi/CommonTestTypes.hs

@@ -205,7 +205,14 @@ personSchemaJSON = [aesonQQ|
     {
       "name":   { "type": "string"  },
       "phone":  { "type": "integer" },
-      "email":  { "type": "string"  }
+      "email":
+        {
+          "oneOf" :
+            [
+              { "type" : "null" },
+              { "type": "string" }
+            ]
+        }
     },
   "required": ["name", "phone"]
 }
@@ -867,7 +874,14 @@ singleMaybeFieldSchemaJSON = [aesonQQ|
   "type": "object",
   "properties":
     {
-      "singleMaybeField": { "type": "string" }
+      "singleMaybeField":
+        {
+          "oneOf" :
+            [
+              { "type" : "null" },
+              { "type": "string" }
+            ]
+        }
     }
 }
 |]

test/Data/OpenApi/Schema/GeneratorSpec.hs

@@ -68,7 +68,7 @@ spec = do
     prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
     prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
     prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
-    -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
+    prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
     prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
     prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
     prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

test/Data/OpenApi/Schema/ValidationSpec.hs

@@ -1,18 +1,21 @@
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE PackageImports      #-}
+{-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Data.OpenApi.Schema.ValidationSpec where
 
 import           Control.Applicative
 import           Control.Lens                        ((&), (.~), (?~))
+import           Control.Monad
 import           Data.Aeson
 #if MIN_VERSION_aeson(2,0,0)
 import qualified Data.Aeson.Key as Key
 import qualified Data.Aeson.KeyMap as KeyMap
 #endif
+import           Data.Aeson.QQ.Simple
 import           Data.Aeson.Types
 import           Data.Hashable                       (Hashable)
 import           Data.HashMap.Strict                 (HashMap)
@@ -45,6 +48,13 @@ import           Test.QuickCheck.Instances           ()
 shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
 shouldValidate _ x = validateToJSON x == []
 
+shouldValidateValue :: (ToSchema a) => Proxy a -> Value -> Expectation
+shouldValidateValue px val = do
+  let (defs, sch) = runDeclare (declareSchema px) mempty
+  case validateJSON defs sch val of
+    [] -> pure ()
+    errors -> expectationFailure $ unlines errors
+
 shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool
 shouldNotValidate f = not . null . validateJSON defs sch . f
   where
@@ -75,7 +85,7 @@ spec = do
     prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
     prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
     prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
-    -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
+    prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
     prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
     prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
     prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
@@ -92,7 +102,11 @@ spec = do
     prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
     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 "Person" $ shouldValidate (Proxy :: Proxy Person)
+    describe "Person: record with optional field" $ do
+      let px = Proxy :: Proxy Person
+      it "optional field is Just" $ shouldValidateValue px personJustEmailField
+      it "optional field is Null" $ shouldValidateValue px personNullEmailField
+      it "optional field is omitted" $ shouldValidateValue px personOmittedEmailField
     prop "Color" $ shouldValidate (Proxy :: Proxy Color)
     prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
     prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
@@ -128,6 +142,32 @@ instance ToSchema Person
 instance Arbitrary Person where
   arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
 
+personJustEmailField :: Value
+personJustEmailField = [aesonQQ|
+  {
+    "name" : "foo",
+    "phone" : 1,
+    "email" : "foo@email.com"
+  }
+|]
+
+personNullEmailField :: Value
+personNullEmailField = [aesonQQ|
+  {
+    "name" : "foo",
+    "phone" : 1,
+    "email" : null
+  }
+|]
+
+personOmittedEmailField :: Value
+personOmittedEmailField = [aesonQQ|
+  {
+    "name" : "foo",
+    "phone" : 1
+  }
+|]
+
 invalidPersonToJSON :: Person -> Value
 invalidPersonToJSON Person{..} = object
   [ stringToKey "personName"  .= toJSON name