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