diff --git a/CHANGELOG.md b/CHANGELOG.md --- 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/src/Data/Swagger.hs b/src/Data/Swagger.hs --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -38,8 +38,9 @@ PathItem(..), -- ** Operations - Tag(..), Operation(..), + Tag(..), + TagName, -- ** Types and formats SwaggerType(..), @@ -52,8 +53,8 @@ ParamOtherSchema(..), ParamLocation(..), ParamName, - Items(..), Header(..), + HeaderName, Example(..), -- ** Schemas @@ -65,6 +66,7 @@ -- ** Responses Responses(..), Response(..), + HttpStatusCode, -- ** Security SecurityScheme(..), 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 @@ -211,7 +211,7 @@ 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. @@ -319,15 +319,21 @@ -- 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 @@ 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 @@ 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 @@ , _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 @@ { -- | 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) @@ -664,11 +658,14 @@ { 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. @@ -736,6 +733,10 @@ mempty = genericMempty mappend = genericMappend +instance Monoid Header where + mempty = genericMempty + mappend = genericMappend + instance Monoid Responses where mempty = genericMempty mappend = genericMappend @@ -752,6 +753,10 @@ mempty = genericMempty mappend = genericMappend +instance Monoid Example where + mempty = genericMempty + mappend = genericMappend + -- ======================================================================= -- SwaggerMonoid helper instances -- ======================================================================= @@ -779,43 +784,15 @@ 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) @@ -934,13 +911,12 @@ 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 $ @@ -1009,7 +985,7 @@ toJSON CollectionMulti = "multi" instance ToJSON (ParamSchema t) where - toJSON = genericToJSON (jsonPrefix "paramSchema") + toJSON = omitEmpties . genericToJSONWithSub "items" (jsonPrefix "paramSchema") -- ======================================================================= -- Manual FromJSON instances @@ -1068,11 +1044,10 @@ 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 @@ -1166,16 +1141,17 @@ 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 --- 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 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 @@ -82,9 +85,13 @@ instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Int16 where toParamSchema = toParamSchemaBoundedIntegral -instance ToParamSchema Int32 where toParamSchema = toParamSchemaBoundedIntegral -instance ToParamSchema Int64 where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Int32 where + toParamSchema proxy = toParamSchemaBoundedIntegral proxy & schemaFormat ?~ "int32" + +instance ToParamSchema Int64 where + toParamSchema proxy = toParamSchemaBoundedIntegral proxy & schemaFormat ?~ "int64" + instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral @@ -111,21 +118,23 @@ toParamSchema _ = mempty & schemaType .~ SwaggerNumber instance ToParamSchema Double where - toParamSchema _ = mempty & schemaType .~ SwaggerNumber + toParamSchema _ = mempty + & schemaType .~ SwaggerNumber + & schemaFormat ?~ "double" instance ToParamSchema Float where - toParamSchema _ = mempty & schemaType .~ SwaggerNumber + toParamSchema _ = mempty + & schemaType .~ SwaggerNumber + & schemaFormat ?~ "float" timeParamSchema :: String -> ParamSchema t timeParamSchema format = mempty & schemaType .~ SwaggerString & schemaFormat ?~ T.pack format --- | --- >>> toParamSchema (Proxy :: Proxy Day) ^. schemaFormat --- Just "yyyy-mm-dd" +-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format. instance ToParamSchema Day where - toParamSchema _ = timeParamSchema "yyyy-mm-dd" + toParamSchema _ = timeParamSchema "date" -- | -- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. schemaFormat @@ -161,6 +170,18 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a) 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 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 ()) 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 @@ -128,7 +128,7 @@ -- (Nothing,"{\"type\":\"string\"}") -- -- >>> encode <$> toNamedSchema (Proxy :: Proxy Day) --- (Just "Day","{\"format\":\"yyyy-mm-dd\",\"type\":\"string\"}") +-- (Just "Day","{\"format\":\"date\",\"type\":\"string\"}") toNamedSchema :: ToSchema a => proxy a -> NamedSchema toNamedSchema = undeclare . declareNamedSchema @@ -228,7 +228,7 @@ -- | Convert a type into a schema without references. -- -- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day]) --- "{\"items\":{\"format\":\"yyyy-mm-dd\",\"type\":\"string\"},\"type\":\"array\"}" +-- "{\"items\":{\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}" -- -- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema -- when inlining recursive schemas. @@ -305,11 +305,9 @@ & schemaType .~ SwaggerString & schemaFormat ?~ format --- | --- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat --- Just "yyyy-mm-dd" +-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format. instance ToSchema Day where - declareNamedSchema _ = pure $ named "Day" (timeSchema "yyyy-mm-dd") + declareNamedSchema _ = pure $ named "Day" (timeSchema "date") -- | -- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat @@ -317,11 +315,9 @@ instance ToSchema LocalTime where declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss") --- | --- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat --- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)" +-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format. instance ToSchema ZonedTime where - declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)" + declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time" instance ToSchema NominalDiffTime where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer) diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs --- 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 #-} @@ -14,6 +15,7 @@ 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 +68,17 @@ 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 +124,11 @@ swaggerMappend = mappend 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 diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -38,8 +38,6 @@ makePrisms ''ParamAnySchema -- ** 'ParamOtherSchema' lenses makeLenses ''ParamOtherSchema --- ** 'Items' lenses -makeLenses ''Items -- ** 'Header' lenses makeLenses ''Header -- ** 'Schema' lenses @@ -86,7 +84,6 @@ 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 diff --git a/swagger2.cabal b/swagger2.cabal --- 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 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 @@ -152,8 +152,8 @@ "type": "object", "properties": { - "x": { "type": "number" }, - "y": { "type": "number" } + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } }, "required": ["x", "y"] } @@ -458,8 +458,8 @@ "type": "object", "properties": { - "x": { "type": "number" }, - "y": { "type": "number" } + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } }, "required": ["x", "y"] } @@ -477,8 +477,8 @@ "type": "object", "properties": { - "x": { "type": "number" }, - "y": { "type": "number" } + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } }, "required": ["x", "y"] } @@ -545,9 +545,9 @@ "type": "object", "properties": { - "LightFreq": { "type": "number" }, + "LightFreq": { "type": "number", "format": "double" }, "LightColor": { "$ref": "#/definitions/Color" }, - "LightWaveLength": { "type": "number" } + "LightWaveLength": { "type": "number", "format": "double" } }, "maxProperties": 1, "minProperties": 1 @@ -560,13 +560,13 @@ "type": "object", "properties": { - "LightFreq": { "type": "number" }, + "LightFreq": { "type": "number", "format": "double" }, "LightColor": { "type": "string", "enum": ["Red", "Green", "Blue"] }, - "LightWaveLength": { "type": "number" } + "LightWaveLength": { "type": "number", "format": "double" } }, "maxProperties": 1, "minProperties": 1