From 6d4d10825cd9afaf0de22814cddc9559613b0eff Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Sun, 13 Dec 2015 23:14:41 +0300 Subject: [PATCH] Introduce SwaggerItems GADT to simplify ParamSchema --- src/Data/Swagger.hs | 2 +- src/Data/Swagger/Internal.hs | 80 ++++++++++++++++-------- src/Data/Swagger/Internal/ParamSchema.hs | 16 ++--- src/Data/Swagger/Internal/Schema.hs | 12 ++-- src/Data/Swagger/Lens.hs | 51 +++++++-------- test/Data/Swagger/ParamSchemaSpec.hs | 2 +- 6 files changed, 95 insertions(+), 68 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index a7de8f6..f508547 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -45,7 +45,7 @@ module Data.Swagger ( -- * Schemas ParamSchema(..), Schema(..), - SchemaItems(..), + SwaggerItems(..), Xml(..), -- * Responses diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 087e491..53d5690 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -10,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} module Data.Swagger.Internal where import Control.Applicative @@ -324,9 +325,33 @@ data ParamOtherSchema = ParamOtherSchema -- Default value is csv. , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param) - , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema Items + , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema } deriving (Eq, Show, Generic, Data, Typeable) +data SwaggerItems t where + SwaggerItemsPrimitive :: Items -> SwaggerItems t + SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema + SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema + +deriving instance Eq (SwaggerItems t) +deriving instance Show (SwaggerItems t) +deriving instance Typeable (SwaggerItems t) + +swaggerItemsPrimitiveConstr :: Constr +swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix + +swaggerItemsDataType :: DataType +swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr] + +instance {-# OVERLAPPABLE #-} Typeable t => Data (SwaggerItems t) where + gunfold k z c = case constrIndex c of + 1 -> k (z SwaggerItemsPrimitive) + _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)." + toConstr _ = swaggerItemsPrimitiveConstr + dataTypeOf _ = swaggerItemsDataType + +deriving instance Data (SwaggerItems Schema) + data SwaggerType t where SwaggerString :: SwaggerType t SwaggerNumber :: SwaggerType t @@ -453,15 +478,10 @@ data Schema = Schema , _schemaMaxProperties :: Maybe Integer , _schemaMinProperties :: Maybe Integer - , _schemaParamSchema :: ParamSchema Schema SchemaItems + , _schemaParamSchema :: ParamSchema Schema } deriving (Eq, Show, Generic, Data, Typeable) -data SchemaItems - = SchemaItemsObject (Referenced Schema) - | SchemaItemsArray [Referenced Schema] - deriving (Eq, Show, Generic, Data, Typeable) - -data ParamSchema t items = ParamSchema +data ParamSchema t = ParamSchema { -- | Declares the value of the parameter that the server will use if none is provided, -- for example a @"count"@ to control the number of results per page might default to @100@ -- if not supplied by the client in the request. @@ -471,7 +491,7 @@ data ParamSchema t items = ParamSchema , _paramSchemaType :: SwaggerType t , _paramSchemaFormat :: Maybe Format - , _paramSchemaItems :: Maybe items + , _paramSchemaItems :: Maybe (SwaggerItems t) , _paramSchemaMaximum :: Maybe Scientific , _paramSchemaExclusiveMaximum :: Maybe Bool , _paramSchemaMinimum :: Maybe Scientific @@ -486,7 +506,7 @@ data ParamSchema t items = ParamSchema , _paramSchemaMultipleOf :: Maybe Scientific } deriving (Eq, Show, Generic, Typeable) -deriving instance (Data t, Data (SwaggerType t), Data i) => Data (ParamSchema t i) +deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t) data Xml = Xml { -- | Replaces the name of the element/attribute used for the described schema property. @@ -521,7 +541,7 @@ data Items = Items -- Default value is @'ItemsCollectionCSV'@. _itemsCollectionFormat :: Maybe (CollectionFormat Items) - , _itemsParamSchema :: ParamSchema Items Items + , _itemsParamSchema :: ParamSchema Items } deriving (Eq, Show, Generic, Data, Typeable) -- | A container for the expected responses of an operation. @@ -571,7 +591,7 @@ data Header = Header -- Default value is @'ItemsCollectionCSV'@. , _headerCollectionFormat :: Maybe (CollectionFormat Items) - , _headerParamSchema :: ParamSchema Header Items + , _headerParamSchema :: ParamSchema Header } deriving (Eq, Show, Generic, Data, Typeable) data Example = Example { getExample :: Map MediaType Value } @@ -706,7 +726,7 @@ instance Monoid Schema where mempty = genericMempty mappend = genericMappend -instance Monoid (ParamSchema t i) where +instance Monoid (ParamSchema t) where mempty = genericMempty mappend = genericMappend @@ -742,7 +762,7 @@ instance SwaggerMonoid Info instance SwaggerMonoid Paths instance SwaggerMonoid PathItem instance SwaggerMonoid Schema -instance SwaggerMonoid (ParamSchema t i) +instance SwaggerMonoid (ParamSchema t) instance SwaggerMonoid Param instance SwaggerMonoid ParamOtherSchema instance SwaggerMonoid Responses @@ -870,6 +890,11 @@ instance ToJSON Header where instance ToJSON Items where toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "items") +instance ToJSON (SwaggerItems t) where + toJSON (SwaggerItemsPrimitive x) = toJSON x + toJSON (SwaggerItemsObject x) = toJSON x + toJSON (SwaggerItemsArray x) = toJSON x + instance ToJSON Host where toJSON (Host host mport) = toJSON $ case mport of @@ -892,10 +917,6 @@ instance ToJSON ParamAnySchema where instance ToJSON ParamOtherSchema where toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema") -instance ToJSON SchemaItems where - toJSON (SchemaItemsObject x) = toJSON x - toJSON (SchemaItemsArray xs) = toJSON xs - instance ToJSON Responses where toJSON (Responses def rs) = omitEmpties $ toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ] @@ -940,7 +961,7 @@ instance ToJSON (CollectionFormat t) where toJSON CollectionPipes = "pipes" toJSON CollectionMulti = "multi" -instance ToJSON i => ToJSON (ParamSchema t i) where +instance ToJSON (ParamSchema t) where toJSON = genericToJSON (jsonPrefix "paramSchema") -- ======================================================================= @@ -1003,6 +1024,14 @@ instance FromJSON Header where instance FromJSON Items where parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "items") +instance {-# OVERLAPPABLE #-} FromJSON (SwaggerItems t) where + parseJSON js = SwaggerItemsPrimitive <$> parseJSON js + +instance {-# OVERLAPPING #-} FromJSON (SwaggerItems Schema) where + parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js + parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js + parseJSON _ = empty + instance FromJSON Host where parseJSON (String s) = case fromInteger <$> readMaybe portStr of @@ -1035,11 +1064,6 @@ instance FromJSON ParamAnySchema where instance FromJSON ParamOtherSchema where parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema") -instance FromJSON SchemaItems where - parseJSON js@(Object _) = SchemaItemsObject <$> parseJSON js - parseJSON js@(Array _) = SchemaItemsArray <$> parseJSON js - parseJSON _ = empty - instance FromJSON Responses where parseJSON (Object o) = Responses <$> o .:? "default" @@ -1101,8 +1125,10 @@ instance FromJSON (CollectionFormat Param) where instance FromJSON (CollectionFormat Items) where parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] --- NOTE: The constraint @FromJSON (SwaggerType t)@ is necessary here! +-- NOTE: The constraints @FromJSON (SwaggerType t)@ and +-- @FromJSON (SwaggerItems t)@ are necessary here! -- Without the constraint the general instance will be used --- that only accepts common types (i.e. NOT object, null or file). -instance (FromJSON (SwaggerType t), FromJSON i) => FromJSON (ParamSchema t i) where +-- that only accepts common types (i.e. NOT object, null or file) +-- and primitive array items. +instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where parseJSON = genericParseJSON (jsonPrefix "ParamSchema") diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs index bf0ff23..d46c801 100644 --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -63,8 +63,8 @@ import Data.Swagger.SchemaOptions -- @ class ToParamSchema a where -- | Convert a type into a plain parameter schema. - toParamSchema :: proxy a -> ParamSchema t i - default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t i + toParamSchema :: proxy a -> ParamSchema t + default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t toParamSchema = genericToParamSchema defaultSchemaOptions instance {-# OVERLAPPING #-} ToParamSchema String where @@ -89,7 +89,7 @@ instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral -- | Default plain schema for @'Bounded'@, @'Integral'@ types. -toParamSchemaBoundedIntegral :: forall proxy a t i. (Bounded a, Integral a) => proxy a -> ParamSchema t i +toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t toParamSchemaBoundedIntegral _ = mempty & schemaType .~ SwaggerInteger & schemaMinimum ?~ fromInteger (toInteger (minBound :: a)) @@ -110,7 +110,7 @@ instance ToParamSchema Double where instance ToParamSchema Float where toParamSchema _ = mempty & schemaType .~ SwaggerNumber -timeParamSchema :: String -> ParamSchema t i +timeParamSchema :: String -> ParamSchema t timeParamSchema format = mempty & schemaType .~ SwaggerString & schemaFormat ?~ T.pack format @@ -158,7 +158,7 @@ instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = to instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a) -- | --- >>> encode (toParamSchema (Proxy :: Proxy ()) :: ParamSchema t Items) +-- >>> encode $ toParamSchema (Proxy :: Proxy ()) -- "{\"type\":\"string\",\"enum\":[\"_\"]}" instance ToParamSchema () where toParamSchema _ = mempty @@ -166,11 +166,11 @@ instance ToParamSchema () where & schemaEnum ?~ ["_"] -- | A configurable generic @'ParamSchema'@ creator. -genericToParamSchema :: forall proxy a t i. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t i +genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty class GToParamSchema (f :: * -> *) where - gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t i -> ParamSchema t i + gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t instance GToParamSchema f => GToParamSchema (D1 d f) where gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f) @@ -185,7 +185,7 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g)) class GEnumParamSchema (f :: * -> *) where - genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t i -> ParamSchema t i + genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g) diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index d2099af..f04808f 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -266,7 +266,7 @@ instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where ref <- declareSchemaRef (Proxy :: Proxy a) return $ unnamed $ mempty & schemaType .~ SwaggerArray - & schemaItems ?~ SchemaItemsObject ref + & schemaItems ?~ SwaggerItemsObject ref instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema @@ -449,7 +449,7 @@ instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where | otherwise = do (_, schema) <- recordSchema case schema ^. schemaItems of - Just (SchemaItemsArray [_]) -> fieldSchema + Just (SwaggerItemsArray [_]) -> fieldSchema _ -> pure (unnamed schema) where recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s @@ -474,10 +474,10 @@ gdeclareSchemaRef opts proxy = do return $ Ref (Reference name) _ -> Inline <$> gdeclareSchema opts proxy -appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems -appendItem x Nothing = Just (SchemaItemsArray [x]) -appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs)) -appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject" +appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema) +appendItem x Nothing = Just (SwaggerItemsArray [x]) +appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs)) +appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject" withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Declare Definitions Schema diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index 767bf6c..765e946 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} module Data.Swagger.Lens where @@ -43,8 +44,8 @@ makeLenses ''Items makeLenses ''Header -- ** 'Schema' lenses makeLenses ''Schema --- ** 'SchemaItems' prisms -makePrisms ''SchemaItems +-- ** 'SwaggerItems' prisms +makePrisms ''SwaggerItems -- ** 'ParamSchema' lenses makeLenses ''ParamSchema -- ** 'Xml' lenses @@ -80,60 +81,60 @@ instance HasDescription Schema (Maybe Text) where description = schemaDe instance HasDescription SecurityScheme (Maybe Text) where description = securitySchemeDescription instance HasDescription ExternalDocs (Maybe Text) where description = externalDocsDescription -class HasParamSchema s t i | s -> t i where - parameterSchema :: Lens' s (ParamSchema t i) +class HasParamSchema s t | s -> t where + parameterSchema :: Lens' s (ParamSchema t) -instance HasParamSchema Schema Schema SchemaItems where parameterSchema = schemaParamSchema -instance HasParamSchema ParamOtherSchema ParamOtherSchema Items where parameterSchema = paramOtherSchemaParamSchema -instance HasParamSchema Items Items Items where parameterSchema = itemsParamSchema -instance HasParamSchema Header Header Items where parameterSchema = headerParamSchema -instance HasParamSchema (ParamSchema t i) t i where parameterSchema = id +instance HasParamSchema Schema Schema where parameterSchema = schemaParamSchema +instance HasParamSchema ParamOtherSchema ParamOtherSchema where parameterSchema = paramOtherSchemaParamSchema +instance HasParamSchema Items Items where parameterSchema = itemsParamSchema +instance HasParamSchema Header Header where parameterSchema = headerParamSchema +instance HasParamSchema (ParamSchema t) t where parameterSchema = id -schemaType :: HasParamSchema s t i => Lens' s (SwaggerType t) +schemaType :: HasParamSchema s t => Lens' s (SwaggerType t) schemaType = parameterSchema.paramSchemaType -schemaFormat :: HasParamSchema s t i => Lens' s (Maybe Format) +schemaFormat :: HasParamSchema s t => Lens' s (Maybe Format) schemaFormat = parameterSchema.paramSchemaFormat -schemaItems :: HasParamSchema s t i => Lens' s (Maybe i) +schemaItems :: HasParamSchema s t => Lens' s (Maybe (SwaggerItems t)) schemaItems = parameterSchema.paramSchemaItems -schemaDefault :: HasParamSchema s t i => Lens' s (Maybe Value) +schemaDefault :: HasParamSchema s t => Lens' s (Maybe Value) schemaDefault = parameterSchema.paramSchemaDefault -schemaMaximum :: HasParamSchema s t i => Lens' s (Maybe Scientific) +schemaMaximum :: HasParamSchema s t => Lens' s (Maybe Scientific) schemaMaximum = parameterSchema.paramSchemaMaximum -schemaExclusiveMaximum :: HasParamSchema s t i => Lens' s (Maybe Bool) +schemaExclusiveMaximum :: HasParamSchema s t => Lens' s (Maybe Bool) schemaExclusiveMaximum = parameterSchema.paramSchemaExclusiveMaximum -schemaMinimum :: HasParamSchema s t i => Lens' s (Maybe Scientific) +schemaMinimum :: HasParamSchema s t => Lens' s (Maybe Scientific) schemaMinimum = parameterSchema.paramSchemaMinimum -schemaExclusiveMinimum :: HasParamSchema s t i => Lens' s (Maybe Bool) +schemaExclusiveMinimum :: HasParamSchema s t => Lens' s (Maybe Bool) schemaExclusiveMinimum = parameterSchema.paramSchemaExclusiveMinimum -schemaMaxLength :: HasParamSchema s t i => Lens' s (Maybe Integer) +schemaMaxLength :: HasParamSchema s t => Lens' s (Maybe Integer) schemaMaxLength = parameterSchema.paramSchemaMaxLength -schemaMinLength :: HasParamSchema s t i => Lens' s (Maybe Integer) +schemaMinLength :: HasParamSchema s t => Lens' s (Maybe Integer) schemaMinLength = parameterSchema.paramSchemaMinLength -schemaPattern :: HasParamSchema s t i => Lens' s (Maybe Text) +schemaPattern :: HasParamSchema s t => Lens' s (Maybe Text) schemaPattern = parameterSchema.paramSchemaPattern -schemaMaxItems :: HasParamSchema s t i => Lens' s (Maybe Integer) +schemaMaxItems :: HasParamSchema s t => Lens' s (Maybe Integer) schemaMaxItems = parameterSchema.paramSchemaMaxItems -schemaMinItems :: HasParamSchema s t i => Lens' s (Maybe Integer) +schemaMinItems :: HasParamSchema s t => Lens' s (Maybe Integer) schemaMinItems = parameterSchema.paramSchemaMinItems -schemaUniqueItems :: HasParamSchema s t i => Lens' s (Maybe Bool) +schemaUniqueItems :: HasParamSchema s t => Lens' s (Maybe Bool) schemaUniqueItems = parameterSchema.paramSchemaUniqueItems -schemaEnum :: HasParamSchema s t i => Lens' s (Maybe [Value]) +schemaEnum :: HasParamSchema s t => Lens' s (Maybe [Value]) schemaEnum = parameterSchema.paramSchemaEnum -schemaMultipleOf :: HasParamSchema s t i => Lens' s (Maybe Scientific) +schemaMultipleOf :: HasParamSchema s t => Lens' s (Maybe Scientific) schemaMultipleOf = parameterSchema.paramSchemaMultipleOf diff --git a/test/Data/Swagger/ParamSchemaSpec.hs b/test/Data/Swagger/ParamSchemaSpec.hs index 18669bd..697ba1f 100644 --- a/test/Data/Swagger/ParamSchemaSpec.hs +++ b/test/Data/Swagger/ParamSchemaSpec.hs @@ -18,7 +18,7 @@ import SpecCommon import Test.Hspec checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec -checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param Items) <=> js +checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js spec :: Spec spec = do