diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ----- diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -77,6 +77,7 @@ SwaggerItems(..), Xml(..), Pattern, + AdditionalProperties(..), -- ** Responses Responses(..), diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -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 diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -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]) diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -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 $ diff --git a/swagger2.cabal b/swagger2.cabal --- a/swagger2.cabal +++ b/swagger2.cabal @@ -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 diff --git a/test/Data/Swagger/CommonTestTypes.hs b/test/Data/Swagger/CommonTestTypes.hs --- a/test/Data/Swagger/CommonTestTypes.hs +++ b/test/Data/Swagger/CommonTestTypes.hs @@ -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 diff --git a/test/Data/Swagger/Schema/ValidationSpec.hs b/test/Data/Swagger/Schema/ValidationSpec.hs --- a/test/Data/Swagger/Schema/ValidationSpec.hs +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -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) ] diff --git a/test/Data/SwaggerSpec.hs b/test/Data/SwaggerSpec.hs --- a/test/Data/SwaggerSpec.hs +++ b/test/Data/SwaggerSpec.hs @@ -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 } |]