From e744420df5697e6cb97c2c549cb705bb13c6a669 Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Tue, 22 Dec 2015 18:04:28 +0300 Subject: [PATCH 1/7] Export HeaderName and HttpStatusCode --- src/Data/Swagger.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 001e9a1..2b08f2b 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -54,6 +54,7 @@ module Data.Swagger ( ParamName, Items(..), Header(..), + HeaderName, Example(..), -- ** Schemas @@ -65,6 +66,7 @@ module Data.Swagger ( -- ** Responses Responses(..), Response(..), + HttpStatusCode, -- ** Security SecurityScheme(..), From 1a35138e60324ef2630072736869b4885325dd1c Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 24 Dec 2015 14:10:06 +0300 Subject: [PATCH 2/7] Add ToParamSchema instances for [a], Set a and HashSet a --- src/Data/Swagger/Internal/ParamSchema.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs index a6d3ba1..0d025aa 100644 --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -15,7 +16,9 @@ import Data.Proxy import GHC.Generics import Data.Int +import "unordered-containers" Data.HashSet (HashSet) import Data.Monoid +import Data.Set (Set) import Data.Scientific import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -168,6 +171,18 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to 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 [a] where + toParamSchema _ = mempty + & schemaType .~ SwaggerArray + & schemaItems ?~ SwaggerItemsPrimitive (Items Nothing (toParamSchema (Proxy :: Proxy a))) + +instance ToParamSchema a => ToParamSchema (Set a) where + toParamSchema _ = toParamSchema (Proxy :: Proxy [a]) + & schemaUniqueItems ?~ True + +instance ToParamSchema a => ToParamSchema (HashSet a) where + toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a)) + -- | -- >>> encode $ toParamSchema (Proxy :: Proxy ()) -- "{\"type\":\"string\",\"enum\":[\"_\"]}" From ff6e2be1854bd759dd60d5b710165aa0ce82f1c6 Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 24 Dec 2015 14:18:23 +0300 Subject: [PATCH 3/7] Add Monoid instances for Header and Example --- src/Data/Swagger/Internal.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index e2ca0b6..b30fd93 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -736,6 +736,10 @@ instance Monoid ParamOtherSchema where mempty = genericMempty mappend = genericMappend +instance Monoid Header where + mempty = genericMempty + mappend = genericMappend + instance Monoid Responses where mempty = genericMempty mappend = genericMappend @@ -752,6 +756,10 @@ instance Monoid Operation where mempty = genericMempty mappend = genericMappend +instance Monoid Example where + mempty = genericMempty + mappend = genericMappend + -- ======================================================================= -- SwaggerMonoid helper instances -- ======================================================================= From 3cc860dd3f002ab984f4d0e4ce1d1799f985832e Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 24 Dec 2015 22:16:02 +0300 Subject: [PATCH 4/7] Put CollectionFormat in one place (closes #28). This change places collection format in SwaggerItems. --- src/Data/Swagger.hs | 1 - src/Data/Swagger/Internal.hs | 65 +++++++++++------------- src/Data/Swagger/Internal/ParamSchema.hs | 2 +- src/Data/Swagger/Internal/Utils.hs | 13 +++-- src/Data/Swagger/Lens.hs | 3 -- 5 files changed, 39 insertions(+), 45 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 2b08f2b..771dd0d 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -52,7 +52,6 @@ module Data.Swagger ( ParamOtherSchema(..), ParamLocation(..), ParamName, - Items(..), Header(..), HeaderName, Example(..), diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index b30fd93..db5b80c 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -319,15 +319,21 @@ data ParamOtherSchema = ParamOtherSchema -- Default value is @False@. , _paramOtherSchemaAllowEmptyValue :: Maybe Bool - -- | Determines the format of the array if @'ParamArray'@ is used. - -- Default value is csv. - , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param) - , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema } deriving (Eq, Show, Generic, Data, Typeable) +-- | Items for @'SwaggerArray'@ schemas. +-- +-- @'SwaggerItemsPrimitive'@ should be used only for query params, headers and path pieces. +-- The @'CollectionFormat' t@ parameter specifies how elements of an array should be displayed. +-- Note that @fmt@ in @'SwaggerItemsPrimitive' fmt schema@ specifies format for elements of type @schema@. +-- This is different from the original Swagger's . +-- +-- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s. +-- +-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s. data SwaggerItems t where - SwaggerItemsPrimitive :: Items -> SwaggerItems t + SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema @@ -341,9 +347,9 @@ swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimiti swaggerItemsDataType :: DataType swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr] -instance {-# OVERLAPPABLE #-} Typeable t => Data (SwaggerItems t) where +instance {-# OVERLAPPABLE #-} Data t => Data (SwaggerItems t) where gunfold k z c = case constrIndex c of - 1 -> k (z SwaggerItemsPrimitive) + 1 -> k (k (z SwaggerItemsPrimitive)) _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)." toConstr _ = swaggerItemsPrimitiveConstr dataTypeOf _ = swaggerItemsDataType @@ -508,7 +514,7 @@ deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data data Xml = Xml { -- | Replaces the name of the element/attribute used for the described schema property. - -- When defined within the @'Items'@ (items), it will affect the name of the individual XML elements within the list. + -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list. -- When defined alongside type being array (outside the items), -- it will affect the wrapping element and only if wrapped is true. -- If wrapped is false, it will be ignored. @@ -534,14 +540,6 @@ data Xml = Xml , _xmlWrapped :: Maybe Bool } deriving (Eq, Show, Generic, Data, Typeable) -data Items = Items - { -- | Determines the format of the array if type array is used. - -- Default value is @'ItemsCollectionCSV'@. - _itemsCollectionFormat :: Maybe (CollectionFormat Items) - - , _itemsParamSchema :: ParamSchema Items - } deriving (Eq, Show, Generic, Data, Typeable) - -- | A container for the expected responses of an operation. -- The container maps a HTTP response code to the expected response. -- It is not expected from the documentation to necessarily cover all possible HTTP response codes, @@ -585,10 +583,6 @@ data Header = Header { -- | A short description of the header. _headerDescription :: Maybe Text - -- | Determines the format of the array if type array is used. - -- Default value is @'ItemsCollectionCSV'@. - , _headerCollectionFormat :: Maybe (CollectionFormat Items) - , _headerParamSchema :: ParamSchema Header } deriving (Eq, Show, Generic, Data, Typeable) @@ -942,13 +936,12 @@ instance ToJSON Schema where instance ToJSON Header where toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header") -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 + toJSON (SwaggerItemsPrimitive fmt schema) = object + [ "collectionFormat" .= fmt + , "items" .= schema ] + toJSON (SwaggerItemsObject x) = object [ "items" .= x ] + toJSON (SwaggerItemsArray x) = object [ "items" .= x ] instance ToJSON Host where toJSON (Host host mport) = toJSON $ @@ -1017,7 +1010,7 @@ instance ToJSON (CollectionFormat t) where toJSON CollectionMulti = "multi" instance ToJSON (ParamSchema t) where - toJSON = genericToJSON (jsonPrefix "paramSchema") + toJSON = omitEmpties . genericToJSONWithSub "items" (jsonPrefix "paramSchema") -- ======================================================================= -- Manual FromJSON instances @@ -1076,11 +1069,10 @@ instance FromJSON Schema where instance FromJSON Header where parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header") -instance FromJSON Items where - parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "items") - -instance {-# OVERLAPPABLE #-} FromJSON (SwaggerItems t) where - parseJSON js = SwaggerItemsPrimitive <$> parseJSON js +instance {-# OVERLAPPABLE #-} (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where + parseJSON (Object o) = SwaggerItemsPrimitive + <$> o .:? "collectionFormat" + <*> (o .: "items" >>= parseJSON) instance {-# OVERLAPPING #-} FromJSON (SwaggerItems Schema) where parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js @@ -1174,16 +1166,17 @@ instance FromJSON (SwaggerType ParamOtherSchema) where instance {-# OVERLAPPABLE #-} FromJSON (SwaggerType t) where parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray] +instance {-# OVERLAPPABLE #-} FromJSON (CollectionFormat t) where + parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] + instance FromJSON (CollectionFormat Param) where parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti] -instance FromJSON (CollectionFormat Items) where - parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] - -- 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) -- and primitive array items. instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where - parseJSON = genericParseJSON (jsonPrefix "ParamSchema") + parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema") + diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs index 0d025aa..2b2aa1b 100644 --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -174,7 +174,7 @@ instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = to instance ToParamSchema a => ToParamSchema [a] where toParamSchema _ = mempty & schemaType .~ SwaggerArray - & schemaItems ?~ SwaggerItemsPrimitive (Items Nothing (toParamSchema (Proxy :: Proxy a))) + & schemaItems ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a)) instance ToParamSchema a => ToParamSchema (Set a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a]) diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs index b3de04a..6f1aff7 100644 --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -14,6 +14,7 @@ import Data.Data import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Map (Map) import Data.Monoid import Data.Text (Text) import GHC.Generics @@ -66,14 +67,17 @@ genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> genericToJSONWithSub sub opts x = case genericToJSON opts x of Object o -> - let so = HashMap.lookupDefault (error "impossible") sub o - in Object (HashMap.delete sub o) <+> so + case HashMap.lookup sub o of + Just so -> Object (HashMap.delete sub o) <+> so + Nothing -> Object o -- no subjson, leaving object as is _ -> error "genericToJSONWithSub: subjson is not an object" genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a -genericParseJSONWithSub sub opts (Object o) = genericParseJSON opts js +genericParseJSONWithSub sub opts js@(Object o) + = genericParseJSON opts js -- try without subjson + <|> genericParseJSON opts js' -- try with subjson where - js = Object (HashMap.insert sub (Object o) o) + js' = Object (HashMap.insert sub (Object o) o) genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object" (<+>) :: Value -> Value -> Value @@ -119,6 +123,7 @@ class SwaggerMonoid m where swaggerMappend = mappend instance SwaggerMonoid [a] +instance Ord k => SwaggerMonoid (Map k v) instance SwaggerMonoid Text where swaggerMempty = mempty diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index 765e946..12fc4e4 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -38,8 +38,6 @@ makeLenses ''Param makePrisms ''ParamAnySchema -- ** 'ParamOtherSchema' lenses makeLenses ''ParamOtherSchema --- ** 'Items' lenses -makeLenses ''Items -- ** 'Header' lenses makeLenses ''Header -- ** 'Schema' lenses @@ -86,7 +84,6 @@ class HasParamSchema s t | s -> t where 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 From 38e2384d0d2a9d419ab1d9e9a43e4c5162b272e5 Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Fri, 25 Dec 2015 13:17:13 +0300 Subject: [PATCH 5/7] Add TagName type synonym --- src/Data/Swagger.hs | 3 ++- src/Data/Swagger/Internal.hs | 7 +++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 771dd0d..f030e13 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -38,8 +38,9 @@ module Data.Swagger ( PathItem(..), -- ** Operations - Tag(..), Operation(..), + Tag(..), + TagName, -- ** Types and formats SwaggerType(..), diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index db5b80c..748f98e 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -211,7 +211,7 @@ data PathItem = PathItem data Operation = Operation { -- | A list of tags for API documentation control. -- Tags can be used for logical grouping of operations by resources or any other qualifier. - _operationTags :: [Text] + _operationTags :: [TagName] -- | A short summary of what the operation does. -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters. @@ -658,11 +658,14 @@ newtype SecurityRequirement = SecurityRequirement { getSecurityRequirement :: HashMap Text [Text] } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable) +-- | Tag name. +type TagName = Text + -- | Allows adding meta data to a single tag that is used by @Operation@. -- It is not mandatory to have a @Tag@ per tag used there. data Tag = Tag { -- | The name of the tag. - _tagName :: Text + _tagName :: TagName -- | A short description for the tag. -- GFM syntax can be used for rich text representation. From ab875b49baa185e9af43ec24a1cde3ced0a04ef2 Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 31 Dec 2015 01:04:23 +0300 Subject: [PATCH 6/7] Use overwrite strategy for HashMap SwaggerMonoid instances by default --- src/Data/Swagger/Internal.hs | 30 +----------------------------- src/Data/Swagger/Internal/Utils.hs | 5 +++++ 2 files changed, 6 insertions(+), 29 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 748f98e..d220147 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -784,43 +784,15 @@ instance SwaggerMonoid ParamLocation where swaggerMempty = ParamQuery swaggerMappend _ y = y -instance SwaggerMonoid (HashMap Text Schema) where +instance SwaggerMonoid (HashMap FilePath PathItem) where swaggerMempty = HashMap.empty swaggerMappend = HashMap.unionWith mappend -instance SwaggerMonoid (HashMap Text (Referenced Schema)) where - swaggerMempty = HashMap.empty - swaggerMappend = HashMap.unionWith swaggerMappend - instance Monoid a => SwaggerMonoid (Referenced a) where swaggerMempty = Inline mempty swaggerMappend (Inline x) (Inline y) = Inline (x <> y) swaggerMappend _ y = y -instance SwaggerMonoid (HashMap Text Param) where - swaggerMempty = HashMap.empty - swaggerMappend = HashMap.unionWith mappend - -instance SwaggerMonoid (HashMap Text Response) where - swaggerMempty = HashMap.empty - swaggerMappend = flip HashMap.union - -instance SwaggerMonoid (HashMap Text SecurityScheme) where - swaggerMempty = HashMap.empty - swaggerMappend = flip HashMap.union - -instance SwaggerMonoid (HashMap FilePath PathItem) where - swaggerMempty = HashMap.empty - swaggerMappend = HashMap.unionWith mappend - -instance SwaggerMonoid (HashMap HeaderName Header) where - swaggerMempty = HashMap.empty - swaggerMappend = flip HashMap.union - -instance SwaggerMonoid (HashMap HttpStatusCode (Referenced Response)) where - swaggerMempty = HashMap.empty - swaggerMappend = flip HashMap.union - instance SwaggerMonoid ParamAnySchema where swaggerMempty = ParamOther swaggerMempty swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y) diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs index 6f1aff7..10c7905 100644 --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} @@ -125,6 +126,10 @@ class SwaggerMonoid m where instance SwaggerMonoid [a] instance Ord k => SwaggerMonoid (Map k v) +instance {-# OVERLAPPABLE #-} (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where + swaggerMempty = mempty + swaggerMappend = HashMap.unionWith (\_old new -> new) + instance SwaggerMonoid Text where swaggerMempty = mempty swaggerMappend x "" = x From c2cd0b1ef855273967279addd862998e155ab8f4 Mon Sep 17 00:00:00 2001 From: Nickolay Kudasov Date: Thu, 31 Dec 2015 01:37:01 +0300 Subject: [PATCH 7/7] Bump version and update changelog --- CHANGELOG.md | 14 ++++++++++++++ swagger2.cabal | 2 +- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b373f6e..1b24322 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,17 @@ +1.1 +--- +* Major changes: + * Put `CollectionFormat` in one place (see [`3cc860d`](https://github.com/GetShopTV/swagger2/commit/3cc860dd3f002ab984f4d0e4ce1d1799f985832e)). + +* Minor changes: + * Use Swagger formats for `Int32`, `Int64`, `Float`, `Double`, `Day` and `ZonedTime` (see [#32](https://github.com/GetShopTV/swagger2/pull/32)); + * Export `HeaderName`, `TagName`, `HttpStatusCode` type synonyms; + * Add `ToParamSchema` instances for `[a]`, `Set a` and `HashSet a`; + * Add `Monoid` instances for `Header` and `Example`. + +* Fixes: + * Use overwrite strategy for `HashMap` `SwaggerMonoid` instances by default. + 1.0 --- * Major changes: diff --git a/swagger2.cabal b/swagger2.cabal index 4710c51..70e147d 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -1,5 +1,5 @@ name: swagger2 -version: 1.0 +version: 1.1 synopsis: Swagger 2.0 data model description: Please see README.md homepage: https://github.com/GetShopTV/swagger2