Skip to content

Commit bef1ee9

Browse files
stevladimirstevladimir
committed
Fix schema for Maybe
1 parent 5eff1a1 commit bef1ee9

5 files changed

Lines changed: 75 additions & 25 deletions

File tree

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

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -624,7 +624,9 @@ instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSc
624624
instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
625625

626626
instance ToSchema a => ToSchema (Maybe a) where
627-
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
627+
declareNamedSchema _ = do
628+
ref <- declareSchemaRef (Proxy @a)
629+
pure $ unnamed $ mempty & oneOf ?~ [Inline $ mempty & type_ ?~ OpenApiNull, ref]
628630

629631
instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where
630632
-- To match Aeson instance
@@ -1017,10 +1019,7 @@ instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (
10171019
instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
10181020
gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
10191021

1020-
instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
1021-
gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
1022-
1023-
instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
1022+
instance ToSchema c => GToSchema (K1 i c) where
10241023
gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
10251024

10261025
instance ( GSumToSchema f

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

Lines changed: 12 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -34,10 +34,13 @@ import Data.OpenApi.Internal.Schema.Validation
3434
-- $setup
3535
-- >>> import Control.Lens
3636
-- >>> import Data.Aeson
37+
-- >>> import Data.Aeson.QQ.Simple
3738
-- >>> import Data.Proxy
3839
-- >>> import Data.OpenApi
40+
-- >>> import Data.OpenApi.Declare
3941
-- >>> import GHC.Generics
4042
-- >>> :set -XDeriveGeneric
43+
-- >>> :set -XQuasiQuotes
4144

4245
-- $howto
4346
--
@@ -67,24 +70,18 @@ import Data.OpenApi.Internal.Schema.Validation
6770

6871
-- $maybe
6972
--
70-
-- Because @'Maybe' a@ has the same schema as @a@, validation
71-
-- generally fails for @null@ JSON:
72-
--
73-
-- >>> validateToJSON (Nothing :: Maybe String)
74-
-- ["expected JSON value of type OpenApiString"]
75-
-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])
76-
-- ["expected JSON value of type OpenApiString"]
77-
-- >>> validateToJSON (123, Nothing :: Maybe String)
78-
-- ["expected JSON value of type OpenApiString"]
79-
--
80-
-- However, when @'Maybe' a@ is a type of a record field,
81-
-- validation takes @'required'@ property of the @'Schema'@
82-
-- into account:
73+
-- The behavior is in line with "aeson" behavior for derived instances.
74+
-- When @'Maybe' a@ is a type of a record field,
75+
-- validation accepts both ommited field and null as a field value:
8376
--
8477
-- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic
8578
-- >>> instance ToJSON Person
8679
-- >>> instance ToSchema Person
87-
-- >>> validateToJSON (Person "Nick" (Just 24))
80+
-- >>> let (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy Person)) mempty
81+
-- >>> let validate = validateJSON defs sch
82+
-- >>> validate [aesonQQ|{"name" : "Nick", "age" : 18}|]
83+
-- []
84+
-- >>> validate [aesonQQ|{"name" : "Nick", "email" : null}|]
8885
-- []
89-
-- >>> validateToJSON (Person "Nick" Nothing)
86+
-- >>> validate [aesonQQ|{"name" : "Nick"}|]
9087
-- []

‎test/Data/OpenApi/CommonTestTypes.hs‎

Lines changed: 16 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -205,7 +205,14 @@ personSchemaJSON = [aesonQQ|
205205
{
206206
"name": { "type": "string" },
207207
"phone": { "type": "integer" },
208-
"email": { "type": "string" }
208+
"email":
209+
{
210+
"oneOf" :
211+
[
212+
{ "type" : "null" },
213+
{ "type": "string" }
214+
]
215+
}
209216
},
210217
"required": ["name", "phone"]
211218
}
@@ -867,7 +874,14 @@ singleMaybeFieldSchemaJSON = [aesonQQ|
867874
"type": "object",
868875
"properties":
869876
{
870-
"singleMaybeField": { "type": "string" }
877+
"singleMaybeField":
878+
{
879+
"oneOf" :
880+
[
881+
{ "type" : "null" },
882+
{ "type": "string" }
883+
]
884+
}
871885
}
872886
}
873887
|]

