2aafbae · 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"

stack.yaml+2−2

@@ -3,6 +3,6 @@ packages:

3- '.'

4extra-deps:

5- aeson-1.3.1.0

6−- base-compat-0.10.0

6+- base-compat-0.10.1

7−- base-compat-batteries-0.10.0

7+- base-compat-batteries-0.10.1

8- insert-ordered-containers-0.2.1.0

test/Data/Swagger/Schema/ValidationSpec.hs+27−1

@@ -7,6 +7,7 @@

7module Data.Swagger.Schema.ValidationSpec where

8

9import Control.Applicative

10+import Control.Lens ((&), (.~), (?~))

10import Data.Aeson

11import Data.Aeson

11import Data.Aeson.Types

12import Data.Aeson.Types

12import Data.Int

13import Data.Int

@@ -17,7 +18,7 @@ import qualified "unordered-containers" Data.HashSet as HashSet

17import Data.HashMap.Strict (HashMap)

18import Data.HashMap.Strict (HashMap)

18import qualified Data.HashMap.Strict as HashMap

19import qualified Data.HashMap.Strict as HashMap

19import Data.List.NonEmpty.Compat (NonEmpty(..), nonEmpty)

20import Data.List.NonEmpty.Compat (NonEmpty(..), nonEmpty)

20−import Data.Map (Map)

21+import Data.Map (Map, fromList)

21import Data.Monoid (mempty)

22import Data.Monoid (mempty)

22import Data.Proxy

23import Data.Proxy

23import Data.Time

24import Data.Time

@@ -92,6 +93,7 @@ spec = do

92 prop "Light" $ shouldValidate (Proxy :: Proxy Light)

93 prop "Light" $ shouldValidate (Proxy :: Proxy Light)

93 prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)

94 prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)

94 prop "Version" $ shouldValidate (Proxy :: Proxy Version)

95 prop "Version" $ shouldValidate (Proxy :: Proxy Version)

96+ prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)

95

97

96 describe "invalid cases" $ do

98 describe "invalid cases" $ do

97 prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON

99 prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON

@@ -233,5 +235,29 @@ invalidButtonImagesToJSON = genericToJSON defaultOptions

233instance Arbitrary ButtonImages where

235instance Arbitrary ButtonImages where

234 arbitrary = ButtonImages <$> arbitrary

236 arbitrary = ButtonImages <$> arbitrary

235

237

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+

236instance Eq ZonedTime where

261instance Eq ZonedTime where

237 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y

262 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

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