diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,18 @@ +2.1.5 +----- + +* Type error by default when deriving Generic-based instances for mixed sum types (see [#118](https://github.com/GetShopTV/swagger2/pull/118)); +* Adjust `allOf` to accept referenced schemas (see [#119](https://github.com/GetShopTV/swagger2/issues/119)); +* Add instances for `Identity` (see [#116](https://github.com/GetShopTV/swagger2/pull/116)); +* Add Gitter chat badge (see [#114](https://github.com/GetShopTV/swagger2/pull/114)). + 2.1.4.1 ------- -* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95)) -* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105)) +* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95), [#106](https://github.com/GetShopTV/swagger2/pull/106) and [#108](https://github.com/GetShopTV/swagger2/pull/108)); +* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105)); +* Allow `generics-sop-0.3` (see [#102](https://github.com/GetShopTV/swagger2/pull/102)); +* Fix `ToSchema` example in docs (see [#104](https://github.com/GetShopTV/swagger2/pull/104)). 2.1.4 ----- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015-2016, GetShopTV +Copyright (c) 2015-2017, GetShopTV All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # swagger2 +[![Join the chat at https://gitter.im/haskell-swagger2/Lobby](https://badges.gitter.im/haskell-swagger2/Lobby.svg)](https://gitter.im/haskell-swagger2/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) + [![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2) [![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2) [![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2) @@ -11,7 +13,7 @@ ## Usage -This library is inteded to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them. +This library is intended to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them. Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2). diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module: Data.Swagger -- Maintainer: Nickolay Kudasov @@ -286,13 +287,46 @@ -- >>> instance ToSchema SampleSumType -- >>> instance ToJSON SampleSumType -- --- we can not derive a valid schema for a mix of the above. The following will result in a bad schema --- +-- we can not derive a valid schema for a mix of the above. The following will result in a type error +-- +#if __GLASGOW_HASKELL__ < 800 -- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic -- >>> instance ToSchema BadMixedType --- >>> instance ToJSON BadMixedType +-- ... +-- ... error: +-- ... • No instance for (Data.Swagger.Internal.TypeShape.CannotDeriveSchemaForMixedSumType +-- ... BadMixedType) +-- ... arising from a use of ‘Data.Swagger.Internal.Schema.$dmdeclareNamedSchema’ +-- ... • In the expression: +-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType +-- ... In an equation for ‘declareNamedSchema’: +-- ... declareNamedSchema +-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType +-- ... In the instance declaration for ‘ToSchema BadMixedType’ +#else +-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic +-- >>> instance ToSchema BadMixedType +-- ... +-- ... error: +-- ... • Cannot derive Generic-based Swagger Schema for BadMixedType +-- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors). +-- ... Swagger does not have a good representation for these types. +-- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema +-- ... that matches aeson's Generic-based toJSON, +-- ... but that's not supported by some Swagger tools. +-- ... • In the expression: +-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType +-- ... In an equation for ‘declareNamedSchema’: +-- ... declareNamedSchema +-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType +-- ... In the instance declaration for ‘ToSchema BadMixedType’ +#endif -- --- This is due to the fact that @'ToJSON'@ encodes empty constructors with an empty list which can not be described in a swagger schema. +-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON': +-- +-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic +-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions +-- >>> instance ToJSON BadMixedType -- -- $manipulation 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 @@ -554,7 +554,7 @@ , _schemaDescription :: Maybe Text , _schemaRequired :: [ParamName] - , _schemaAllOf :: Maybe [Schema] + , _schemaAllOf :: Maybe [Referenced Schema] , _schemaProperties :: InsOrdHashMap Text (Referenced Schema) , _schemaAdditionalProperties :: Maybe (Referenced Schema) diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -225,6 +225,8 @@ instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a) instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a) +instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a) + instance ToParamSchema a => ToParamSchema [a] where toParamSchema _ = mempty & type_ .~ SwaggerArray 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -64,6 +65,7 @@ import Data.Swagger.Lens hiding (name, schema) import qualified Data.Swagger.Lens as Swagger import Data.Swagger.SchemaOptions +import Data.Swagger.Internal.TypeShape #if __GLASGOW_HASKELL__ < 800 #else @@ -137,7 +139,8 @@ -- Note that the schema itself is included in definitions -- only if it is recursive (and thus needs its definition in scope). declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema - default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema + default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") => + proxy a -> Declare (Definitions Schema) NamedSchema declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions -- | Convert a type into a schema and declare all used schema definitions. @@ -562,6 +565,8 @@ instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) +instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a) + -- | Default schema for @'Bounded'@, @'Integral'@ types. -- -- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16) @@ -581,16 +586,33 @@ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy) -- | A configurable generic @'Schema'@ creator. -genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema -genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy +genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") => + SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema +genericDeclareSchema = genericDeclareSchemaUnrestricted -- | A configurable generic @'NamedSchema'@ creator. -- This function applied to @'defaultSchemaOptions'@ -- is used as the default for @'declareNamedSchema'@ -- when the type is an instance of @'Generic'@. -genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema -genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty +genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") => + SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema +genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted +-- | A configurable generic @'Schema'@ creator. +-- +-- Unlike 'genericDeclareSchema' also works for mixed sum types. +-- Use with care since some Swagger tools do not support well schemas for mixed sum types. +genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema +genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy + +-- | A configurable generic @'NamedSchema'@ creator. +-- +-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types. +-- Use with care since some Swagger tools do not support well schemas for mixed sum types. +genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (Rep a)) => + SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema +genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty + gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text gdatatypeSchemaName opts _ = case name of (c:_) | isAlpha c && isUpper c -> Just (T.pack name) @@ -708,7 +730,10 @@ instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c) -instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where +instance ( GSumToSchema f + , GSumToSchema g + ) => GToSchema (f :+: g) + where gdeclareNamedSchema = gdeclareNamedSumSchema gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema diff --git a/src/Data/Swagger/Internal/TypeShape.hs b/src/Data/Swagger/Internal/TypeShape.hs new file mode 100644 --- /dev/null +++ b/src/Data/Swagger/Internal/TypeShape.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Swagger.Internal.TypeShape where + +import Data.Proxy +import GHC.Generics +import GHC.TypeLits +import GHC.Exts (Constraint) + +-- | Shape of a datatype. +data TypeShape + = Enumeration -- ^ A simple enumeration. + | SumOfProducts -- ^ A product or a sum of non-unit products. + | Mixed -- ^ Mixed sum type with both unit and non-unit constructors. + +-- | A combined shape for a product type. +type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where + ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products + ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products + ProdCombine a b = SumOfProducts + +-- | A combined shape for a sum type. +type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where + SumCombine Enumeration Enumeration = Enumeration + SumCombine SumOfProducts SumOfProducts = SumOfProducts + SumCombine a b = Mixed + +type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where + TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t)) + +type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where + GenericHasSimpleShape t f Enumeration = () + GenericHasSimpleShape t f SumOfProducts = () +#if __GLASGOW_HASKELL__ < 800 + GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t + +class CannotDeriveSchemaForMixedSumType t where +#else + GenericHasSimpleShape t f Mixed = + TypeError + ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t + :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)." + :$$: Text "Swagger does not have a good representation for these types." + :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema" + :$$: Text "that matches aeson's Generic-based toJSON," + :$$: Text "but that's not supported by some Swagger tools." + ) +#endif + +-- | Infer a 'TypeShape' for a generic representation of a type. +type family GenericShape (g :: * -> *) :: TypeShape + +type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g) +type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g) +type instance GenericShape (D1 d f) = GenericShape f +type instance GenericShape (C1 c U1) = Enumeration +type instance GenericShape (C1 c (S1 s f)) = SumOfProducts +type instance GenericShape (C1 c (f :*: g)) = SumOfProducts + + diff --git a/src/Data/Swagger/Schema.hs b/src/Data/Swagger/Schema.hs --- a/src/Data/Swagger/Schema.hs +++ b/src/Data/Swagger/Schema.hs @@ -22,6 +22,10 @@ paramSchemaToNamedSchema, paramSchemaToSchema, + -- ** Unrestricted versions + genericDeclareNamedSchemaUnrestricted, + genericDeclareSchemaUnrestricted, + -- * Schema templates passwordSchema, binarySchema, diff --git a/swagger2.cabal b/swagger2.cabal --- a/swagger2.cabal +++ b/swagger2.cabal @@ -1,5 +1,5 @@ name: swagger2 -version: 2.1.4.1 +version: 2.1.5 synopsis: Swagger 2.0 data model description: This library is inteded to be used for decoding and encoding Swagger 2.0 API @@ -13,7 +13,7 @@ author: Nickolay Kudasov maintainer: nickolay@getshoptv.com copyright: (c) 2015-2016, GetShopTV -category: Web +category: Web, Swagger build-type: Custom extra-source-files: README.md @@ -47,6 +47,7 @@ Data.Swagger.Internal.ParamSchema Data.Swagger.Internal.Utils Data.Swagger.Internal.AesonUtils + Data.Swagger.Internal.TypeShape build-depends: base >=4.7 && <4.11 , base-compat >=0.9.1 && <0.10 , aeson >=0.11.2.1 @@ -100,6 +101,9 @@ Data.Swagger.SchemaSpec Data.Swagger.Schema.ValidationSpec default-language: Haskell2010 + -- https://github.com/haskell/cabal/issues/3708 + build-tool-depends: + hspec-discover:hspec-discover test-suite doctests -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes 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 @@ -148,7 +148,8 @@ data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic) -instance ToSchema Light +instance ToSchema Light where + declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions instance ToJSON Light where toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField } diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs --- a/test/Data/Swagger/SchemaSpec.hs +++ b/test/Data/Swagger/SchemaSpec.hs @@ -599,7 +599,7 @@ deriving (Generic) instance ToSchema Light where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions { unwrapUnaryRecords = True } lightSchemaJSON :: Value diff --git a/test/Data/SwaggerSpec.hs b/test/Data/SwaggerSpec.hs --- a/test/Data/SwaggerSpec.hs +++ b/test/Data/SwaggerSpec.hs @@ -42,6 +42,7 @@ describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON + describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON describe "Swagger Object" $ do context "Todo Example" $ swaggerExample <=> swaggerExampleJSON context "PetStore Example" $ @@ -1612,5 +1613,35 @@ "description":"Find out more about Swagger", "url":"http://swagger.io" } +} +|] + +compositionSchemaExample :: Schema +compositionSchemaExample = mempty + & type_ .~ SwaggerObject + & Data.Swagger.allOf ?~ [ + Ref (Reference "Other") + , Inline (mempty + & type_ .~ SwaggerObject + & properties .~ + [ ("greet", Inline $ mempty + & type_ .~ SwaggerString) ]) + ] + +compositionSchemaExampleJSON :: Value +compositionSchemaExampleJSON = [aesonQQ| +{ + "type": "object", + "allOf": [ + { + "$ref": "#/definitions/Other" + }, + { + "type": "object", + "properties": { + "greet": { "type": "string" } + } + } + ] } |]