e725fd2 · typeable/swagger2

src/Data/Swagger.hs+1

compare with master

unifiedsplit

@@ -77,6 +77,7 @@ module Data.Swagger (

77 SwaggerItems(..),

78 Xml(..),

79 Pattern,

80+ AdditionalProperties(..),

80

81

81 -- ** Responses

82 -- ** Responses

82 Responses(..),

83 Responses(..),

src/Data/Swagger/Internal.hs+14−1

@@ -557,7 +557,7 @@ data Schema = Schema

557

558 , _schemaAllOf :: Maybe [Referenced Schema]

559 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)

560− , _schemaAdditionalProperties :: Maybe (Referenced Schema)

560+ , _schemaAdditionalProperties :: Maybe AdditionalProperties

561

562 , _schemaDiscriminator :: Maybe Text

563 , _schemaReadOnly :: Maybe Bool

@@ -802,6 +802,11 @@ instance IsString a => IsString (Referenced a) where

802

803newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)

804

805+data AdditionalProperties

806+ = AdditionalPropertiesAllowed Bool

807+ | AdditionalPropertiesSchema (Referenced Schema)

808+ deriving (Eq, Show, Data, Typeable)

809+

805-- =======================================================================

810-- =======================================================================

806-- Monoid instances

811-- Monoid instances

807-- =======================================================================

812-- =======================================================================

@@ -1125,6 +1130,10 @@ instance ToJSON (ParamSchema k) where

1125 toJSON = sopSwaggerGenericToJSONWithOpts $

1130 toJSON = sopSwaggerGenericToJSONWithOpts $

1126 mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"

1131 mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"

1127

1132

1133+instance ToJSON AdditionalProperties where

1134+ toJSON (AdditionalPropertiesAllowed b) = toJSON b

1135+ toJSON (AdditionalPropertiesSchema s) = toJSON s

1136+

1128-- =======================================================================

1137-- =======================================================================

1129-- Manual FromJSON instances

1138-- Manual FromJSON instances

1130-- =======================================================================

1139-- =======================================================================

@@ -1280,6 +1289,10 @@ instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where

1280instance FromJSON (ParamSchema 'SwaggerKindSchema) where

1289instance FromJSON (ParamSchema 'SwaggerKindSchema) where

1281 parseJSON = sopSwaggerGenericParseJSON

1290 parseJSON = sopSwaggerGenericParseJSON

1282

1291

1292+instance FromJSON AdditionalProperties where

1293+ parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b

1294+ parseJSON js = AdditionalPropertiesSchema <$> parseJSON js

1295+

1283-------------------------------------------------------------------------------

1296-------------------------------------------------------------------------------

1284-- TH splices

1297-- TH splices

1285-------------------------------------------------------------------------------

1298-------------------------------------------------------------------------------

src/Data/Swagger/Internal/Schema.hs+1−1

@@ -529,7 +529,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where

529 schema <- declareSchemaRef (Proxy :: Proxy v)

530 return $ unnamed $ mempty

531 & type_ .~ SwaggerObject

532− & additionalProperties ?~ schema

532+ & additionalProperties ?~ AdditionalPropertiesSchema schema

533

534instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where

535 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))

src/Data/Swagger/Internal/Schema/Validation.hs+5−1

@@ -312,9 +312,13 @@ validateObject o = withSchema $ \sch ->

312 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property

313 _ ->

314 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

316 Just s -> validateWithSchemaRef s v

317

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+

318 unknownProperty :: Text -> Validation s a

322 unknownProperty :: Text -> Validation s a

319 unknownProperty name = invalid $

323 unknownProperty name = invalid $

320 "property " <> show name <> " is found in JSON value, but it is not mentioned in Swagger schema"

324 "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

37 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON

38 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON

39 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON

40+ context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON

40 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON

41 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON

41 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON

42 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON

42 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

43 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

@@ -272,7 +273,7 @@ schemaSimpleModelExampleJSON = [aesonQQ|

272schemaModelDictExample :: Schema

273schemaModelDictExample :: Schema

273schemaModelDictExample = mempty

274schemaModelDictExample = mempty

274 & type_ .~ SwaggerObject

275 & type_ .~ SwaggerObject

275− & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)

276+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ .~ SwaggerString))

276

277

277schemaModelDictExampleJSON :: Value

278schemaModelDictExampleJSON :: Value

278schemaModelDictExampleJSON = [aesonQQ|

279schemaModelDictExampleJSON = [aesonQQ|

@@ -284,6 +285,19 @@ schemaModelDictExampleJSON = [aesonQQ|

284}

285}

285|]

286|]

286

287

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+

287schemaWithExampleExample :: Schema

301schemaWithExampleExample :: Schema

288schemaWithExampleExample = mempty

302schemaWithExampleExample = mempty

289 & type_ .~ SwaggerObject

303 & type_ .~ SwaggerObject