From 0291b5d2bf118361ebf46eee759ec05b0c4675a2 Mon Sep 17 00:00:00 2001 From: "Alejandro D. P" Date: Tue, 5 Sep 2017 23:57:17 +0200 Subject: [PATCH 1/7] Type machinary to find ilegal shapes --- src/Data/Swagger/Internal/TypeShape.hs | 60 ++++++++++++++++++++++++++ swagger2.cabal | 1 + 2 files changed, 61 insertions(+) create mode 100644 src/Data/Swagger/Internal/TypeShape.hs diff --git a/src/Data/Swagger/Internal/TypeShape.hs b/src/Data/Swagger/Internal/TypeShape.hs new file mode 100644 index 0000000..1c35dcc --- /dev/null +++ b/src/Data/Swagger/Internal/TypeShape.hs @@ -0,0 +1,60 @@ + +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + + +module Data.Swagger.Internal.TypeShape where + + +import Data.Proxy +import GHC.Generics +import GHC.TypeLits + +data TypeShape = EnumShape + | NestedShape + | IlegalShape + + +type family ProdCombine (a :: TypeShape ) (b :: TypeShape) :: TypeShape where + + ProdCombine IlegalShape b = IlegalShape + ProdCombine a IlegalShape = IlegalShape + ProdCombine a b = NestedShape + + +type family SumCombine (a :: TypeShape ) (b :: TypeShape) :: TypeShape where + + SumCombine EnumShape EnumShape = EnumShape + SumCombine NestedShape NestedShape = NestedShape + SumCombine a b = IlegalShape + + + + +class LegalShape (a :: TypeShape) where + +instance LegalShape EnumShape +instance LegalShape NestedShape + +instance TypeError + ( Text "Cannot auto derive swagger class, for that to be possible, make sure that any constructor " + :$$: Text "for this type, only holds 0 arguments if there are no other contructors with more than 0 arguments," + :$$: Text "otherwise, every constructor have to hold at least 1 argument" + ) => LegalShape IlegalShape + + + +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) = EnumShape +type instance GenericShape (C1 c (S1 s f)) = NestedShape +type instance GenericShape (C1 c (f :*: g)) = NestedShape + + diff --git a/swagger2.cabal b/swagger2.cabal index e03639e..f8982cf 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -47,6 +47,7 @@ library 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 From 28bf3492ca57191ff3e744232156d3070e7fec77 Mon Sep 17 00:00:00 2001 From: "Alejandro D. P" Date: Wed, 6 Sep 2017 00:33:06 +0200 Subject: [PATCH 2/7] Force legal types on derived ToSchema instances --- src/Data/Swagger/Internal/Schema.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index d25b07a..bd19d22 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -64,6 +64,7 @@ import Data.Swagger.Internal.ParamSchema (ToParamSchema(..)) 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 @@ -708,7 +709,12 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where 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 + , LegalShape (GenericShape (f :+: g)) + + ) => GToSchema (f :+: g) + where gdeclareNamedSchema = gdeclareNamedSumSchema gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema From a4bab47d60dccffe1e114f70b25d021a7689113f Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 7 Sep 2017 03:37:10 +0300 Subject: [PATCH 3/7] Improve type shape restrictions - Explain mixed sum types problem better - Provide unrestricted genericDeclareSchema and genericDeclareNamedSchema versions --- src/Data/Swagger/Internal/Schema.hs | 32 ++++++--- src/Data/Swagger/Internal/TypeShape.hs | 95 +++++++++++++------------- src/Data/Swagger/Schema.hs | 4 ++ 3 files changed, 75 insertions(+), 56 deletions(-) diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index bd19d22..7fa9bb2 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -138,7 +138,8 @@ class ToSchema a where -- 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. @@ -582,15 +583,32 @@ genericToNamedSchemaBoundedIntegral opts proxy = 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 @@ -711,9 +729,7 @@ instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where instance ( GSumToSchema f , GSumToSchema g - , LegalShape (GenericShape (f :+: g)) - - ) => GToSchema (f :+: g) + ) => GToSchema (f :+: g) where gdeclareNamedSchema = gdeclareNamedSumSchema diff --git a/src/Data/Swagger/Internal/TypeShape.hs b/src/Data/Swagger/Internal/TypeShape.hs index 1c35dcc..a81dd6a 100644 --- a/src/Data/Swagger/Internal/TypeShape.hs +++ b/src/Data/Swagger/Internal/TypeShape.hs @@ -1,60 +1,59 @@ - -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# 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 - -data TypeShape = EnumShape - | NestedShape - | IlegalShape - - -type family ProdCombine (a :: TypeShape ) (b :: TypeShape) :: TypeShape where - - ProdCombine IlegalShape b = IlegalShape - ProdCombine a IlegalShape = IlegalShape - ProdCombine a b = NestedShape - - -type family SumCombine (a :: TypeShape ) (b :: TypeShape) :: TypeShape where - - SumCombine EnumShape EnumShape = EnumShape - SumCombine NestedShape NestedShape = NestedShape - SumCombine a b = IlegalShape - - - - -class LegalShape (a :: TypeShape) where - -instance LegalShape EnumShape -instance LegalShape NestedShape - -instance TypeError - ( Text "Cannot auto derive swagger class, for that to be possible, make sure that any constructor " - :$$: Text "for this type, only holds 0 arguments if there are no other contructors with more than 0 arguments," - :$$: Text "otherwise, every constructor have to hold at least 1 argument" - ) => LegalShape IlegalShape - - - -type family GenericShape ( g :: * -> * ) :: TypeShape - +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 = () + 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." + ) + +-- | 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) = EnumShape -type instance GenericShape (C1 c (S1 s f)) = NestedShape -type instance GenericShape (C1 c (f :*: g)) = NestedShape +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 index 6f9f616..c8a09c8 100644 --- a/src/Data/Swagger/Schema.hs +++ b/src/Data/Swagger/Schema.hs @@ -22,6 +22,10 @@ module Data.Swagger.Schema ( paramSchemaToNamedSchema, paramSchemaToSchema, + -- ** Unrestricted versions + genericDeclareNamedSchemaUnrestricted, + genericDeclareSchemaUnrestricted, + -- * Schema templates passwordSchema, binarySchema, From 1200b30c1c3d20ad7244f98682d66ec83137afc4 Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 7 Sep 2017 03:58:41 +0300 Subject: [PATCH 4/7] Improve documentation section on mixed sum types --- src/Data/Swagger.hs | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 9b10815..7b4ec6d 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -286,13 +286,30 @@ import Data.Swagger.Internal -- >>> 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 +-- -- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic -- >>> instance ToSchema BadMixedType --- >>> instance ToJSON 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’ +-- +-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON': -- --- This is due to the fact that @'ToJSON'@ encodes empty constructors with an empty list which can not be described in a swagger schema. +-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic +-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions +-- >>> instance ToJSON BadMixedType -- -- $manipulation From da1fc8b0049782814ff668bc982aaa89f3795b28 Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 7 Sep 2017 03:58:50 +0300 Subject: [PATCH 5/7] Fix tests --- test/Data/Swagger/Schema/ValidationSpec.hs | 3 ++- test/Data/Swagger/SchemaSpec.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/test/Data/Swagger/Schema/ValidationSpec.hs b/test/Data/Swagger/Schema/ValidationSpec.hs index 9b05c7d..d32fd0a 100644 --- a/test/Data/Swagger/Schema/ValidationSpec.hs +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -148,7 +148,8 @@ instance Arbitrary MyRoseTree where 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 index e31f7db..af4641a 100644 --- a/test/Data/Swagger/SchemaSpec.hs +++ b/test/Data/Swagger/SchemaSpec.hs @@ -599,7 +599,7 @@ data Light deriving (Generic) instance ToSchema Light where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions { unwrapUnaryRecords = True } lightSchemaJSON :: Value From 50038e769e3c214cca3e0099dcaece46c44fba51 Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 7 Sep 2017 05:07:53 +0300 Subject: [PATCH 6/7] Fix builds for older GHC versions --- src/Data/Swagger.hs | 17 +++++++++++++++++ src/Data/Swagger/Internal/TypeShape.hs | 7 +++++++ 2 files changed, 24 insertions(+) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 7b4ec6d..080d4e9 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module: Data.Swagger -- Maintainer: Nickolay Kudasov @@ -288,6 +289,21 @@ import Data.Swagger.Internal -- -- 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 +-- ... +-- ... 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 -- ... @@ -304,6 +320,7 @@ import Data.Swagger.Internal -- ... declareNamedSchema -- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType -- ... In the instance declaration for ‘ToSchema BadMixedType’ +#endif -- -- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON': -- diff --git a/src/Data/Swagger/Internal/TypeShape.hs b/src/Data/Swagger/Internal/TypeShape.hs index a81dd6a..64e8283 100644 --- a/src/Data/Swagger/Internal/TypeShape.hs +++ b/src/Data/Swagger/Internal/TypeShape.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} @@ -36,6 +37,11 @@ type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where 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 @@ -45,6 +51,7 @@ type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint :$$: 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 From b6baa3110538cf888734377fc22f216f14c73f39 Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 7 Sep 2017 17:12:59 +0300 Subject: [PATCH 7/7] Fix build for GHC 7.8 --- src/Data/Swagger/Internal/Schema.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index 7fa9bb2..e752d38 100644 --- 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 #-}