Merge pull request #33 from GetShopTV/release-v1.1

Release v1.1

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:

src/Data/Swagger.hs

@@ -38,8 +38,9 @@ module Data.Swagger (
   PathItem(..),
 
   -- ** Operations
-  Tag(..),
   Operation(..),
+  Tag(..),
+  TagName,
 
   -- ** Types and formats
   SwaggerType(..),
@@ -52,8 +53,8 @@ module Data.Swagger (
   ParamOtherSchema(..),
   ParamLocation(..),
   ParamName,
-  Items(..),
   Header(..),
+  HeaderName,
   Example(..),
 
   -- ** Schemas
@@ -65,6 +66,7 @@ module Data.Swagger (
   -- ** Responses
   Responses(..),
   Response(..),
+  HttpStatusCode,
 
   -- ** Security
   SecurityScheme(..),

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.
@@ -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 <http://swagger.io/specification/#itemsObject Items Object>.
+--
+-- @'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)
 
@@ -664,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.
@@ -736,6 +733,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 +753,10 @@ instance Monoid Operation where
   mempty = genericMempty
   mappend = genericMappend
 
+instance Monoid Example where
+  mempty = genericMempty
+  mappend = genericMappend
+
 -- =======================================================================
 -- SwaggerMonoid helper instances
 -- =======================================================================
@@ -779,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)
@@ -934,13 +911,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 $
@@ -1009,7 +985,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
@@ -1068,11 +1044,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
@@ -1166,16 +1141,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")
+

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 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\":[\"_\"]}"

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.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 +68,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 +124,11 @@ class SwaggerMonoid m where
   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

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
 

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