swagger2 2.2.2 → 2.3
raw patch · 9 files changed
+153/−59 lines, 9 files
Files
- CHANGELOG.md +15/−0
- src/Data/Swagger.hs +1/−0
- src/Data/Swagger/Internal.hs +14/−1
- src/Data/Swagger/Internal/Schema.hs +8/−2
- src/Data/Swagger/Internal/Schema/Validation.hs +5/−1
- swagger2.cabal +5/−5
- test/Data/Swagger/CommonTestTypes.hs +16/−16
- test/Data/Swagger/Schema/ValidationSpec.hs +74/−33
- test/Data/SwaggerSpec.hs +15/−1
CHANGELOG.md view
@@ -1,3 +1,18 @@+2.3+---++Major changes:++- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));+- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));++Dependencies and CI:++- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));+- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));+- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));+- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));+ 2.2.2 -----
src/Data/Swagger.hs view
@@ -77,6 +77,7 @@ SwaggerItems(..), Xml(..), Pattern,+ AdditionalProperties(..), -- ** Responses Responses(..),
src/Data/Swagger/Internal.hs view
@@ -557,7 +557,7 @@ , _schemaAllOf :: Maybe [Referenced Schema] , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)- , _schemaAdditionalProperties :: Maybe (Referenced Schema)+ , _schemaAdditionalProperties :: Maybe AdditionalProperties , _schemaDiscriminator :: Maybe Text , _schemaReadOnly :: Maybe Bool@@ -802,6 +802,11 @@ newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable) +data AdditionalProperties+ = AdditionalPropertiesAllowed Bool+ | AdditionalPropertiesSchema (Referenced Schema)+ deriving (Eq, Show, Data, Typeable)+ -- ======================================================================= -- Monoid instances -- =======================================================================@@ -1125,6 +1130,10 @@ toJSON = sopSwaggerGenericToJSONWithOpts $ mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" +instance ToJSON AdditionalProperties where+ toJSON (AdditionalPropertiesAllowed b) = toJSON b+ toJSON (AdditionalPropertiesSchema s) = toJSON s+ -- ======================================================================= -- Manual FromJSON instances -- =======================================================================@@ -1279,6 +1288,10 @@ parseJSON = sopSwaggerGenericParseJSON instance FromJSON (ParamSchema 'SwaggerKindSchema) where parseJSON = sopSwaggerGenericParseJSON++instance FromJSON AdditionalProperties where+ parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b+ parseJSON js = AdditionalPropertiesSchema <$> parseJSON js ------------------------------------------------------------------------------- -- TH splices
src/Data/Swagger/Internal/Schema.hs view
@@ -32,7 +32,7 @@ import Control.Monad import Control.Monad.Writer-import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..))+import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..)) import Data.Char import Data.Data (Data) import Data.Foldable (traverse_)@@ -529,7 +529,7 @@ schema <- declareSchemaRef (Proxy :: Proxy v) return $ unnamed $ mempty & type_ .~ SwaggerObject- & additionalProperties ?~ schema+ & additionalProperties ?~ AdditionalPropertiesSchema schema instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))@@ -551,6 +551,12 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a)) #endif++instance OVERLAPPING_ ToSchema Object where+ declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty+ & type_ .~ SwaggerObject+ & description ?~ "Arbitrary JSON object."+ & additionalProperties ?~ AdditionalPropertiesAllowed True instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a]) instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
src/Data/Swagger/Internal/Schema/Validation.hs view
@@ -312,8 +312,12 @@ Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property _ -> case InsOrdHashMap.lookup k (sch ^. properties) of- Nothing -> checkMissing (unknownProperty k) additionalProperties $ \s -> validateWithSchemaRef s v+ Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v Just s -> validateWithSchemaRef s v++ validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid+ validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"+ validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v unknownProperty :: Text -> Validation s a unknownProperty name = invalid $
swagger2.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: swagger2-version: 2.2.2+version: 2.3 synopsis: Swagger 2.0 data model description:@@ -23,7 +23,7 @@ , CHANGELOG.md , examples/*.hs , include/overlapping-compat.h-tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.1+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 custom-setup setup-depends:@@ -67,13 +67,13 @@ -- other dependencies build-depends: base-compat-batteries >=0.10.1 && <0.11- , aeson >=1.0.0.0 && <1.4+ , aeson >=1.0.0.0 && <1.5 , generics-sop >=0.3.2.0 && <0.4 , hashable >=1.2.7.0 && <1.3 , http-media >=0.7.1.2 && <0.8 , insert-ordered-containers >=0.1.0.0 && <0.3- , lens >=4.16.1 && <4.17- , network >=2.6.3.5 && <2.7+ , lens >=4.16.1 && <4.18+ , network >=2.6.3.5 && <2.8 , scientific >=0.3.5.3 && <0.4 , transformers-compat >=0.3 && <0.7 , unordered-containers >=0.2.9.0 && <0.3
test/Data/Swagger/CommonTestTypes.hs view
@@ -1,25 +1,25 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE QuasiQuotes #-} module Data.Swagger.CommonTestTypes where -import Prelude ()-import Prelude.Compat+import Prelude ()+import Prelude.Compat -import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))-import Data.Aeson.Types (toJSONKeyText)-import Data.Aeson.QQ-import Data.Char-import Data.Proxy-import Data.Set (Set)-import Data.Map (Map)-import qualified Data.Text as Text-import GHC.Generics+import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)+import Data.Aeson.QQ+import Data.Aeson.Types (toJSONKeyText)+import Data.Char+import Data.Map (Map)+import Data.Proxy+import Data.Set (Set)+import qualified Data.Text as Text+import GHC.Generics -import Data.Swagger-import Data.Swagger.Declare-import Data.Swagger.Internal (SwaggerKind(..))+import Data.Swagger+import Data.Swagger.Declare+import Data.Swagger.Internal (SwaggerKind (..)) -- ======================================================================== -- Unit type
test/Data/Swagger/Schema/ValidationSpec.hs view
@@ -1,40 +1,41 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Swagger.Schema.ValidationSpec where -import Control.Applicative-import Data.Aeson-import Data.Aeson.Types-import Data.Int-import Data.IntMap (IntMap)-import Data.Hashable (Hashable)-import "unordered-containers" Data.HashSet (HashSet)+import Control.Applicative+import Control.Lens ((&), (.~), (?~))+import Data.Aeson+import Data.Aeson.Types+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import "unordered-containers" Data.HashSet (HashSet) import qualified "unordered-containers" Data.HashSet as HashSet-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.List.NonEmpty.Compat (NonEmpty(..), nonEmpty)-import Data.Map (Map)-import Data.Monoid (mempty)-import Data.Proxy-import Data.Time-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Version (Version)-import Data.Set (Set)-import Data.Word-import GHC.Generics+import Data.Int+import Data.IntMap (IntMap)+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)+import Data.Map (Map, fromList)+import Data.Monoid (mempty)+import Data.Proxy+import Data.Set (Set)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Time+import Data.Version (Version)+import Data.Word+import GHC.Generics -import Data.Swagger-import Data.Swagger.Declare+import Data.Swagger+import Data.Swagger.Declare -import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck-import Test.QuickCheck.Instances ()+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Instances () shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool shouldValidate _ x = validateToJSON x == []@@ -82,6 +83,7 @@ prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int)) prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int)) prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))+ prop "Object" $ shouldValidate (Proxy :: Proxy Object) prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double)) prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int])) prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))@@ -92,6 +94,7 @@ prop "Light" $ shouldValidate (Proxy :: Proxy Light) prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages) prop "Version" $ shouldValidate (Proxy :: Proxy Version)+ prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm) describe "invalid cases" $ do prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON@@ -137,9 +140,9 @@ arbitrary = arbitraryBoundedEnum invalidColorToJSON :: Color -> Value-invalidColorToJSON Red = toJSON "red"-invalidColorToJSON Green = toJSON "green"-invalidColorToJSON Blue = toJSON "blue"+invalidColorToJSON Red = toJSON "red"+invalidColorToJSON Green = toJSON "green"+invalidColorToJSON Blue = toJSON "blue" -- ======================================================================== -- Paint (record with bounded enum property)@@ -233,5 +236,43 @@ instance Arbitrary ButtonImages where arbitrary = ButtonImages <$> arbitrary +-- ========================================================================+-- FreeForm (wraps a raw JSON Value)+-- ========================================================================++data FreeForm = FreeForm { jsonContent :: Map T.Text Value }+ deriving (Show, Generic)++instance ToJSON FreeForm where+ toJSON = toJSON . jsonContent++instance ToSchema FreeForm where+ declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty+ & type_ .~ SwaggerObject+ & additionalProperties ?~ AdditionalPropertiesAllowed True++instance Arbitrary FreeForm where+ arbitrary = (FreeForm . fromList) <$> genObj+ where+ genObj = listOf $ do+ k <- arbitrary+ v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]+ pure (k, v)+ instance Eq ZonedTime where ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y++-- ========================================================================+-- Arbitrary instance for Data.Aeson.Value+-- ========================================================================++instance Arbitrary Value where+ -- Weights are almost random+ -- Uniform oneof tends not to build complex objects cause of recursive call.+ arbitrary = resize 4 $ frequency+ [ (3, Object <$> arbitrary)+ , (3, Array <$> arbitrary)+ , (3, String <$> arbitrary)+ , (3, Number <$> arbitrary)+ , (3, Bool <$> arbitrary)+ , (1, return Null) ]
test/Data/SwaggerSpec.hs view
@@ -37,6 +37,7 @@ context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON+ context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON@@ -272,7 +273,7 @@ schemaModelDictExample :: Schema schemaModelDictExample = mempty & type_ .~ SwaggerObject- & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ .~ SwaggerString)) schemaModelDictExampleJSON :: Value schemaModelDictExampleJSON = [aesonQQ|@@ -281,6 +282,19 @@ "additionalProperties": { "type": "string" }+}+|]++schemaAdditionalExample :: Schema+schemaAdditionalExample = mempty+ & type_ .~ SwaggerObject+ & additionalProperties ?~ AdditionalPropertiesAllowed True++schemaAdditionalExampleJSON :: Value+schemaAdditionalExampleJSON = [aesonQQ|+{+ "type": "object",+ "additionalProperties": true } |]