git.iko.soy/typeable/swagger2
on master help sign in
Merge pull request #159 from tvision-insights/bool-additional-properties

Add support for additionalProperties with Bool value

commit2aafbaea36d698d0d27354b59e2062c4030ac93e authorNickolay Kudasov <fizruk@users.noreply.github.com> dateFri 29 Jun 2018, 13:47 (8 years ago) parentbbffa0642f69fd
7 files changed+65−7
compare with master
unifiedsplit
src/Data/Swagger.hs+1 src/Data/Swagger/Internal.hs+14−1 src/Data/Swagger/Internal/Schema.hs+1−1 src/Data/Swagger/Internal/Schema/Validation.hs+5−1 stack.yaml+2−2 test/Data/Swagger/Schema/ValidationSpec.hs+27−1 test/Data/SwaggerSpec.hs+15−1
src/Data/Swagger.hs+1
@@ -77,6 +77,7 @@ module Data.Swagger (
7777 SwaggerItems(..),
7878 Xml(..),
7979 Pattern,
80+ AdditionalProperties(..),
8081
8182 -- ** Responses
8283 Responses(..),
src/Data/Swagger/Internal.hs+14−1
@@ -557,7 +557,7 @@ data Schema = Schema
557557
558558 , _schemaAllOf :: Maybe [Referenced Schema]
559559 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
560− , _schemaAdditionalProperties :: Maybe (Referenced Schema)
560+ , _schemaAdditionalProperties :: Maybe AdditionalProperties
561561
562562 , _schemaDiscriminator :: Maybe Text
563563 , _schemaReadOnly :: Maybe Bool
@@ -802,6 +802,11 @@ instance IsString a => IsString (Referenced a) where
802802
803803newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)
804804
805+data AdditionalProperties
806+ = AdditionalPropertiesAllowed Bool
807+ | AdditionalPropertiesSchema (Referenced Schema)
808+ deriving (Eq, Show, Data, Typeable)
809+
805810-- =======================================================================
806811-- Monoid instances
807812-- =======================================================================
@@ -1125,6 +1130,10 @@ instance ToJSON (ParamSchema k) where
11251130 toJSON = sopSwaggerGenericToJSONWithOpts $
11261131 mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
11271132
1133+instance ToJSON AdditionalProperties where
1134+ toJSON (AdditionalPropertiesAllowed b) = toJSON b
1135+ toJSON (AdditionalPropertiesSchema s) = toJSON s
1136+
11281137-- =======================================================================
11291138-- Manual FromJSON instances
11301139-- =======================================================================
@@ -1280,6 +1289,10 @@ instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where
12801289instance FromJSON (ParamSchema 'SwaggerKindSchema) where
12811290 parseJSON = sopSwaggerGenericParseJSON
12821291
1292+instance FromJSON AdditionalProperties where
1293+ parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b
1294+ parseJSON js = AdditionalPropertiesSchema <$> parseJSON js
1295+
12831296-------------------------------------------------------------------------------
12841297-- TH splices
12851298-------------------------------------------------------------------------------
src/Data/Swagger/Internal/Schema.hs+1−1
@@ -529,7 +529,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
529529 schema <- declareSchemaRef (Proxy :: Proxy v)
530530 return $ unnamed $ mempty
531531 & type_ .~ SwaggerObject
532− & additionalProperties ?~ schema
532+ & additionalProperties ?~ AdditionalPropertiesSchema schema
533533
534534instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
535535 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
src/Data/Swagger/Internal/Schema/Validation.hs+5−1
@@ -312,9 +312,13 @@ validateObject o = withSchema $ \sch ->
312312 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
313313 _ ->
314314 case InsOrdHashMap.lookup k (sch ^. properties) of
315− Nothing -> checkMissing (unknownProperty k) additionalProperties $ \s -> validateWithSchemaRef s v
315+ Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
316316 Just s -> validateWithSchemaRef s v
317317
318+ validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid
319+ validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"
320+ validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v
321+
318322 unknownProperty :: Text -> Validation s a
319323 unknownProperty name = invalid $
320324 "property " <> show name <> " is found in JSON value, but it is not mentioned in Swagger schema"
stack.yaml+2−2
@@ -3,6 +3,6 @@ packages:
33- '.'
44extra-deps:
55- aeson-1.3.1.0
6−- base-compat-0.10.0
7−- base-compat-batteries-0.10.0
6+- base-compat-0.10.1
7+- base-compat-batteries-0.10.1
88- insert-ordered-containers-0.2.1.0
test/Data/Swagger/Schema/ValidationSpec.hs+27−1
@@ -7,6 +7,7 @@
77module Data.Swagger.Schema.ValidationSpec where
88
99import Control.Applicative
10+import Control.Lens ((&), (.~), (?~))
1011import Data.Aeson
1112import Data.Aeson.Types
1213import Data.Int
@@ -17,7 +18,7 @@ import qualified "unordered-containers" Data.HashSet as HashSet
1718import Data.HashMap.Strict (HashMap)
1819import qualified Data.HashMap.Strict as HashMap
1920import Data.List.NonEmpty.Compat (NonEmpty(..), nonEmpty)
20−import Data.Map (Map)
21+import Data.Map (Map, fromList)
2122import Data.Monoid (mempty)
2223import Data.Proxy
2324import Data.Time
@@ -92,6 +93,7 @@ spec = do
9293 prop "Light" $ shouldValidate (Proxy :: Proxy Light)
9394 prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)
9495 prop "Version" $ shouldValidate (Proxy :: Proxy Version)
96+ prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)
9597
9698 describe "invalid cases" $ do
9799 prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON
@@ -233,5 +235,29 @@ invalidButtonImagesToJSON = genericToJSON defaultOptions
233235instance Arbitrary ButtonImages where
234236 arbitrary = ButtonImages <$> arbitrary
235237
238+-- ========================================================================
239+-- FreeForm (wraps a raw JSON Value)
240+-- ========================================================================
241+
242+data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
243+ deriving (Show, Generic)
244+
245+instance ToJSON FreeForm where
246+ toJSON = toJSON . jsonContent
247+
248+instance ToSchema FreeForm where
249+ declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
250+ & type_ .~ SwaggerObject
251+ & additionalProperties ?~ AdditionalPropertiesAllowed True
252+
253+instance Arbitrary FreeForm where
254+ arbitrary = (FreeForm . fromList) <$> genObj
255+ where
256+ genObj = listOf $ do
257+ k <- arbitrary
258+ v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]
259+ pure (k, v)
260+
236261instance Eq ZonedTime where
237262 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
263+
test/Data/SwaggerSpec.hs+15−1
@@ -37,6 +37,7 @@ spec = do
3737 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
3838 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
3939 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
40+ context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON
4041 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
4142 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
4243 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
@@ -272,7 +273,7 @@ schemaSimpleModelExampleJSON = [aesonQQ|
272273schemaModelDictExample :: Schema
273274schemaModelDictExample = mempty
274275 & type_ .~ SwaggerObject
275− & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)
276+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ .~ SwaggerString))
276277
277278schemaModelDictExampleJSON :: Value
278279schemaModelDictExampleJSON = [aesonQQ|
@@ -284,6 +285,19 @@ schemaModelDictExampleJSON = [aesonQQ|
284285}
285286|]
286287
288+schemaAdditionalExample :: Schema
289+schemaAdditionalExample = mempty
290+ & type_ .~ SwaggerObject
291+ & additionalProperties ?~ AdditionalPropertiesAllowed True
292+
293+schemaAdditionalExampleJSON :: Value
294+schemaAdditionalExampleJSON = [aesonQQ|
295+{
296+ "type": "object",
297+ "additionalProperties": true
298+}
299+|]
300+
287301schemaWithExampleExample :: Schema
288302schemaWithExampleExample = mempty
289303 & type_ .~ SwaggerObject