git.iko.soy/typeable/swagger2
on master help sign in
Support for additionalProperties with Bool value

According to the spec ([here](https://tools.ietf.org/html/draft-wright-json-schema-validation-00#section-5.18)), `additionalProperties` can be `true` (meaning additional properties with any values) or `false` (meaning the same thing as the attribute not being present, I believe) or a schema. This commit adds a new type, `AdditionalProperties`, with custom JSON encoding to deal with that, and what appears to be reasonable validation for it.

commite725fd292887ba661c06e32789981d0aac1610ba authorMoss Prescott <moss@tvisioninsights.com> dateTue 26 Jun 2018, 16:51 (8 years ago) parent3e05560
5 files changed+36−4
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 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"
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