swagger2 2.0.2 → 2.1
raw patch · 13 files changed
+695/−202 lines, 13 filesdep +bytestringdep +generics-sopdep +insert-ordered-containersdep ~aeson
Dependencies added: bytestring, generics-sop, insert-ordered-containers
Dependency ranges changed: aeson
Files
- CHANGELOG.md +7/−0
- src/Data/Swagger.hs +3/−3
- src/Data/Swagger/Internal.hs +226/−105
- src/Data/Swagger/Internal/AesonUtils.hs +336/−0
- src/Data/Swagger/Internal/Schema.hs +29/−25
- src/Data/Swagger/Internal/Schema/Validation.hs +4/−2
- src/Data/Swagger/Internal/Utils.hs +6/−45
- src/Data/Swagger/Lens.hs +8/−7
- src/Data/Swagger/Operation.hs +9/−8
- swagger2.cabal +9/−3
- test/Data/Swagger/ParamSchemaSpec.hs +3/−1
- test/Data/Swagger/SchemaSpec.hs +48/−1
- test/SpecCommon.hs +7/−2
CHANGELOG.md view
@@ -1,3 +1,10 @@+2.1+---++* Major changes:+ * Use `InsOrdHashMap` to preserve insertion order for endpoints and definitions (see [#56](https://github.com/GetShopTV/swagger2/pull/56));+ * Add support for GHC 8.0 (see [#65](https://github.com/GetShopTV/swagger2/pull/65)).+ 2.0.2 ---
src/Data/Swagger.hs view
@@ -186,7 +186,7 @@ -- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User")) -- & at 404 ?~ "User info not found")) ] -- :}--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}},\"produces\":[\"application/json\"]}}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}" -- -- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@ -- which produces @application/json@ output. It should respond with code @200@ and body specified@@ -205,7 +205,7 @@ -- & type_ .~ SwaggerBoolean -- & description ?~ "To be or not to be" -- :}--- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}"+-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}" -- -- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@). -- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.@@ -271,7 +271,7 @@ -- >>> encode (Person "David" 28) -- "{\"age\":28,\"name\":\"David\"}" -- >>> encode $ toSchema (Proxy :: Proxy Person)--- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}"+-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}" -- $manipulation -- Sometimes you have to work with an imported or generated @'Swagger'@.
src/Data/Swagger/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}@@ -11,19 +12,23 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+#if __GLASGOW_HASKELL__ <710+{-# LANGUAGE PolyKinds #-}+#endif #include "overlapping-compat.h" module Data.Swagger.Internal where import Prelude () import Prelude.Compat +import Control.Lens ((&), (.~), (?~)) import Control.Applicative-import Control.Monad import Data.Aeson import qualified Data.Aeson.Types as JSON import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)-import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import qualified Data.Map as Map@@ -38,10 +43,29 @@ import Network.HTTP.Media (MediaType) import Text.Read (readMaybe) +import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap++import Generics.SOP.TH (deriveGeneric)+import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON+ ,sopSwaggerGenericToJSONWithOpts+ ,sopSwaggerGenericParseJSON+ ,HasSwaggerAesonOptions(..)+ ,AesonDefaultValue(..)+ ,mkSwaggerAesonOptions+ ,saoAdditionalPairs+ ,saoSubObject) import Data.Swagger.Internal.Utils +#if MIN_VERSION_aeson(0,10,0)+import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)+#define DEFINE_TOENCODING toEncoding = sopSwaggerGenericToEncoding+#else+#define DEFINE_TOENCODING+#endif+ -- | A list of definitions that can be used in references.-type Definitions = HashMap Text+type Definitions = InsOrdHashMap Text -- | This is the root document object for the API specification. data Swagger = Swagger@@ -73,7 +97,7 @@ -- | The available paths and operations for the API. -- Holds the relative paths to the individual endpoints. -- The path is appended to the @'basePath'@ in order to construct the full URL.- , _swaggerPaths :: HashMap FilePath PathItem+ , _swaggerPaths :: InsOrdHashMap FilePath PathItem -- | An object to hold data types produced and consumed by operations. , _swaggerDefinitions :: Definitions Schema@@ -330,8 +354,8 @@ -- Default value is @False@. , _paramOtherSchemaAllowEmptyValue :: Maybe Bool - , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema- } deriving (Eq, Show, Generic, Data, Typeable)+ , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema+ } deriving (Eq, Show, Generic, Typeable, Data) -- | Items for @'SwaggerArray'@ schemas. --@@ -344,9 +368,9 @@ -- -- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s. data SwaggerItems t where- SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t- SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema- SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema+ SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema deriving (Typeable) deriving instance Eq (SwaggerItems t)@@ -356,27 +380,76 @@ swaggerItemsPrimitiveConstr :: Constr swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix +swaggerItemsObjectConstr :: Constr+swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix++swaggerItemsArrayConstr :: Constr+swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix+ swaggerItemsDataType :: DataType swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr] -instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where+-- Note: unfortunately we have to write these Data instances by hand,+-- to get better contexts / avoid duplicate name when using standalone deriving++instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where+ -- TODO: define gfoldl gunfold k z c = case constrIndex c of 1 -> k (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)+-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only+instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where+ -- TODO: define gfoldl+ gunfold k z c = case constrIndex c of+ 1 -> k (k (z SwaggerItemsPrimitive))+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindParamOtherSchema)."+ toConstr _ = swaggerItemsPrimitiveConstr+ dataTypeOf _ = swaggerItemsDataType +instance Data (SwaggerItems 'SwaggerKindSchema) where+ gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema"+ gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref+ gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref++ gunfold k z c = case constrIndex c of+ 2 -> k (z SwaggerItemsObject)+ 3 -> k (z SwaggerItemsArray)+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)."++ toConstr (SwaggerItemsPrimitive _ _) = error "Not supported"+ toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr+ toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr++ dataTypeOf _ = swaggerItemsDataType++-- | Type used as a kind to avoid overlapping instances.+data SwaggerKind t+ = SwaggerKindNormal t+ | SwaggerKindParamOtherSchema+ | SwaggerKindSchema+ deriving (Typeable)++deriving instance Typeable 'SwaggerKindNormal+deriving instance Typeable 'SwaggerKindParamOtherSchema+deriving instance Typeable 'SwaggerKindSchema++type family SwaggerKindType (k :: SwaggerKind *) :: *+type instance SwaggerKindType ('SwaggerKindNormal t) = t+type instance SwaggerKindType 'SwaggerKindSchema = Schema+type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema+ data SwaggerType t where SwaggerString :: SwaggerType t SwaggerNumber :: SwaggerType t SwaggerInteger :: SwaggerType t SwaggerBoolean :: SwaggerType t SwaggerArray :: SwaggerType t- SwaggerFile :: SwaggerType ParamOtherSchema- SwaggerNull :: SwaggerType Schema- SwaggerObject :: SwaggerType Schema+ SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema+ SwaggerNull :: SwaggerType 'SwaggerKindSchema+ SwaggerObject :: SwaggerType 'SwaggerKindSchema deriving (Typeable) deriving instance Eq (SwaggerType t)@@ -388,30 +461,30 @@ swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs -swaggerCommonTypes :: [SwaggerType t]+swaggerCommonTypes :: [SwaggerType k] swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray] -swaggerParamTypes :: [SwaggerType ParamOtherSchema]+swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema] swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile] -swaggerSchemaTypes :: [SwaggerType Schema]+swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema] swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject] swaggerTypeConstrs :: [Constr]-swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema]) ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject] -instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where+instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes toConstr = swaggerTypeConstr dataTypeOf = swaggerTypeDataType -instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where+instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes toConstr = swaggerTypeConstr dataTypeOf = swaggerTypeDataType -instance OVERLAPPABLE_ Data (SwaggerType Schema) where+instance Data (SwaggerType 'SwaggerKindSchema) where gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes toConstr = swaggerTypeConstr dataTypeOf = swaggerTypeDataType@@ -451,7 +524,7 @@ -- Corresponds to multiple parameter instances -- instead of multiple values for a single instance @foo=bar&foo=baz@. -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.- CollectionMulti :: CollectionFormat ParamOtherSchema+ CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema deriving (Typeable) deriving instance Eq (CollectionFormat t)@@ -467,12 +540,12 @@ collectionCommonFormats :: [CollectionFormat t] collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ] -instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where+instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats toConstr = collectionFormatConstr dataTypeOf _ = collectionFormatDataType -deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)+deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema) type ParamName = Text @@ -482,7 +555,7 @@ , _schemaRequired :: [ParamName] , _schemaAllOf :: Maybe [Schema]- , _schemaProperties :: HashMap Text (Referenced Schema)+ , _schemaProperties :: InsOrdHashMap Text (Referenced Schema) , _schemaAdditionalProperties :: Maybe (Referenced Schema) , _schemaDiscriminator :: Maybe Text@@ -494,7 +567,7 @@ , _schemaMaxProperties :: Maybe Integer , _schemaMinProperties :: Maybe Integer - , _schemaParamSchema :: ParamSchema Schema+ , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema } deriving (Eq, Show, Generic, Data, Typeable) -- | A @'Schema'@ with an optional name.@@ -507,7 +580,7 @@ -- | Regex pattern for @string@ type. type Pattern = Text -data ParamSchema t = ParamSchema+data ParamSchema (t :: SwaggerKind *) = 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.@@ -532,7 +605,7 @@ , _paramSchemaMultipleOf :: Maybe Scientific } deriving (Eq, Show, Generic, Typeable) -deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)+deriving instance (Typeable k, Data (SwaggerKindType k), Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k) data Xml = Xml { -- | Replaces the name of the element/attribute used for the described schema property.@@ -574,7 +647,7 @@ -- | Any HTTP status code can be used as the property name (one property per HTTP status code). -- Describes the expected response for those HTTP status codes.- , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)+ , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response) } deriving (Eq, Show, Generic, Data, Typeable) type HttpStatusCode = Int@@ -593,7 +666,7 @@ , _responseSchema :: Maybe (Referenced Schema) -- | A list of headers that are sent with the response.- , _responseHeaders :: HashMap HeaderName Header+ , _responseHeaders :: InsOrdHashMap HeaderName Header -- | An example of the response message. , _responseExamples :: Maybe Example@@ -608,7 +681,7 @@ { -- | A short description of the header. _headerDescription :: Maybe Text - , _headerParamSchema :: ParamSchema Header+ , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header) } deriving (Eq, Show, Generic, Data, Typeable) data Example = Example { getExample :: Map MediaType Value }@@ -659,7 +732,7 @@ _oauth2Flow :: OAuth2Flow -- | The available scopes for the OAuth2 security scheme.- , _oauth2Scopes :: HashMap Text Text+ , _oauth2Scopes :: InsOrdHashMap Text Text } deriving (Eq, Show, Generic, Data, Typeable) data SecuritySchemeType@@ -680,7 +753,7 @@ -- The object can have multiple security schemes declared in it which are all required -- (that is, there is a logical AND between the schemes). newtype SecurityRequirement = SecurityRequirement- { getSecurityRequirement :: HashMap Text [Text]+ { getSecurityRequirement :: InsOrdHashMap Text [Text] } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable) -- | Tag name.@@ -814,9 +887,9 @@ swaggerMempty = ParamQuery swaggerMappend _ y = y -instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where- swaggerMempty = HashMap.empty- swaggerMappend = HashMap.unionWith mappend+instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where+ swaggerMempty = InsOrdHashMap.empty+ swaggerMappend = InsOrdHashMap.unionWith mappend instance Monoid a => SwaggerMonoid (Referenced a) where swaggerMempty = Inline mempty@@ -914,7 +987,8 @@ , "tokenUrl" .= tokenUrl ] instance ToJSON OAuth2Params where- toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING instance ToJSON SecuritySchemeType where toJSON SecuritySchemeBasic@@ -927,24 +1001,22 @@ <+> object [ "type" .= ("oauth2" :: Text) ] instance ToJSON Swagger where- toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")- where- addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)- addVersion _ = error "impossible"+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING instance ToJSON SecurityScheme where- toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING instance ToJSON Schema where- toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")- where- f "items" (Array _) = True- f _ _ = False+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING instance ToJSON Header where- toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING -instance ToJSON (SwaggerItems t) where+instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where toJSON (SwaggerItemsPrimitive fmt schema) = object [ "collectionFormat" .= fmt , "items" .= schema ]@@ -961,27 +1033,32 @@ toJSON (MimeList xs) = toJSON (map show xs) instance ToJSON Param where- toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING instance ToJSON ParamAnySchema where toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ] toJSON (ParamOther s) = toJSON s instance ToJSON ParamOtherSchema where- toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING instance ToJSON Responses where- toJSON (Responses def rs) = omitEmpties $- toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING instance ToJSON Response where- toJSON = omitEmpties . genericToJSON (jsonPrefix "response")+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING instance ToJSON Operation where- toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING instance ToJSON PathItem where- toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")+ toJSON = sopSwaggerGenericToJSON+ DEFINE_TOENCODING instance ToJSON Example where toJSON = toJSON . Map.mapKeys show . getExample@@ -1014,11 +1091,10 @@ toJSON CollectionPipes = "pipes" toJSON CollectionMulti = "multi" -instance ToJSON (ParamSchema t) where- toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")- where- f "items" (Array _) = True- f _ _ = False+instance ToJSON (ParamSchema k) where+ -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`?+ toJSON = sopSwaggerGenericToJSONWithOpts $+ mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" -- ======================================================================= -- Manual FromJSON instances@@ -1038,7 +1114,7 @@ parseJSON _ = empty instance FromJSON OAuth2Params where- parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")+ parseJSON = sopSwaggerGenericParseJSON instance FromJSON SecuritySchemeType where parseJSON js@(Object o) = do@@ -1051,38 +1127,28 @@ parseJSON _ = empty instance FromJSON Swagger where- parseJSON js@(Object o) = do- (version :: Text) <- o .: "swagger"- when (version /= "2.0") empty- (genericParseJSON (jsonPrefix "swagger")- `withDefaults` [ "consumes" .= (mempty :: MimeList)- , "produces" .= (mempty :: MimeList)- , "security" .= ([] :: [SecurityRequirement])- , "tags" .= ([] :: [Tag])- , "definitions" .= (mempty :: Definitions Schema)- , "parameters" .= (mempty :: Definitions Param)- , "responses" .= (mempty :: Definitions Response)- , "securityDefinitions" .= (mempty :: Definitions SecurityScheme)- ] ) js- parseJSON _ = empty+ parseJSON = sopSwaggerGenericParseJSON instance FromJSON SecurityScheme where- parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")+ parseJSON = sopSwaggerGenericParseJSON instance FromJSON Schema where- parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")- `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)- , "required" .= ([] :: [ParamName]) ]+ parseJSON = sopSwaggerGenericParseJSON instance FromJSON Header where- parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")+ parseJSON = sopSwaggerGenericParseJSON -instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where+instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive <$> o .:? "collectionFormat" <*> (o .: "items" >>= parseJSON) -instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where+instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where+ parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive+ <$> o .:? "collectionFormat"+ <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))++instance FromJSON (SwaggerItems 'SwaggerKindSchema) where parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js parseJSON _ = empty@@ -1100,7 +1166,7 @@ parseJSON js = (MimeList . map fromString) <$> parseJSON js instance FromJSON Param where- parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")+ parseJSON = sopSwaggerGenericParseJSON instance FromJSON ParamAnySchema where parseJSON js@(Object o) = do@@ -1113,12 +1179,12 @@ parseJSON _ = empty instance FromJSON ParamOtherSchema where- parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")+ parseJSON = sopSwaggerGenericParseJSON instance FromJSON Responses where parseJSON (Object o) = Responses <$> o .:? "default"- <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)+ <*> (parseJSON (Object (HashMap.delete "default" o))) parseJSON _ = empty instance FromJSON Example where@@ -1127,18 +1193,13 @@ pure $ Example (Map.mapKeys fromString m) instance FromJSON Response where- parseJSON = genericParseJSON (jsonPrefix "response")- `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]+ parseJSON = sopSwaggerGenericParseJSON instance FromJSON Operation where- parseJSON = genericParseJSON (jsonPrefix "operation")- `withDefaults` [ "security" .= ([] :: [SecurityRequirement])- , "tags" .= ([] :: [Tag])- , "parameters" .= ([] :: [Referenced Param]) ]+ parseJSON = sopSwaggerGenericParseJSON instance FromJSON PathItem where- parseJSON = genericParseJSON (jsonPrefix "pathItem")- `withDefaults` [ "parameters" .= ([] :: [Param]) ]+ parseJSON = sopSwaggerGenericParseJSON instance FromJSON Reference where parseJSON (Object o) = Reference <$> o .: "$ref"@@ -1164,26 +1225,86 @@ instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") -instance FromJSON (SwaggerType Schema) where+instance FromJSON (SwaggerType 'SwaggerKindSchema) where parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject] -instance FromJSON (SwaggerType ParamOtherSchema) where+instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile] -instance OVERLAPPABLE_ FromJSON (SwaggerType t) where+instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray] -instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where+instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] -instance FromJSON (CollectionFormat ParamOtherSchema) where+-- NOTE: There aren't collections of 'Schema'+--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where+-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]++instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti] --- 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 = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")+instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where+ parseJSON = sopSwaggerGenericParseJSON+instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where+ parseJSON = sopSwaggerGenericParseJSON+instance FromJSON (ParamSchema 'SwaggerKindSchema) where+ parseJSON = sopSwaggerGenericParseJSON +-------------------------------------------------------------------------------+-- TH splices+-------------------------------------------------------------------------------++deriveGeneric ''Header+deriveGeneric ''OAuth2Params+deriveGeneric ''Operation+deriveGeneric ''Param+deriveGeneric ''ParamOtherSchema+deriveGeneric ''PathItem+deriveGeneric ''Response+deriveGeneric ''Responses+deriveGeneric ''SecurityScheme+deriveGeneric ''Schema+deriveGeneric ''ParamSchema+deriveGeneric ''Swagger++instance HasSwaggerAesonOptions Header where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema"+instance HasSwaggerAesonOptions OAuth2Params where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow"+instance HasSwaggerAesonOptions Operation where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "operation"+instance HasSwaggerAesonOptions Param where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject ?~ "schema"+instance HasSwaggerAesonOptions ParamOtherSchema where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramOtherSchema" & saoSubObject ?~ "paramSchema"+instance HasSwaggerAesonOptions PathItem where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem"+instance HasSwaggerAesonOptions Response where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "response"+instance HasSwaggerAesonOptions Responses where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses"+instance HasSwaggerAesonOptions SecurityScheme where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type"+instance HasSwaggerAesonOptions Schema where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema"+instance HasSwaggerAesonOptions Swagger where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")]++instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"+instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"+-- NOTE: Schema doesn't have 'items' sub object!+instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where+ swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema"++instance AesonDefaultValue (ParamSchema s)+instance AesonDefaultValue OAuth2Flow+instance AesonDefaultValue Responses+instance AesonDefaultValue ParamAnySchema+instance AesonDefaultValue SecuritySchemeType+instance AesonDefaultValue (SwaggerType a)+instance AesonDefaultValue MimeList where defaultValue = Just mempty+instance AesonDefaultValue Info+instance AesonDefaultValue ParamLocation
+ src/Data/Swagger/Internal/AesonUtils.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE TemplateHaskell #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE UndecidableSuperClasses #-}+#endif+module Data.Swagger.Internal.AesonUtils (+ -- * Generic functions+ AesonDefaultValue(..),+ sopSwaggerGenericToJSON,+#if MIN_VERSION_aeson(0,10,0)+ sopSwaggerGenericToEncoding,+#endif+ sopSwaggerGenericToJSONWithOpts,+ sopSwaggerGenericParseJSON,+ -- * Options+ HasSwaggerAesonOptions(..),+ SwaggerAesonOptions,+ mkSwaggerAesonOptions,+ saoPrefix,+ saoAdditionalPairs,+ saoSubObject,+ ) where++import Prelude ()+import Prelude.Compat++import Control.Applicative ((<|>))+import Control.Lens (makeLenses, (^.))+import Control.Monad (unless)+import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)+import Data.Aeson.Types (Parser, Pair)+import Data.Char (toLower, isUpper)+import Data.Foldable (traverse_)+import Data.Text (Text)++import Generics.SOP++import qualified Data.Text as T+import qualified Data.HashMap.Strict as HM+import qualified Data.Set as Set+import qualified Data.HashMap.Strict.InsOrd as InsOrd++#if MIN_VERSION_aeson(0,10,0)+import Data.Aeson (Encoding, pairs, (.=), Series)+import Data.Monoid ((<>))+#endif++-------------------------------------------------------------------------------+-- SwaggerAesonOptions+-------------------------------------------------------------------------------++data SwaggerAesonOptions = SwaggerAesonOptions+ { _saoPrefix :: String+ , _saoAdditionalPairs :: [(Text, Value)]+ , _saoSubObject :: Maybe String+ }++mkSwaggerAesonOptions+ :: String -- ^ prefix+ -> SwaggerAesonOptions+mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing++makeLenses ''SwaggerAesonOptions++class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where+ swaggerAesonOptions :: proxy a -> SwaggerAesonOptions++ -- So far we use only default definitions+ aesonDefaults :: proxy a -> POP Maybe (Code a)+ aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue++-------------------------------------------------------------------------------+-- Generics+-------------------------------------------------------------------------------++class AesonDefaultValue a where+ defaultValue :: Maybe a+ defaultValue = Nothing++instance AesonDefaultValue Text where defaultValue = Nothing+instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing+instance AesonDefaultValue [a] where defaultValue = Just []+instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty+instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty++-------------------------------------------------------------------------------+-- ToJSON+-------------------------------------------------------------------------------++-- | Generic serialisation for swagger records.+--+-- Features+--+-- * omits nulls, empty objects and empty arrays (configurable)+-- * possible to add fields+-- * possible to merge sub-object+sopSwaggerGenericToJSON+ :: forall a xs.+ ( Generic a+ , HasDatatypeInfo a+ , HasSwaggerAesonOptions a+ , All2 ToJSON (Code a)+ , All2 Eq (Code a)+ , Code a ~ '[xs]+ )+ => a+ -> Value+sopSwaggerGenericToJSON x =+ let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)+ in object (opts ^. saoAdditionalPairs ++ ps)+ where+ proxy = Proxy :: Proxy a+ opts = swaggerAesonOptions proxy++-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)+--+-- Also uses default `aesonDefaults`+sopSwaggerGenericToJSONWithOpts+ :: forall a xs.+ ( Generic a+ , All2 AesonDefaultValue (Code a)+ , HasDatatypeInfo a+ , All2 ToJSON (Code a)+ , All2 Eq (Code a)+ , Code a ~ '[xs]+ )+ => SwaggerAesonOptions+ -> a+ -> Value+sopSwaggerGenericToJSONWithOpts opts x =+ let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs+ in object (opts ^. saoAdditionalPairs ++ ps)+ where+ proxy = Proxy :: Proxy a+ defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue++sopSwaggerGenericToJSON'+ :: (All2 ToJSON '[xs], All2 Eq '[xs])+ => SwaggerAesonOptions+ -> SOP I '[xs]+ -> DatatypeInfo '[xs]+ -> POP Maybe '[xs]+ -> [Pair]+sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =+ sopSwaggerGenericToJSON'' opts fields fieldsInfo defs+sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"++sopSwaggerGenericToJSON''+ :: (All ToJSON xs, All Eq xs)+ => SwaggerAesonOptions+ -> NP I xs+ -> NP FieldInfo xs+ -> NP Maybe xs+ -> [Pair]+sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go+ where+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]+ go Nil Nil Nil = []+ go (I x :* xs) (FieldInfo name :* names) (def :* defs)+ | Just name' == sub = case json of+ Object m -> HM.toList m ++ rest+ Null -> rest+ _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json+ -- If default value: omit it.+ | Just x == def =+ rest+ | otherwise =+ (T.pack name', json) : rest+ where+ json = toJSON x+ name' = fieldNameModifier name+ rest = go xs names defs+#if __GLASGOW_HASKELL__ < 800+ go _ _ _ = error "not empty"+#endif++ fieldNameModifier = modifier . drop 1+ modifier = lowerFirstUppers . drop (length prefix)+ lowerFirstUppers s = map toLower x ++ y+ where (x, y) = span isUpper s++-------------------------------------------------------------------------------+-- FromJSON+-------------------------------------------------------------------------------++sopSwaggerGenericParseJSON+ :: forall a xs.+ ( Generic a+ , HasDatatypeInfo a+ , HasSwaggerAesonOptions a+ , All2 FromJSON (Code a)+ , All2 Eq (Code a)+ , Code a ~ '[xs]+ )+ => Value+ -> Parser a+sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->+ let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)+ in do+ traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs)+ to <$> ps+ where+ proxy = Proxy :: Proxy a+ opts = swaggerAesonOptions proxy++ parseAdditionalField :: Object -> (Text, Value) -> Parser ()+ parseAdditionalField obj (k, v) = do+ v' <- obj .: k+ unless (v == v') $ fail $+ "Additonal field don't match for key " ++ T.unpack k+ ++ ": " ++ show v+ ++ " /= " ++ show v'++sopSwaggerGenericParseJSON'+ :: (All2 FromJSON '[xs], All2 Eq '[xs])+ => SwaggerAesonOptions+ -> Object+ -> DatatypeInfo '[xs]+ -> POP Maybe '[xs]+ -> Parser (SOP I '[xs])+sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =+ SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs+sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"++sopSwaggerGenericParseJSON''+ :: (All FromJSON xs, All Eq xs)+ => SwaggerAesonOptions+ -> Object+ -> NP FieldInfo xs+ -> NP Maybe xs+ -> Parser (NP I xs)+sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go+ where+ go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)+ go Nil Nil = pure Nil+ go (FieldInfo name :* names) (def :* defs)+ | Just name' == sub =+ -- Note: we might strip fields of outer structure.+ cons <$> (withDef $ parseJSON $ Object obj) <*> rest+ | otherwise = case def of+ Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest+ Nothing -> cons <$> obj .: T.pack name' <*> rest+ where+ cons h t = I h :* t+ name' = fieldNameModifier name+ rest = go names defs++ withDef = case def of+ Just def' -> (<|> pure def')+ Nothing -> id+#if __GLASGOW_HASKELL__ < 800+ go _ _ = error "not empty"+#endif++ fieldNameModifier = modifier . drop 1+ modifier = lowerFirstUppers . drop (length prefix)+ lowerFirstUppers s = map toLower x ++ y+ where (x, y) = span isUpper s++-------------------------------------------------------------------------------+-- ToEncoding+-------------------------------------------------------------------------------++#if MIN_VERSION_aeson(0,10,0)++sopSwaggerGenericToEncoding+ :: forall a xs.+ ( Generic a+ , HasDatatypeInfo a+ , HasSwaggerAesonOptions a+ , All2 ToJSON (Code a)+ , All2 Eq (Code a)+ , Code a ~ '[xs]+ )+ => a+ -> Encoding+sopSwaggerGenericToEncoding x =+ let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)+ in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)+ where+ proxy = Proxy :: Proxy a+ opts = swaggerAesonOptions proxy++pairsToSeries :: [Pair] -> Series+pairsToSeries = foldMap (\(k, v) -> (k .= v))++sopSwaggerGenericToEncoding'+ :: (All2 ToJSON '[xs], All2 Eq '[xs])+ => SwaggerAesonOptions+ -> SOP I '[xs]+ -> DatatypeInfo '[xs]+ -> POP Maybe '[xs]+ -> Series+sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =+ sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs+sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"++sopSwaggerGenericToEncoding''+ :: (All ToJSON xs, All Eq xs)+ => SwaggerAesonOptions+ -> NP I xs+ -> NP FieldInfo xs+ -> NP Maybe xs+ -> Series+sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go+ where+ go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series+ go Nil Nil Nil = mempty+ go (I x :* xs) (FieldInfo name :* names) (def :* defs)+ | Just name' == sub = case toJSON x of+ Object m -> pairsToSeries (HM.toList m) <> rest+ Null -> rest+ _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)+ -- If default value: omit it.+ | Just x == def =+ rest+ | otherwise =+ (T.pack name' .= x) <> rest+ where+ name' = fieldNameModifier name+ rest = go xs names defs+#if __GLASGOW_HASKELL__ < 800+ go _ _ _ = error "not empty"+#endif++ fieldNameModifier = modifier . drop 1+ modifier = lowerFirstUppers . drop (length prefix)+ lowerFirstUppers s = map toLower x ++ y+ where (x, y) = span isUpper s++#endif
src/Data/Swagger/Internal/Schema.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-}@@ -25,6 +26,7 @@ import Control.Monad import Control.Monad.Writer import Data.Aeson+import qualified Data.Aeson.Types as Aeson import Data.Char import Data.Data (Data) import Data.Foldable (traverse_)@@ -33,6 +35,8 @@ import qualified Data.HashMap.Strict as HashMap import "unordered-containers" Data.HashSet (HashSet) import qualified "unordered-containers" Data.HashSet as HashSet+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Int import Data.IntSet (IntSet) import Data.IntMap (IntMap)@@ -88,15 +92,15 @@ -- data Coord = Coord { x :: Double, y :: Double } -- -- instance ToSchema Coord where--- declareNamedSchema = pure (Just \"Coord\", schema)--- where--- schema = mempty--- & type_ .~ SwaggerObject--- & properties .~--- [ (\"x\", toSchemaRef (Proxy :: Proxy Double))--- , (\"y\", toSchemaRef (Proxy :: Proxy Double))--- ]--- & required .~ [ \"x\", \"y\" ]+-- declareNamedSchema = do+-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)+-- return $ NamedSchema (Just \"Coord\")) $ mempty+-- & type_ .~ SwaggerObject+-- & properties .~+-- [ (\"x\", doubleSchema)+-- , (\"y\", doubleSchema)+-- ]+-- & required .~ [ \"x\", \"y\" ] -- @ -- -- Instead of manually writing your @'ToSchema'@ instance you can@@ -194,7 +198,7 @@ -- have already declared it. -- If we have, we don't need to declare anything for -- this schema this time and thus simply return the reference.- known <- looks (HashMap.member name)+ known <- looks (InsOrdHashMap.member name) when (not known) $ do declare [(name, schema)] void $ declareNamedSchema proxy@@ -213,7 +217,7 @@ where deref r@(Ref (Reference name)) | p name =- case HashMap.lookup name defs of+ case InsOrdHashMap.lookup name defs of Just schema -> Inline (inlineSchemasWhen p defs schema) Nothing -> r | otherwise = r@@ -255,7 +259,7 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs where nonRecursive name =- case HashMap.lookup name defs of+ case InsOrdHashMap.lookup name defs of Just schema -> name `notElem` execDeclare (usedNames schema) mempty Nothing -> False @@ -267,7 +271,7 @@ seen <- looks (name `elem`) when (not seen) $ do declare [name]- traverse_ usedNames (HashMap.lookup name defs)+ traverse_ usedNames (InsOrdHashMap.lookup name defs) Inline subschema -> usedNames subschema -- | Default schema for binary data (any sequence of octets).@@ -304,7 +308,7 @@ -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person -- >>> encode $ sketchSchema (Person "Jack" 25)--- "{\"example\":{\"age\":25,\"name\":\"Jack\"},\"required\":[\"age\",\"name\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}}}"+-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}" sketchSchema :: ToJSON a => a -> Schema sketchSchema = sketch . toJSON where@@ -331,7 +335,7 @@ go js@(Object o) = mempty & type_ .~ SwaggerObject & required .~ HashMap.keys o- & properties .~ fmap (Inline . go) o+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) -- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance. -- Produced schema uses as much constraints as possible.@@ -348,7 +352,7 @@ -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person -- >>> encode $ sketchStrictSchema (Person "Jack" 25)--- "{\"minProperties\":2,\"required\":[\"age\",\"name\"],\"maxProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}}}"+-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}},\"maxProperties\":2,\"minProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}]}" sketchStrictSchema :: ToJSON a => a -> Schema sketchStrictSchema = go . toJSON where@@ -381,7 +385,7 @@ go js@(Object o) = mempty & type_ .~ SwaggerObject & required .~ names- & properties .~ fmap (Inline . go) o+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) & maxProperties ?~ fromIntegral (length names) & minProperties ?~ fromIntegral (length names) & enum_ ?~ [js]@@ -564,8 +568,8 @@ instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where gdeclareNamedSchema opts _ schema = do- NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema- gdeclareNamedSchema opts (Proxy :: Proxy f) gschema+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema+ gdeclareNamedSchema opts (Proxy :: Proxy g) gschema instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s@@ -605,16 +609,16 @@ -- have already declared it. -- If we have, we don't need to declare anything for -- this schema this time and thus simply return the reference.- known <- looks (HashMap.member name)+ known <- looks (InsOrdHashMap.member name) when (not known) $ do declare [(name, schema)] void $ gdeclareNamedSchema opts proxy mempty return $ Ref (Reference name) _ -> Inline <$> gdeclareSchema opts proxy -appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)+appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema) appendItem x Nothing = Just (SwaggerItemsArray [x])-appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs))+appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x])) appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject" withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>@@ -630,7 +634,7 @@ & type_ .~ SwaggerObject & properties . at fname ?~ ref & if isRequiredField- then required %~ (fname :)+ then required %~ (++ [fname]) else id where fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))@@ -662,7 +666,7 @@ toStringTag schema = mempty & type_ .~ SwaggerString- & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)+ & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex) type AllNullary = All @@ -670,7 +674,7 @@ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where- gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g) gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) => Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
src/Data/Swagger/Internal/Schema/Validation.hs view
@@ -30,6 +30,8 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import qualified "unordered-containers" Data.HashSet as HashSet+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Monoid import Data.Proxy import Data.Scientific (Scientific, isInteger)@@ -174,7 +176,7 @@ -- | Validate value against a schema given schema reference and validation function. withRef :: Reference -> (Schema -> Validation s a) -> Validation s a withRef (Reference ref) f = withConfig $ \cfg ->- case HashMap.lookup ref (configDefinitions cfg) of+ case InsOrdHashMap.lookup ref (configDefinitions cfg) of Nothing -> invalid $ "unknown schema " ++ show ref Just s -> f s @@ -290,7 +292,7 @@ case v of Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property _ ->- case HashMap.lookup k (schema ^. properties) of+ case InsOrdHashMap.lookup k (schema ^. properties) of Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v Just s -> validateWithSchemaRef s v
src/Data/Swagger/Internal/Utils.hs view
@@ -9,8 +9,6 @@ import Prelude () import Prelude.Compat -import Control.Arrow (first)-import Control.Applicative import Control.Lens ((&), (%~)) import Control.Lens.TH import Data.Aeson@@ -20,13 +18,14 @@ import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Map (Map) import Data.Monoid import Data.Set (Set) import Data.Text (Text) import GHC.Generics import Language.Haskell.TH (mkName)-import Text.Read (readMaybe) swaggerFieldRules :: LensRules swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer@@ -53,17 +52,6 @@ Just x -> z x Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "." -hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v-hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList--hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)-hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList- where- g (x, y) = (\a -> (a, y)) <$> f x--hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)-hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)- jsonPrefix :: String -> Options jsonPrefix prefix = defaultOptions { fieldLabelModifier = modifier . drop 1@@ -85,40 +73,10 @@ where ys = zip (map toJSON xs) xs -omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value-omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o)- where- nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null)-omitEmptiesExcept _ js = js--omitEmpties :: Value -> Value-omitEmpties = omitEmptiesExcept (\_ _ -> False)--genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value-genericToJSONWithSub sub opts x =- case genericToJSON opts x of- Object o ->- 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 js@(Object o)- = genericParseJSON opts js -- try without subjson- <|> genericParseJSON opts js' -- try with subjson- where- js' = Object (HashMap.insert sub (Object o) o)-genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"- (<+>) :: Value -> Value -> Value Object x <+> Object y = Object (x <> y) _ <+> _ = error "<+>: merging non-objects" -withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a-withDefaults parser defs js@(Object _) = parser (js <+> object defs)-withDefaults _ _ _ = empty- genericMempty :: (Generic a, GMonoid (Rep a)) => a genericMempty = to gmempty @@ -161,6 +119,10 @@ swaggerMempty = mempty swaggerMappend = HashMap.unionWith (\_old new -> new) +instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where+ swaggerMempty = mempty+ swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)+ instance SwaggerMonoid Text where swaggerMempty = mempty swaggerMappend x "" = x@@ -170,4 +132,3 @@ swaggerMempty = Nothing swaggerMappend x Nothing = x swaggerMappend _ y = y-
src/Data/Swagger/Lens.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "overlapping-compat.h"@@ -59,14 +60,14 @@ -- ** 'SwaggerItems' prisms -_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema]+_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema] _SwaggerItemsArray = prism (\x -> SwaggerItemsArray x) $ \x -> case x of SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p) SwaggerItemsObject o -> Left (SwaggerItemsObject o) SwaggerItemsArray a -> Right a -_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema)+_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema) _SwaggerItemsObject = prism (\x -> SwaggerItemsObject x) $ \x -> case x of SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)@@ -91,13 +92,13 @@ instance Ixed Operation where ix n = responses . ix n instance At Operation where at n = responses . at n -instance HasParamSchema NamedSchema (ParamSchema Schema) where paramSchema = schema.paramSchema+instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema -- HasType instances-instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_-instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_-instance HasType NamedSchema (SwaggerType Schema) where type_ = paramSchema.type_-instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_+instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_+instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_+instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_+instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_ -- HasDefault instances instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
src/Data/Swagger/Operation.hs view
@@ -46,6 +46,9 @@ import Data.Swagger.Lens import Data.Swagger.Schema +import Data.HashMap.Strict.InsOrd (InsOrdHashMap)+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+ -- $setup -- >>> import Data.Aeson -- >>> import Data.Proxy@@ -58,10 +61,8 @@ -- >>> encode $ prependPath "user/{user_id}" api ^. paths -- "{\"/user/{user_id}/info\":{}}" prependPath :: FilePath -> Swagger -> Swagger-prependPath path = paths %~ mapKeys (path </>)+prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>) where- mapKeys f = HashMap.fromList . map (first f) . HashMap.toList- x </> y = case trim y of "" -> "/" <> trim x y' -> "/" <> trim x <> "/" <> y'@@ -80,15 +81,15 @@ -- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)] -- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)] -- >>> encode api--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" -- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" operationsOf :: Swagger -> Traversal' Swagger Operation operationsOf sub = paths.itraversed.withIndex.subops where -- | Traverse operations that correspond to paths and methods of the sub API. subops :: Traversal' (FilePath, PathItem) Operation- subops f (path, item) = case HashMap.lookup path (sub ^. paths) of+ subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of Just subitem -> (,) path <$> methodsOf subitem f item Nothing -> pure (path, item) @@ -119,7 +120,7 @@ -- necessary schema definitions. -- -- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty--- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]"+-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]" declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response declareResponse proxy = do s <- declareSchemaRef proxy@@ -139,7 +140,7 @@ -- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)] -- >>> let res = declareResponse (Proxy :: Proxy Day) -- >>> encode $ api & setResponse 200 res--- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}}}" -- -- See also @'setResponseWith'@. setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
swagger2.cabal view
@@ -1,5 +1,5 @@ name: swagger2-version: 2.0.2+version: 2.1 synopsis: Swagger 2.0 data model description: Please see README.md homepage: https://github.com/GetShopTV/swagger2@@ -17,7 +17,7 @@ , examples/*.hs , include/overlapping-compat.h cabal-version: >=1.10-tested-with: GHC==7.8.4, GHC==7.10.3+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1 library hs-source-dirs: src@@ -38,12 +38,15 @@ Data.Swagger.Internal.Schema.Validation Data.Swagger.Internal.ParamSchema Data.Swagger.Internal.Utils+ Data.Swagger.Internal.AesonUtils build-depends: base >=4.7 && <4.10 , base-compat >=0.6.0 && <0.10 , aeson , containers , hashable+ , generics-sop >=0.2 && <0.3 , http-media+ , insert-ordered-containers >=0.1.0.0 && <0.2 , lens , mtl , network@@ -60,13 +63,16 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs+ -- We need aeson's toEncoding for doctests too build-depends: base , base-compat- , aeson+ , aeson >=0.10.0.0 , aeson-qq+ , bytestring , containers , hashable , hspec+ , insert-ordered-containers , HUnit , mtl , QuickCheck
test/Data/Swagger/ParamSchemaSpec.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}@@ -11,12 +12,13 @@ import GHC.Generics import Data.Swagger+import Data.Swagger.Internal (SwaggerKind(..)) import SpecCommon import Test.Hspec checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec-checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema (SwaggerKindNormal Param)) <=> js spec :: Spec spec = do
test/Data/Swagger/SchemaSpec.hs view
@@ -7,10 +7,12 @@ import Prelude () import Prelude.Compat +import Control.Lens ((^.)) import Data.Aeson import Data.Aeson.QQ import Data.Char import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set@@ -34,10 +36,17 @@ checkDefs :: ToSchema a => Proxy a -> [String] -> Spec checkDefs proxy names = it ("uses these definitions " ++ show names) $- Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)+ InsOrdHashMap.keys defs `shouldBe` map Text.pack names where defs = execDeclare (declareNamedSchema proxy) mempty +checkProperties :: ToSchema a => Proxy a -> [String] -> Spec+checkProperties proxy names =+ it ("has these fields in order " ++ show names) $+ InsOrdHashMap.keys fields `shouldBe` map Text.pack names+ where+ fields = toSchema proxy ^. properties+ checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec checkInlinedSchema proxy js = toInlinedSchema proxy <=> js @@ -58,6 +67,9 @@ context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON+ context "Point5 (many field record)" $ do+ checkToSchema (Proxy :: Proxy Point5) point5SchemaJSON+ checkProperties (Proxy :: Proxy Point5) point5Properties context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON@@ -143,6 +155,7 @@ -- ======================================================================== -- Point (record data type with custom fieldLabelModifier) -- ========================================================================+ data Point = Point { pointX :: Double , pointY :: Double@@ -165,6 +178,40 @@ } |] +-- ========================================================================+-- Point (record data type with multiple fields)+-- ========================================================================++data Point5 = Point5+ { point5X :: Double+ , point5Y :: Double+ , point5Z :: Double+ , point5U :: Double+ , point5V :: Double -- 5 dimensional!+ } deriving (Generic)++instance ToSchema Point5 where+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+ { fieldLabelModifier = map toLower . drop (length "point5") }++point5SchemaJSON :: Value+point5SchemaJSON = [aesonQQ|+{+ "type": "object",+ "properties":+ {+ "x": { "type": "number", "format": "double" },+ "y": { "type": "number", "format": "double" },+ "z": { "type": "number", "format": "double" },+ "u": { "type": "number", "format": "double" },+ "v": { "type": "number", "format": "double" }+ },+ "required": ["x", "y", "z", "u", "v"]+}+|]++point5Properties :: [String]+point5Properties = ["x", "y", "z", "u", "v"] -- ======================================================================== -- Color (enum)
test/SpecCommon.hs view
@@ -1,6 +1,7 @@ module SpecCommon where import Data.Aeson+import Data.ByteString.Builder (toLazyByteString) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HashMap import qualified Data.Vector as Vector@@ -21,5 +22,9 @@ toJSON x `shouldBe` js it "decodes correctly" $ do fromJSON js `shouldBe` Success x--+ it "roundtrips: eitherDecode . encode" $ do+ eitherDecode (encode x) `shouldBe` Right x+ it "roundtrips with toJSON" $ do+ eitherDecode (encode $ toJSON x) `shouldBe` Right x+ it "roundtrips with toEncoding" $ do+ eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x