‎test/Data/OpenApi/Schema/GeneratorSpec.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -68,7 +68,7 @@ spec = do
6868
prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
6969
prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
7070
prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
71-
-- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
71+
prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
7272
prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
7373
prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
7474
prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

‎test/Data/OpenApi/Schema/ValidationSpec.hs‎

Lines changed: 42 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,21 @@
11
{-# LANGUAGE CPP #-}
22
{-# LANGUAGE DeriveGeneric #-}
33
{-# LANGUAGE PackageImports #-}
4+
{-# LANGUAGE QuasiQuotes #-}
45
{-# LANGUAGE RecordWildCards #-}
56
{-# LANGUAGE ScopedTypeVariables #-}
67
{-# OPTIONS_GHC -fno-warn-orphans #-}
78
module Data.OpenApi.Schema.ValidationSpec where
89

910
import Control.Applicative
1011
import Control.Lens ((&), (.~), (?~))
12+
import Control.Monad
1113
import Data.Aeson
1214
#if MIN_VERSION_aeson(2,0,0)
1315
import qualified Data.Aeson.Key as Key
1416
import qualified Data.Aeson.KeyMap as KeyMap
1517
#endif
18+
import Data.Aeson.QQ.Simple
1619
import Data.Aeson.Types
1720
import Data.Hashable (Hashable)
1821
import Data.HashMap.Strict (HashMap)
@@ -45,6 +48,13 @@ import Test.QuickCheck.Instances ()
4548
shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
4649
shouldValidate _ x = validateToJSON x == []
4750

51+
shouldValidateValue :: (ToSchema a) => Proxy a -> Value -> Expectation
52+
shouldValidateValue px val = do
53+
let (defs, sch) = runDeclare (declareSchema px) mempty
54+
case validateJSON defs sch val of
55+
[] -> pure ()
56+
errors -> expectationFailure $ unlines errors
57+
4858
shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool
4959
shouldNotValidate f = not . null . validateJSON defs sch . f
5060
where
@@ -75,7 +85,7 @@ spec = do
7585
prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
7686
prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
7787
prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
78-
-- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
88+
prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
7989
prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
8090
prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
8191
prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
@@ -92,7 +102,11 @@ spec = do
92102
prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
93103
prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
94104
prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
95-
prop "Person" $ shouldValidate (Proxy :: Proxy Person)
105+
describe "Person: record with optional field" $ do
106+
let px = Proxy :: Proxy Person
107+
it "optional field is Just" $ shouldValidateValue px personJustEmailField
108+
it "optional field is Null" $ shouldValidateValue px personNullEmailField
109+
it "optional field is omitted" $ shouldValidateValue px personOmittedEmailField
96110
prop "Color" $ shouldValidate (Proxy :: Proxy Color)
97111
prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
98112
prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
@@ -128,6 +142,32 @@ instance ToSchema Person
128142
instance Arbitrary Person where
129143
arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
130144

145+
personJustEmailField :: Value
146+
personJustEmailField = [aesonQQ|
147+
{
148+
"name" : "foo",
149+
"phone" : 1,
150+
"email" : "foo@email.com"
151+
}
152+
|]
153+
154+
personNullEmailField :: Value
155+
personNullEmailField = [aesonQQ|
156+
{
157+
"name" : "foo",
158+
"phone" : 1,
159+
"email" : null
160+
}
161+
|]
162+
163+
personOmittedEmailField :: Value
164+
personOmittedEmailField = [aesonQQ|
165+
{
166+
"name" : "foo",
167+
"phone" : 1
168+
}
169+
|]
170+
131171
invalidPersonToJSON :: Person -> Value
132172
invalidPersonToJSON Person{..} = object
133173
[ stringToKey "personName" .= toJSON name

0 commit comments

Comments
 (0)