From 821654cd65e88ab93e3f8c9268f5bbb4a81d8bc7 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Tue, 23 Jun 2020 22:01:50 +0300 Subject: [PATCH 01/25] Migrate toplevel schema to openapi3 --- src/Data/Swagger.hs | 5 + src/Data/Swagger/Internal.hs | 290 ++++++++++++++++++++++++----------- 2 files changed, 204 insertions(+), 91 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 2ea7facb..b06443ec 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -40,6 +40,9 @@ module Data.Swagger ( Swagger(..), Host(..), Scheme(..), + Server(..), + ServerVariable(..), + Components(..), -- ** Info types Info(..), @@ -69,6 +72,8 @@ module Data.Swagger ( Header(..), HeaderName, Example(..), + RequestBody(..), + MediaTypeObject(..), -- ** Schemas ParamSchema(..), diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index aba43653..1fce6fde 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -68,56 +68,28 @@ data Swagger = Swagger -- The metadata can be used by the clients if needed. _swaggerInfo :: Info - -- | The host (name or ip) serving the API. It MAY include a port. - -- If the host is not included, the host serving the documentation is to be used (including the port). - , _swaggerHost :: Maybe Host - - -- | The base path on which the API is served, which is relative to the host. - -- If it is not included, the API is served directly under the host. - -- The value MUST start with a leading slash (/). - , _swaggerBasePath :: Maybe FilePath - - -- | The transfer protocol of the API. - -- If the schemes is not included, the default scheme to be used is the one used to access the Swagger definition itself. - , _swaggerSchemes :: Maybe [Scheme] - - -- | A list of MIME types the APIs can consume. - -- This is global to all APIs but can be overridden on specific API calls. - , _swaggerConsumes :: MimeList - - -- | A list of MIME types the APIs can produce. - -- This is global to all APIs but can be overridden on specific API calls. - , _swaggerProduces :: MimeList + -- | An array of Server Objects, which provide connectivity information + -- to a target server. If the servers property is not provided, or is an empty array, + -- the default value would be a 'Server' object with a url value of @/@. + , _swaggerServers :: [Server] -- | 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 :: InsOrdHashMap FilePath PathItem - -- | An object to hold data types produced and consumed by operations. - , _swaggerDefinitions :: Definitions Schema + -- | An element to hold various schemas for the specification. + , _swaggerComponents :: Components - -- | An object to hold parameters that can be used across operations. - -- This property does not define global parameters for all operations. - , _swaggerParameters :: Definitions Param - - -- | An object to hold responses that can be used across operations. - -- This property does not define global responses for all operations. - , _swaggerResponses :: Definitions Response - - -- | Security scheme definitions that can be used across the specification. - , _swaggerSecurityDefinitions :: SecurityDefinitions - - -- | A declaration of which security schemes are applied for the API as a whole. - -- The list of values describes alternative security schemes that can be used - -- (that is, there is a logical OR between the security requirements). + -- | A declaration of which security mechanisms can be used across the API. + -- The list of values includes alternative security requirement objects that can be used. + -- Only one of the security requirement objects need to be satisfied to authorize a request. -- Individual operations can override this definition. + -- To make security optional, an empty security requirement can be included in the array. , _swaggerSecurity :: [SecurityRequirement] -- | A list of tags used by the specification with additional metadata. -- The order of the tags can be used to reflect on their order by the parsing tools. - -- Not all tags that are used by the Operation Object must be declared. - -- The tags that are not declared may be organized randomly or based on the tools' logic. + -- Not all tags that are used by the 'Operation' Object must be declared. + -- The tags that are not declared MAY be organized randomly or based on the tools' logic. -- Each tag name in the list MUST be unique. , _swaggerTags :: InsOrdHashSet Tag @@ -126,17 +98,17 @@ data Swagger = Swagger } deriving (Eq, Show, Generic, Data, Typeable) -- | The object provides metadata about the API. --- The metadata can be used by the clients if needed, --- and can be presented in the Swagger-UI for convenience. +-- The metadata MAY be used by the clients if needed, +-- and MAY be presented in editing or documentation generation tools for convenience. data Info = Info - { -- | The title of the application. + { -- | The title of the API. _infoTitle :: Text - -- | A short description of the application. - -- GFM syntax can be used for rich text representation. + -- | A short description of the API. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. , _infoDescription :: Maybe Text - -- | The Terms of Service for the API. + -- | A URL to the Terms of Service for the API. MUST be in the format of a URL. , _infoTermsOfService :: Maybe Text -- | The contact information for the exposed API. @@ -145,8 +117,8 @@ data Info = Info -- | The license information for the exposed API. , _infoLicense :: Maybe License - -- | Provides the version of the application API - -- (not to be confused with the specification version). + -- | The version of the OpenAPI document (which is distinct from the + -- OpenAPI Specification version or the API implementation version). , _infoVersion :: Text } deriving (Eq, Show, Generic, Data, Typeable) @@ -174,6 +146,54 @@ data License = License instance IsString License where fromString s = License (fromString s) Nothing +-- | An object representing a Server. +data Server = Server + { -- | A URL to the target host. This URL supports Server Variables and MAY be relative, + -- to indicate that the host location is relative to the location where + -- the OpenAPI document is being served. Variable substitutions will be made when + -- a variable is named in @{brackets}@. + _serverUrl :: Text + + -- | An optional string describing the host designated by the URL. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. + , _serverDescription :: Maybe Text + + -- | A map between a variable name and its value. + -- The value is used for substitution in the server's URL template. + , _serverVariables :: InsOrdHashMap Text ServerVariable + } deriving (Eq, Show, Generic, Data, Typeable) + +data ServerVariable = ServerVariable + { -- | An enumeration of string values to be used if the substitution options + -- are from a limited set. The array SHOULD NOT be empty. + _serverVariableEnum :: Maybe (InsOrdHashSet Text) -- TODO NonEmpty + + -- | The default value to use for substitution, which SHALL be sent if an alternate value + -- is not supplied. Note this behavior is different than the 'Schema\ Object's treatment + -- of default values, because in those cases parameter values are optional. + -- If the '_serverVariableEnum' is defined, the value SHOULD exist in the enum's values. + , _serverVariableDefault :: Text + + -- | An optional description for the server variable. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. + , _serverVariableDescription :: Maybe Text + } deriving (Eq, Show, Generic, Data, Typeable) + +-- | Holds a set of reusable objects for different aspects of the OAS. +-- All objects defined within the components object will have no effect on the API +-- unless they are explicitly referenced from properties outside the components object. +data Components = Components + { _componentsSchemas :: Definitions Schema -- TODO check Schema itself + , _componentsResponses :: Definitions Response + , _componentsParameters :: Definitions Param +-- , _componentsExamples + , _componentsRequestBodies :: Definitions RequestBody + , _componentsHeader :: Definitions Header + , _componentsSecuritySchemes :: Definitions SecurityScheme +-- , _componentsLinks +-- , _componentsCallbacks + } deriving (Eq, Show, Generic, Data, Typeable) + -- | The host (name or ip) serving the API. It MAY include a port. data Host = Host { _hostName :: HostName -- ^ Host name. @@ -209,8 +229,15 @@ data Scheme -- The path itself is still exposed to the documentation viewer -- but they will not know which operations and parameters are available. data PathItem = PathItem - { -- | A definition of a GET operation on this path. - _pathItemGet :: Maybe Operation + { -- | An optional, string summary, intended to apply to all operations in this path. + _pathItemSummary :: Maybe Text + + -- | An optional, string description, intended to apply to all operations in this path. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. + , _pathItemDescription :: Maybe Text + + -- | A definition of a GET operation on this path. + , _pathItemGet :: Maybe Operation -- | A definition of a PUT operation on this path. , _pathItemPut :: Maybe Operation @@ -230,6 +257,12 @@ data PathItem = PathItem -- | A definition of a PATCH operation on this path. , _pathItemPatch :: Maybe Operation + -- | A definition of a TRACE operation on this path. + , _pathItemTrace :: Maybe Operation + + -- | An alternative server array to service all operations in this path. + , _pathItemServers :: [Server] + -- | A list of parameters that are applicable for all the operations described under this path. -- These parameters can be overridden at the operation level, but cannot be removed there. -- The list MUST NOT include duplicated parameters. @@ -248,7 +281,7 @@ data Operation = Operation , _operationSummary :: Maybe Text -- | A verbose explanation of the operation behavior. - -- GFM syntax can be used for rich text representation. + -- [CommonMark syntax](https://spec.commonmark.org/) can be used for rich text representation. , _operationDescription :: Maybe Text -- | Additional external documentation for this operation. @@ -256,20 +289,11 @@ data Operation = Operation -- | Unique string used to identify the operation. -- The id MUST be unique among all operations described in the API. - -- Tools and libraries MAY use the it to uniquely identify an operation, - -- therefore, it is recommended to follow common programming naming conventions. + -- The operationId value is **case-sensitive**. + -- Tools and libraries MAY use the operationId to uniquely identify an operation, therefore, + -- it is RECOMMENDED to follow common programming naming conventions. , _operationOperationId :: Maybe Text - -- | A list of MIME types the operation can consume. - -- This overrides the @'consumes'@. - -- @Just []@ MAY be used to clear the global definition. - , _operationConsumes :: Maybe MimeList - - -- | A list of MIME types the operation can produce. - -- This overrides the @'produces'@. - -- @Just []@ MAY be used to clear the global definition. - , _operationProduces :: Maybe MimeList - -- | A list of parameters that are applicable for this operation. -- If a parameter is already defined at the @'PathItem'@, -- the new definition will override it, but can never remove it. @@ -277,12 +301,17 @@ data Operation = Operation -- A unique parameter is defined by a combination of a name and location. , _operationParameters :: [Referenced Param] + -- | The request body applicable for this operation. + -- The requestBody is only supported in HTTP methods where the HTTP 1.1 + -- specification [RFC7231](https://tools.ietf.org/html/rfc7231#section-4.3.1) + -- has explicitly defined semantics for request bodies. + -- In other cases where the HTTP spec is vague, requestBody SHALL be ignored by consumers. + , _operationRequestBody :: Maybe (Referenced RequestBody) + -- | The list of possible responses as they are returned from executing this operation. , _operationResponses :: Responses - -- | The transfer protocol for the operation. - -- The value overrides @'schemes'@. - , _operationSchemes :: Maybe [Scheme] + -- TODO callbacks -- | Declares this operation to be deprecated. -- Usage of the declared operation should be refrained. @@ -295,6 +324,37 @@ data Operation = Operation -- This definition overrides any declared top-level security. -- To remove a top-level security declaration, @Just []@ can be used. , _operationSecurity :: [SecurityRequirement] + + -- | An alternative server array to service this operation. + -- If an alternative server object is specified at the 'PathItem' Object or Root level, + -- it will be overridden by this value. + , _operationServers :: [Server] + } deriving (Eq, Show, Generic, Data, Typeable) + +-- | Describes a single request body. +data RequestBody = RequestBody + { -- | A brief description of the request body. This could contain examples of use. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. + _requestBodyDescription :: Maybe Text + + -- | The content of the request body. + -- The key is a media type or media type range and the value describes it. + -- For requests that match multiple keys, only the most specific key is applicable. + -- e.g. @text/plain@ overrides @text/*@ + , _requestBodyContent :: InsOrdHashMap {-MediaType-} Text MediaTypeObject -- FIXME Data MediaType + + , _requestBodyRequired :: Maybe Bool + } deriving (Eq, Show, Generic, Data, Typeable) + +-- | Each Media Type Object provides schema and examples for the media type identified by its key. +data MediaTypeObject = MediaTypeObject + { _mediaTypeSchema :: Maybe (Referenced Schema) + +-- TODO +-- , _mediaTypeExample +-- , _mediaTypeExamples + +-- , _mediaTypeEncoding :: InsOrdHashMap Text Encoding } deriving (Eq, Show, Generic, Data, Typeable) newtype MimeList = MimeList { getMimeList :: [MediaType] } @@ -494,14 +554,8 @@ data ParamLocation -- This does not include the host or base path of the API. -- For example, in @/items/{itemId}@, the path parameter is @itemId@. | ParamPath - -- | Used to describe the payload of an HTTP request when either @application/x-www-form-urlencoded@ - -- or @multipart/form-data@ are used as the content type of the request - -- (in Swagger's definition, the @consumes@ property of an operation). - -- This is the only parameter type that can be used to send files, thus supporting the @'ParamFile'@ type. - -- Since form parameters are sent in the payload, they cannot be declared together with a body parameter for the same operation. - -- Form parameters have a different format based on the content-type used - -- (for further details, consult ). - | ParamFormData + -- | Used to pass a specific cookie value to the API. + | ParamCookie deriving (Eq, Show, Generic, Data, Typeable) type Format = Text @@ -650,25 +704,23 @@ type HttpStatusCode = Int -- | Describes a single response from an API Operation. data Response = Response { -- | A short description of the response. - -- GFM syntax can be used for rich text representation. + -- [CommonMark syntax](https://spec.commonmark.org/) can be used for rich text representation. _responseDescription :: Text - -- | A definition of the response structure. - -- It can be a primitive, an array or an object. - -- If this field does not exist, it means no content is returned as part of the response. - -- As an extension to the Schema Object, its root type value may also be "file". - -- This SHOULD be accompanied by a relevant produces mime-type. - , _responseSchema :: Maybe (Referenced Schema) + -- | A map containing descriptions of potential response payloads. + -- The key is a media type or media type range and the value describes it. + -- For responses that match multiple keys, only the most specific key is applicable. + -- e.g. @text/plain@ overrides @text/*@. + , _responseContent :: InsOrdHashMap Text MediaTypeObject - -- | A list of headers that are sent with the response. - , _responseHeaders :: InsOrdHashMap HeaderName Header + -- | Maps a header name to its definition. + , _responseHeaders :: InsOrdHashMap HeaderName Header -- FIXME Referenced - -- | An example of the response message. - , _responseExamples :: Maybe Example + -- TODO links } deriving (Eq, Show, Generic, Data, Typeable) instance IsString Response where - fromString s = Response (fromString s) Nothing mempty Nothing + fromString s = Response (fromString s) mempty mempty type HeaderName = Text @@ -699,6 +751,7 @@ instance Data Example where data ApiKeyLocation = ApiKeyQuery | ApiKeyHeader + | ApiKeyCookie deriving (Eq, Show, Generic, Data, Typeable) data ApiKeyParams = ApiKeyParams @@ -731,9 +784,10 @@ data OAuth2Params = OAuth2Params } deriving (Eq, Show, Generic, Data, Typeable) data SecuritySchemeType - = SecuritySchemeBasic + = SecuritySchemeHttp | SecuritySchemeApiKey ApiKeyParams | SecuritySchemeOAuth2 OAuth2Params +-- | SecuritySchemeOpenIdConnect -- FIXME deriving (Eq, Show, Generic, Data, Typeable) data SecurityScheme = SecurityScheme @@ -825,6 +879,7 @@ data AdditionalProperties -- Generic instances ------------------------------------------------------------------------------- +deriveGeneric ''Components deriveGeneric ''Header deriveGeneric ''OAuth2Params deriveGeneric ''Operation @@ -832,6 +887,8 @@ deriveGeneric ''Param deriveGeneric ''ParamOtherSchema deriveGeneric ''PathItem deriveGeneric ''Response +deriveGeneric ''RequestBody +deriveGeneric ''MediaTypeObject deriveGeneric ''Responses deriveGeneric ''SecurityScheme deriveGeneric ''Schema @@ -860,6 +917,12 @@ instance Monoid Contact where mempty = genericMempty mappend = (<>) +instance Semigroup Components where + (<>) = genericMappend +instance Monoid Components where + mempty = genericMempty + mappend = (<>) + instance Semigroup PathItem where (<>) = genericMappend instance Monoid PathItem where @@ -942,6 +1005,7 @@ instance Monoid SecurityDefinitions where -- ======================================================================= instance SwaggerMonoid Info +instance SwaggerMonoid Components instance SwaggerMonoid PathItem instance SwaggerMonoid Schema instance SwaggerMonoid (ParamSchema t) @@ -996,6 +1060,12 @@ instance ToJSON Contact where instance ToJSON License where toJSON = genericToJSON (jsonPrefix "License") +instance ToJSON Server where + toJSON = genericToJSON (jsonPrefix "Server") + +instance ToJSON ServerVariable where + toJSON = genericToJSON (jsonPrefix "ServerVariable") + instance ToJSON ApiKeyLocation where toJSON = genericToJSON (jsonPrefix "ApiKey") @@ -1030,6 +1100,12 @@ instance FromJSON Contact where instance FromJSON License where parseJSON = genericParseJSON (jsonPrefix "License") +instance FromJSON Server where + parseJSON = genericParseJSON (jsonPrefix "Server") + +instance FromJSON ServerVariable where + parseJSON = genericParseJSON (jsonPrefix "ServerVariable") + instance FromJSON ApiKeyLocation where parseJSON = genericParseJSON (jsonPrefix "ApiKey") @@ -1069,8 +1145,8 @@ instance ToJSON OAuth2Params where toEncoding = sopSwaggerGenericToEncoding instance ToJSON SecuritySchemeType where - toJSON SecuritySchemeBasic - = object [ "type" .= ("basic" :: Text) ] + toJSON SecuritySchemeHttp + = object [ "type" .= ("http" :: Text) ] toJSON (SecuritySchemeApiKey params) = toJSON params <+> object [ "type" .= ("apiKey" :: Text) ] @@ -1115,6 +1191,10 @@ instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where ] toJSON (SwaggerItemsArray x) = object [ "items" .= x ] +instance ToJSON Components where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON Host where toJSON (Host host mport) = toJSON $ case mport of @@ -1152,6 +1232,14 @@ instance ToJSON PathItem where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON RequestBody where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON MediaTypeObject where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON Example where toJSON = toJSON . Map.mapKeys show . getExample @@ -1165,9 +1253,11 @@ referencedToJSON :: ToJSON a => Text -> Referenced a -> Value referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ] referencedToJSON _ (Inline x) = toJSON x +-- FIXME this stuff instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/definitions/" instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/parameters/" instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/responses/" +instance ToJSON (Referenced RequestBody) where toJSON = referencedToJSON "#/!!!!/" instance ToJSON (SwaggerType t) where toJSON SwaggerArray = "array" @@ -1219,7 +1309,7 @@ instance FromJSON SecuritySchemeType where parseJSON js@(Object o) = do (t :: Text) <- o .: "type" case t of - "basic" -> pure SecuritySchemeBasic + "http" -> pure SecuritySchemeHttp "apiKey" -> SecuritySchemeApiKey <$> parseJSON js "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js _ -> empty @@ -1271,6 +1361,9 @@ instance FromJSON (SwaggerItems 'SwaggerKindSchema) where parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js parseJSON _ = empty +instance FromJSON Components where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON Host where parseJSON (String s) = case map Text.unpack $ Text.split (== ':') s of [host] -> return $ Host host Nothing @@ -1319,6 +1412,12 @@ instance FromJSON Operation where instance FromJSON PathItem where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON RequestBody where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON MediaTypeObject where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON SecurityDefinitions where parseJSON js = SecurityDefinitions <$> parseJSON js @@ -1339,9 +1438,11 @@ referencedParseJSON prefix js@(Object o) = do Just suffix -> pure (Reference suffix) referencedParseJSON _ _ = fail "referenceParseJSON: not an object" +-- FIXME this stuff instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/definitions/" instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/parameters/" instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/responses/" +instance FromJSON (Referenced RequestBody) where parseJSON = referencedParseJSON "#/!!!!/" instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") @@ -1376,6 +1477,8 @@ instance FromJSON AdditionalProperties where parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b parseJSON js = AdditionalPropertiesSchema <$> parseJSON js +instance HasSwaggerAesonOptions Components where + swaggerAesonOptions _ = mkSwaggerAesonOptions "components" instance HasSwaggerAesonOptions Header where swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema" instance HasSwaggerAesonOptions OAuth2Params where @@ -1390,6 +1493,10 @@ instance HasSwaggerAesonOptions PathItem where swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" instance HasSwaggerAesonOptions Response where swaggerAesonOptions _ = mkSwaggerAesonOptions "response" +instance HasSwaggerAesonOptions RequestBody where + swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody" +instance HasSwaggerAesonOptions MediaTypeObject where + swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaType" instance HasSwaggerAesonOptions Responses where swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses" instance HasSwaggerAesonOptions SecurityScheme where @@ -1397,7 +1504,7 @@ instance HasSwaggerAesonOptions SecurityScheme where instance HasSwaggerAesonOptions Schema where swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" instance HasSwaggerAesonOptions Swagger where - swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")] + swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0")] instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" @@ -1407,6 +1514,7 @@ instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" +instance AesonDefaultValue Components instance AesonDefaultValue (ParamSchema s) instance AesonDefaultValue OAuth2Flow instance AesonDefaultValue Responses From 6ac35404f7c00a3801115761fdf8b46068959cc2 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Tue, 23 Jun 2020 22:16:57 +0300 Subject: [PATCH 02/25] Extend Schema --- src/Data/Swagger/Internal.hs | 8 ++++++-- src/Data/Swagger/Internal/Utils.hs | 1 + src/Data/Swagger/Lens.hs | 2 +- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 1fce6fde..e786ea14 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -183,7 +183,7 @@ data ServerVariable = ServerVariable -- All objects defined within the components object will have no effect on the API -- unless they are explicitly referenced from properties outside the components object. data Components = Components - { _componentsSchemas :: Definitions Schema -- TODO check Schema itself + { _componentsSchemas :: Definitions Schema , _componentsResponses :: Definitions Response , _componentsParameters :: Definitions Param -- , _componentsExamples @@ -603,11 +603,15 @@ data Schema = Schema , _schemaDescription :: Maybe Text , _schemaRequired :: [ParamName] + , _schemaNullable :: Maybe Bool , _schemaAllOf :: Maybe [Referenced Schema] + , _schemaOneOf :: Maybe [Referenced Schema] + , _schemaNot :: Maybe (Referenced Schema) + , _schemaAnyOf :: Maybe [Referenced Schema] , _schemaProperties :: InsOrdHashMap Text (Referenced Schema) , _schemaAdditionalProperties :: Maybe AdditionalProperties - , _schemaDiscriminator :: Maybe Text + , _schemaDiscriminator :: Maybe Text -- FIXME Discriminator object , _schemaReadOnly :: Maybe Bool , _schemaXml :: Maybe Xml , _schemaExternalDocs :: Maybe ExternalDocs diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs index ca91d7b7..1a2eff21 100644 --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -44,6 +44,7 @@ swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer fixName' "maximum" = "maximum_" -- Prelude conflict fixName' "enum" = "enum_" -- Control.Lens conflict fixName' "head" = "head_" -- Prelude conflict + fixName' "not" = "not_" -- Prelude conflict fixName' n = n gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index 6e859e89..1eaef2c0 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -37,7 +37,7 @@ makeFields ''Operation makeFields ''Param makeLensesWith swaggerFieldRules ''ParamOtherSchema makeFields ''Header -makeFields ''Schema +makeLensesWith swaggerFieldRules ''Schema makeFields ''NamedSchema makeLensesWith swaggerFieldRules ''ParamSchema makeFields ''Xml From c253c9f7e5f01317279df5757dc4f93d6787e89c Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Tue, 23 Jun 2020 22:48:42 +0300 Subject: [PATCH 03/25] Set version to 3.0.3 --- src/Data/Swagger/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index e786ea14..9d93575d 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -1508,7 +1508,7 @@ instance HasSwaggerAesonOptions SecurityScheme where instance HasSwaggerAesonOptions Schema where swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" instance HasSwaggerAesonOptions Swagger where - swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0")] + swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.3")] instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" From 6dc3170150a3c9311fa0387b1212d7f412712226 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Tue, 23 Jun 2020 22:50:00 +0300 Subject: [PATCH 04/25] Fix ref paths for components --- src/Data/Swagger/Internal.hs | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 9d93575d..aac399aa 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -1257,11 +1257,10 @@ referencedToJSON :: ToJSON a => Text -> Referenced a -> Value referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ] referencedToJSON _ (Inline x) = toJSON x --- FIXME this stuff -instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/definitions/" -instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/parameters/" -instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/responses/" -instance ToJSON (Referenced RequestBody) where toJSON = referencedToJSON "#/!!!!/" +instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/components/schemas/" +instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/components/parameters/" +instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/components/responses/" +instance ToJSON (Referenced RequestBody) where toJSON = referencedToJSON "#/components/requestBodies/" instance ToJSON (SwaggerType t) where toJSON SwaggerArray = "array" @@ -1442,11 +1441,10 @@ referencedParseJSON prefix js@(Object o) = do Just suffix -> pure (Reference suffix) referencedParseJSON _ _ = fail "referenceParseJSON: not an object" --- FIXME this stuff -instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/definitions/" -instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/parameters/" -instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/responses/" -instance FromJSON (Referenced RequestBody) where parseJSON = referencedParseJSON "#/!!!!/" +instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/components/schemas/" +instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/components/parameters/" +instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/components/responses/" +instance FromJSON (Referenced RequestBody) where parseJSON = referencedParseJSON "#/components/requestBodies" instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") From 08444f28e425496952c904b79fe4214c8a2e87b8 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Tue, 23 Jun 2020 22:50:24 +0300 Subject: [PATCH 05/25] Add lenses for new types --- src/Data/Swagger/Internal.hs | 10 ++++++++-- src/Data/Swagger/Lens.hs | 4 ++++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index aac399aa..fe8dfe87 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -348,7 +348,7 @@ data RequestBody = RequestBody -- | Each Media Type Object provides schema and examples for the media type identified by its key. data MediaTypeObject = MediaTypeObject - { _mediaTypeSchema :: Maybe (Referenced Schema) + { _mediaTypeObjectSchema :: Maybe (Referenced Schema) -- TODO -- , _mediaTypeExample @@ -975,6 +975,12 @@ instance Monoid Response where mempty = genericMempty mappend = (<>) +instance Semigroup MediaTypeObject where + (<>) = genericMappend +instance Monoid MediaTypeObject where + mempty = genericMempty + mappend = (<>) + instance Semigroup ExternalDocs where (<>) = genericMappend instance Monoid ExternalDocs where @@ -1498,7 +1504,7 @@ instance HasSwaggerAesonOptions Response where instance HasSwaggerAesonOptions RequestBody where swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody" instance HasSwaggerAesonOptions MediaTypeObject where - swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaType" + swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaTypeObject" instance HasSwaggerAesonOptions Responses where swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses" instance HasSwaggerAesonOptions SecurityScheme where diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index 1eaef2c0..6b5afdf9 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -27,6 +27,10 @@ import Data.Text (Text) -- * Classy lenses makeFields ''Swagger +makeFields ''Components +makeFields ''Server +makeFields ''RequestBody +makeFields ''MediaTypeObject makeFields ''Host makeFields ''Info makeFields ''Contact From eadb30ae61639ad08eb5a604e45d6ac9b99ebe25 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Tue, 23 Jun 2020 22:50:39 +0300 Subject: [PATCH 06/25] Update Operations.hs --- src/Data/Swagger/Operation.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Data/Swagger/Operation.hs b/src/Data/Swagger/Operation.hs index 607dc992..c4f2c0bc 100644 --- a/src/Data/Swagger/Operation.hs +++ b/src/Data/Swagger/Operation.hs @@ -39,6 +39,7 @@ import Data.List.Compat import Data.Maybe (mapMaybe) import Data.Proxy import qualified Data.Set as Set +import Data.Text (Text) import Data.Swagger.Declare import Data.Swagger.Internal @@ -118,12 +119,14 @@ applyTagsFor ops ts swag = swag -- | Construct a response with @'Schema'@ while declaring all -- necessary schema definitions. -- +-- FIXME doc +-- -- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty -- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]" -declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response -declareResponse proxy = do +declareResponse :: ToSchema a => Text -> Proxy a -> Declare (Definitions Schema) Response +declareResponse cType proxy = do s <- declareSchemaRef proxy - return (mempty & schema ?~ s) + return (mempty & content.at cType ?~ (mempty & schema ?~ s)) -- | Set response for all operations. -- This will also update global schema definitions. @@ -167,7 +170,7 @@ setResponseWith = setResponseForWith allOperations -- See also @'setResponseForWith'@. setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger setResponseFor ops code dres swag = swag - & definitions %~ (<> defs) + & components.schemas %~ (<> defs) & ops . at code ?~ Inline res where (defs, res) = runDeclare dres mempty @@ -181,12 +184,12 @@ setResponseFor ops code dres swag = swag -- See also @'setResponseFor'@. setResponseForWith :: Traversal' Swagger Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger setResponseForWith ops f code dres swag = swag - & definitions %~ (<> defs) + & components.schemas %~ (<> defs) & ops . at code %~ Just . Inline . combine where (defs, new) = runDeclare dres mempty - combine (Just (Ref (Reference n))) = case swag ^. responses.at n of + combine (Just (Ref (Reference n))) = case swag ^. components.responses.at n of Just old -> f old new Nothing -> new -- response name can't be dereferenced, replacing with new response combine (Just (Inline old)) = f old new From 59023105338a39610347a01441f6fa2e1febdb1f Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Fri, 26 Jun 2020 10:55:28 +0300 Subject: [PATCH 07/25] Add Example --- src/Data/Swagger.hs | 1 + src/Data/Swagger/Internal.hs | 138 ++++++++++++++++++++++++++--------- 2 files changed, 106 insertions(+), 33 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index b06443ec..cfe46d53 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -74,6 +74,7 @@ module Data.Swagger ( Example(..), RequestBody(..), MediaTypeObject(..), + Encoding(..), -- ** Schemas ParamSchema(..), diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index fe8dfe87..b9ac9d17 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -21,7 +21,7 @@ import Prelude.Compat import Control.Lens ((&), (.~), (?~)) import Control.Applicative -import Data.Aeson +import Data.Aeson hiding (Encoding) import qualified Data.Aeson.Types as JSON import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex) import Data.Hashable (Hashable) @@ -186,7 +186,7 @@ data Components = Components { _componentsSchemas :: Definitions Schema , _componentsResponses :: Definitions Response , _componentsParameters :: Definitions Param --- , _componentsExamples + , _componentsExamples :: Definitions Example , _componentsRequestBodies :: Definitions RequestBody , _componentsHeader :: Definitions Header , _componentsSecuritySchemes :: Definitions SecurityScheme @@ -350,11 +350,59 @@ data RequestBody = RequestBody data MediaTypeObject = MediaTypeObject { _mediaTypeObjectSchema :: Maybe (Referenced Schema) --- TODO --- , _mediaTypeExample --- , _mediaTypeExamples + -- | Example of the media type. + -- The example object SHOULD be in the correct format as specified by the media type. + , _mediaTypeObjectExample :: Maybe Value --- , _mediaTypeEncoding :: InsOrdHashMap Text Encoding + -- | Examples of the media type. + -- Each example object SHOULD match the media type and specified schema if present. + , _mediaTypeObjectExamples :: InsOrdHashMap Text (Referenced Example) + + -- | A map between a property name and its encoding information. + -- The key, being the property name, MUST exist in the schema as a property. + -- The encoding object SHALL only apply to 'RequestBody' objects when the media type + -- is @multipart@ or @application/x-www-form-urlencoded@. + , _mediaTypeObjectEncoding :: InsOrdHashMap Text Encoding + } deriving (Eq, Show, Generic, Data, Typeable) + +data Encoding = Encoding + { -- | The Content-Type for encoding a specific property. + -- Default value depends on the property type: for @string@ + -- with format being @binary@ – @application/octet-stream@; + -- for other primitive types – @text/plain@; for object - @application/json@; + -- for array – the default is defined based on the inner type. + -- The value can be a specific media type (e.g. @application/json@), + -- a wildcard media type (e.g. @image/*@), or a comma-separated list of the two types. + _encodingContentType :: Maybe Text + + -- | A map allowing additional information to be provided as headers, + -- for example @Content-Disposition@. @Content-Type@ is described separately + -- and SHALL be ignored in this section. + -- This property SHALL be ignored if the request body media type is not a @multipart@. + , _encodingHeaders :: InsOrdHashMap Text (Referenced Header) + + -- | Describes how a specific property value will be serialized depending on its type. + -- See Parameter Object for details on the style property. + -- The behavior follows the same values as query parameters, including default values. + -- This property SHALL be ignored if the request body media type + -- is not @application/x-www-form-urlencoded@. + , _encodingStyle :: Maybe Text -- TODO enum + + -- | When this is true, property values of type @array@ or @object@ generate + -- separate parameters for each value of the array, + -- or key-value-pair of the map. + -- For other types of properties this property has no effect. + -- When style is form, the default value is @true@. For all other styles, + -- the default value is @false@. This property SHALL be ignored + -- if the request body media type is not @application/x-www-form-urlencoded@. + , _encodingExplode :: Maybe Bool + + -- | Determines whether the parameter value SHOULD allow reserved characters, + -- as defined by [RFC3986](https://tools.ietf.org/html/rfc3986#section-2.2) + -- @:/?#[]@!$&'()*+,;=@ to be included without percent-encoding. + -- The default value is @false@. This property SHALL be ignored if the request body media type + -- is not @application/x-www-form-urlencoded@. + , _encodingAllowReserved :: Maybe Bool } deriving (Eq, Show, Generic, Data, Typeable) newtype MimeList = MimeList { getMimeList :: [MediaType] } @@ -412,6 +460,28 @@ data ParamOtherSchema = ParamOtherSchema , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema } deriving (Eq, Show, Generic, Typeable, Data) +data Example = Example + { -- | Short description for the example. + _exampleSummary :: Maybe Text + + -- | Long description for the example. + -- CommonMark syntax MAY be used for rich text representation. + , _exampleDescription :: Maybe Text + + -- | Embedded literal example. + -- The '_exampleValue' field and '_exampleExternalValue' field are mutually exclusive. + -- + -- To represent examples of media types that cannot naturally represented in JSON or YAML, + -- use a string value to contain the example, escaping where necessary. + , _exampleValue :: Maybe Value + + -- | A URL that points to the literal example. + -- This provides the capability to reference examples that cannot easily be included + -- in JSON or YAML documents. The '_exampleValue' field + -- and '_exampleExternalValue' field are mutually exclusive. + , _exampleExternalValue :: Maybe URL + } deriving (Eq, Show, Generic, Typeable, Data) + -- | Items for @'SwaggerArray'@ schemas. -- -- @'SwaggerItemsPrimitive'@ should be used only for query params, headers and path pieces. @@ -633,6 +703,8 @@ data NamedSchema = NamedSchema -- | Regex pattern for @string@ type. type Pattern = Text +-- TODO examples for params + 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@ @@ -735,22 +807,6 @@ data Header = Header , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header) } deriving (Eq, Show, Generic, Data, Typeable) -data Example = Example { getExample :: Map MediaType Value } - deriving (Eq, Show, Generic, Typeable) - -exampleConstr :: Constr -exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix - -exampleDataType :: DataType -exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr] - -instance Data Example where - gunfold k z c = case constrIndex c of - 1 -> k (z (\m -> Example (Map.mapKeys fromString m))) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Example." - toConstr (Example _) = exampleConstr - dataTypeOf _ = exampleDataType - -- | The location of the API key. data ApiKeyLocation = ApiKeyQuery @@ -898,6 +954,8 @@ deriveGeneric ''SecurityScheme deriveGeneric ''Schema deriveGeneric ''ParamSchema deriveGeneric ''Swagger +deriveGeneric ''Example +deriveGeneric ''Encoding -- ======================================================================= -- Monoid instances @@ -981,21 +1039,21 @@ instance Monoid MediaTypeObject where mempty = genericMempty mappend = (<>) -instance Semigroup ExternalDocs where +instance Semigroup Encoding where (<>) = genericMappend -instance Monoid ExternalDocs where +instance Monoid Encoding where mempty = genericMempty mappend = (<>) -instance Semigroup Operation where +instance Semigroup ExternalDocs where (<>) = genericMappend -instance Monoid Operation where +instance Monoid ExternalDocs where mempty = genericMempty mappend = (<>) -instance Semigroup Example where +instance Semigroup Operation where (<>) = genericMappend -instance Monoid Example where +instance Monoid Operation where mempty = genericMempty mappend = (<>) @@ -1251,7 +1309,12 @@ instance ToJSON MediaTypeObject where toEncoding = sopSwaggerGenericToEncoding instance ToJSON Example where - toJSON = toJSON . Map.mapKeys show . getExample + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON Encoding where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding instance ToJSON SecurityDefinitions where toJSON (SecurityDefinitions sd) = toJSON sd @@ -1267,6 +1330,8 @@ instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/compone instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/components/parameters/" instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/components/responses/" instance ToJSON (Referenced RequestBody) where toJSON = referencedToJSON "#/components/requestBodies/" +instance ToJSON (Referenced Example) where toJSON = referencedToJSON "#/components/examples/" +instance ToJSON (Referenced Header) where toJSON = referencedToJSON "#/components/headers/" instance ToJSON (SwaggerType t) where toJSON SwaggerArray = "array" @@ -1408,9 +1473,7 @@ instance FromJSON Responses where parseJSON _ = empty instance FromJSON Example where - parseJSON js = do - m <- parseJSON js - pure $ Example (Map.mapKeys fromString m) + parseJSON = sopSwaggerGenericParseJSON instance FromJSON Response where parseJSON = sopSwaggerGenericParseJSON @@ -1427,6 +1490,9 @@ instance FromJSON RequestBody where instance FromJSON MediaTypeObject where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON Encoding where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON SecurityDefinitions where parseJSON js = SecurityDefinitions <$> parseJSON js @@ -1450,7 +1516,9 @@ referencedParseJSON _ _ = fail "referenceParseJSON: not an object" instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/components/schemas/" instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/components/parameters/" instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/components/responses/" -instance FromJSON (Referenced RequestBody) where parseJSON = referencedParseJSON "#/components/requestBodies" +instance FromJSON (Referenced RequestBody) where parseJSON = referencedParseJSON "#/components/requestBodies/" +instance FromJSON (Referenced Example) where parseJSON = referencedParseJSON "#/components/examples/" +instance FromJSON (Referenced Header) where parseJSON = referencedParseJSON "#/components/headers/" instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") @@ -1513,6 +1581,10 @@ instance HasSwaggerAesonOptions Schema where swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" instance HasSwaggerAesonOptions Swagger where swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.3")] +instance HasSwaggerAesonOptions Example where + swaggerAesonOptions _ = mkSwaggerAesonOptions "example" +instance HasSwaggerAesonOptions Encoding where + swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" From 9aa51b3fdf6bcedf26190ceb56b570b042e3baed Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Fri, 26 Jun 2020 12:10:34 +0300 Subject: [PATCH 08/25] Polish types --- src/Data/Swagger.hs | 1 + src/Data/Swagger/Internal.hs | 20 +++++++++++++++++-- .../Swagger/Internal/Schema/Validation.hs | 8 ++++++-- src/Data/Swagger/Lens.hs | 5 +++++ 4 files changed, 30 insertions(+), 4 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index cfe46d53..3597bac3 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -84,6 +84,7 @@ module Data.Swagger ( Xml(..), Pattern, AdditionalProperties(..), + Discriminator(..), -- ** Responses Responses(..), diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index b9ac9d17..f189e181 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -681,11 +681,13 @@ data Schema = Schema , _schemaProperties :: InsOrdHashMap Text (Referenced Schema) , _schemaAdditionalProperties :: Maybe AdditionalProperties - , _schemaDiscriminator :: Maybe Text -- FIXME Discriminator object + , _schemaDiscriminator :: Maybe Discriminator , _schemaReadOnly :: Maybe Bool + , _schemaWriteOnly :: Maybe Bool , _schemaXml :: Maybe Xml , _schemaExternalDocs :: Maybe ExternalDocs , _schemaExample :: Maybe Value + , _schemaDeprecated :: Maybe Bool , _schemaMaxProperties :: Maybe Integer , _schemaMinProperties :: Maybe Integer @@ -693,6 +695,14 @@ data Schema = Schema , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema } deriving (Eq, Show, Generic, Data, Typeable) +data Discriminator = Discriminator + { -- | The name of the property in the payload that will hold the discriminator value. + _discriminatorPropertyName :: Text + + -- | An object to hold mappings between payload values and schema names or references. + , _discriminatorMapping :: InsOrdHashMap Text Text + } deriving (Eq, Show, Generic, Data, Typeable) + -- | A @'Schema'@ with an optional name. -- This name can be used in references. data NamedSchema = NamedSchema @@ -790,7 +800,7 @@ data Response = Response , _responseContent :: InsOrdHashMap Text MediaTypeObject -- | Maps a header name to its definition. - , _responseHeaders :: InsOrdHashMap HeaderName Header -- FIXME Referenced + , _responseHeaders :: InsOrdHashMap HeaderName (Referenced Header) -- TODO links } deriving (Eq, Show, Generic, Data, Typeable) @@ -1152,6 +1162,9 @@ instance ToJSON ExternalDocs where instance ToJSON Xml where toJSON = genericToJSON (jsonPrefix "Xml") +instance ToJSON Discriminator where + toJSON = genericToJSON (jsonPrefix "Discriminator") + -- ======================================================================= -- Simple Generic-based FromJSON instances -- ======================================================================= @@ -1189,6 +1202,9 @@ instance FromJSON Tag where instance FromJSON ExternalDocs where parseJSON = genericParseJSON (jsonPrefix "ExternalDocs") +instance FromJSON Discriminator where + parseJSON = genericParseJSON (jsonPrefix "Discriminator") + -- ======================================================================= -- Manual ToJSON instances -- ======================================================================= diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs index 39fd03a5..abe7c169 100644 --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -37,6 +37,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import qualified "unordered-containers" Data.HashSet as HashSet +import Data.Maybe (fromMaybe) import Data.Proxy import Data.Scientific (Scientific, isInteger) import Data.Text (Text) @@ -374,8 +375,11 @@ validateArray xs = do validateObject :: HashMap Text Value -> Validation Schema () validateObject o = withSchema $ \sch -> case sch ^. discriminator of - Just pname -> case fromJSON <$> HashMap.lookup pname o of - Just (Success ref) -> validateWithSchemaRef ref (Object o) + Just (Discriminator pname types) -> case fromJSON <$> HashMap.lookup pname o of + Just (Success pvalue) -> + let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types + -- TODO ref may be name or reference + in validateWithSchemaRef (Ref (Reference ref)) (Object o) Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg) Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing") Nothing -> do diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index 6b5afdf9..bdaf154d 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -29,6 +29,8 @@ import Data.Text (Text) makeFields ''Swagger makeFields ''Components makeFields ''Server +-- conflict with enum of ParamSchema +--makeLensesWith swaggerFieldRules ''ServerVariable makeFields ''RequestBody makeFields ''MediaTypeObject makeFields ''Host @@ -51,6 +53,9 @@ makeLensesWith swaggerFieldRules ''SecurityScheme makeFields ''ApiKeyParams makeFields ''OAuth2Params makeFields ''ExternalDocs +makeFields ''Encoding +makeFields ''Example +makeFields ''Discriminator -- * Prisms -- ** 'ParamAnySchema' prisms From 5b5cfcbe6a52583eedc3095f4b5bcb7b9115f043 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Fri, 26 Jun 2020 12:13:19 +0300 Subject: [PATCH 09/25] Add Optics --- src/Data/Swagger/Optics.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs index 07819c7f..b3ced6e0 100644 --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -75,6 +75,11 @@ import Optics.TH -- Lenses makeFieldLabels ''Swagger +makeFieldLabels ''Components +makeFieldLabels ''Server +makeFieldLabels ''ServerVariable +makeFieldLabels ''RequestBody +makeFieldLabels ''MediaTypeObject makeFieldLabels ''Host makeFieldLabels ''Info makeFieldLabels ''Contact @@ -95,6 +100,9 @@ makeFieldLabels ''SecurityScheme makeFieldLabels ''ApiKeyParams makeFieldLabels ''OAuth2Params makeFieldLabels ''ExternalDocs +makeFieldLabels ''Encoding +makeFieldLabels ''Example +makeFieldLabels ''Discriminator -- Prisms From fec285b3a40937e6e3c9e94508dd4a43f8daaad3 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Fri, 26 Jun 2020 13:59:50 +0300 Subject: [PATCH 10/25] Migrate OAuth2 flows --- src/Data/Swagger.hs | 7 +- src/Data/Swagger/Internal.hs | 170 +++++++++++++++++++---------------- src/Data/Swagger/Lens.hs | 13 ++- src/Data/Swagger/Optics.hs | 7 +- 4 files changed, 109 insertions(+), 88 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 3597bac3..bb96a1d5 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -95,15 +95,18 @@ module Data.Swagger ( SecurityScheme(..), SecuritySchemeType(..), SecurityRequirement(..), - SecurityDefinitions(..), -- *** API key ApiKeyParams(..), ApiKeyLocation(..), -- *** OAuth2 - OAuth2Params(..), + OAuth2Flows(..), OAuth2Flow(..), + OAuth2ImplicitFlow(..), + OAuth2PasswordFlow(..), + OAuth2ClientCredentialsFlow(..), + OAuth2AuthorizationCodeFlow(..), AuthorizationURL, TokenURL, diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index f189e181..794d79ab 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -838,26 +838,54 @@ type AuthorizationURL = Text -- | The token URL to be used for OAuth2 flow. This SHOULD be in the form of a URL. type TokenURL = Text -data OAuth2Flow - = OAuth2Implicit AuthorizationURL - | OAuth2Password TokenURL - | OAuth2Application TokenURL - | OAuth2AccessCode AuthorizationURL TokenURL - deriving (Eq, Show, Generic, Data, Typeable) +data OAuth2ImplicitFlow = OAuth2ImplicitFlow + { _oAuth2ImplicitFlowAuthorizationUrl :: AuthorizationURL + } deriving (Eq, Show, Generic, Data, Typeable) + +data OAuth2PasswordFlow = OAuth2PasswordFlow + { _oAuth2PasswordFlowTokenUrl :: TokenURL + } deriving (Eq, Show, Generic, Data, Typeable) + +data OAuth2ClientCredentialsFlow = OAuth2ClientCredentialsFlow + { _oAuth2ClientCredentialsFlowTokenUrl :: TokenURL + } deriving (Eq, Show, Generic, Data, Typeable) + +data OAuth2AuthorizationCodeFlow = OAuth2AuthorizationCodeFlow + { _oAuth2AuthorizationCodeFlowAuthorizationUrl :: AuthorizationURL + , _oAuth2AuthorizationCodeFlowTokenUrl :: TokenURL + } deriving (Eq, Show, Generic, Data, Typeable) -data OAuth2Params = OAuth2Params - { -- | The flow used by the OAuth2 security scheme. - _oauth2Flow :: OAuth2Flow +data OAuth2Flow p = OAuth2Flow + { _oAuth2Params :: p + + -- | The URL to be used for obtaining refresh tokens. + , _oAath2RefreshUrl :: Maybe URL -- | The available scopes for the OAuth2 security scheme. - , _oauth2Scopes :: InsOrdHashMap Text Text + -- A map between the scope name and a short description for it. + -- The map MAY be empty. + , _oAuth2Scopes :: InsOrdHashMap Text Text + } deriving (Eq, Show, Generic, Data, Typeable) + +data OAuth2Flows = OAuth2Flows + { -- | Configuration for the OAuth Implicit flow + _oAuth2FlowsImplicit :: Maybe (OAuth2Flow OAuth2ImplicitFlow) + + -- | Configuration for the OAuth Resource Owner Password flow + , _oAuth2FlowsPassword :: Maybe (OAuth2Flow OAuth2PasswordFlow) + + -- | Configuration for the OAuth Client Credentials flow + , _oAuth2FlowsClientCredentials :: Maybe (OAuth2Flow OAuth2ClientCredentialsFlow) + + -- | Configuration for the OAuth Authorization Code flow + , _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow) } deriving (Eq, Show, Generic, Data, Typeable) data SecuritySchemeType = SecuritySchemeHttp | SecuritySchemeApiKey ApiKeyParams - | SecuritySchemeOAuth2 OAuth2Params --- | SecuritySchemeOpenIdConnect -- FIXME + | SecuritySchemeOAuth2 OAuth2Flows + | SecuritySchemeOpenIdConnect URL deriving (Eq, Show, Generic, Data, Typeable) data SecurityScheme = SecurityScheme @@ -868,22 +896,6 @@ data SecurityScheme = SecurityScheme , _securitySchemeDescription :: Maybe Text } deriving (Eq, Show, Generic, Data, Typeable) - --- | merge scopes of two OAuth2 security schemes when their flows are identical. --- In other case returns first security scheme -mergeSecurityScheme :: SecurityScheme -> SecurityScheme -> SecurityScheme -mergeSecurityScheme s1@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 scopes1)) desc) - s2@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow2 scopes2)) _) - = if flow1 == flow2 then - SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 (scopes1 <> scopes2))) desc - else - s1 -mergeSecurityScheme s1 _ = s1 - -newtype SecurityDefinitions - = SecurityDefinitions (Definitions SecurityScheme) - deriving (Eq, Show, Generic, Data, Typeable) - -- | Lists the required security schemes to execute this operation. -- The object can have multiple security schemes declared in it which are all required -- (that is, there is a logical AND between the schemes). @@ -951,7 +963,8 @@ data AdditionalProperties deriveGeneric ''Components deriveGeneric ''Header -deriveGeneric ''OAuth2Params +deriveGeneric ''OAuth2Flow +deriveGeneric ''OAuth2Flows deriveGeneric ''Operation deriveGeneric ''Param deriveGeneric ''ParamOtherSchema @@ -1067,15 +1080,10 @@ instance Monoid Operation where mempty = genericMempty mappend = (<>) -instance Semigroup SecurityScheme where - (<>) = mergeSecurityScheme - -instance Semigroup SecurityDefinitions where - (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) = - SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2 - -instance Monoid SecurityDefinitions where - mempty = SecurityDefinitions InsOrdHashMap.empty +instance Semigroup OAuth2Flows where + (<>) = genericMappend +instance Monoid OAuth2Flows where + mempty = genericMempty mappend = (<>) -- ======================================================================= @@ -1093,7 +1101,6 @@ instance SwaggerMonoid Responses instance SwaggerMonoid Response instance SwaggerMonoid ExternalDocs instance SwaggerMonoid Operation -instance SwaggerMonoid SecurityDefinitions instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a) instance SwaggerMonoid MimeList @@ -1165,6 +1172,18 @@ instance ToJSON Xml where instance ToJSON Discriminator where toJSON = genericToJSON (jsonPrefix "Discriminator") +instance ToJSON OAuth2ImplicitFlow where + toJSON = genericToJSON (jsonPrefix "OAuth2ImplicitFlow") + +instance ToJSON OAuth2PasswordFlow where + toJSON = genericToJSON (jsonPrefix "OAuth2PasswordFlow") + +instance ToJSON OAuth2ClientCredentialsFlow where + toJSON = genericToJSON (jsonPrefix "OAuth2ClientCredentialsFlow") + +instance ToJSON OAuth2AuthorizationCodeFlow where + toJSON = genericToJSON (jsonPrefix "OAuth2AuthorizationCodeFlow") + -- ======================================================================= -- Simple Generic-based FromJSON instances -- ======================================================================= @@ -1205,26 +1224,27 @@ instance FromJSON ExternalDocs where instance FromJSON Discriminator where parseJSON = genericParseJSON (jsonPrefix "Discriminator") +instance FromJSON OAuth2ImplicitFlow where + parseJSON = genericParseJSON (jsonPrefix "OAuth2ImplicitFlow") + +instance FromJSON OAuth2PasswordFlow where + parseJSON = genericParseJSON (jsonPrefix "OAuth2PasswordFlow") + +instance FromJSON OAuth2ClientCredentialsFlow where + parseJSON = genericParseJSON (jsonPrefix "OAuth2ClientCredentialsFlow") + +instance FromJSON OAuth2AuthorizationCodeFlow where + parseJSON = genericParseJSON (jsonPrefix "OAuth2AuthorizationCodeFlow") + -- ======================================================================= -- Manual ToJSON instances -- ======================================================================= -instance ToJSON OAuth2Flow where - toJSON (OAuth2Implicit authUrl) = object - [ "flow" .= ("implicit" :: Text) - , "authorizationUrl" .= authUrl ] - toJSON (OAuth2Password tokenUrl) = object - [ "flow" .= ("password" :: Text) - , "tokenUrl" .= tokenUrl ] - toJSON (OAuth2Application tokenUrl) = object - [ "flow" .= ("application" :: Text) - , "tokenUrl" .= tokenUrl ] - toJSON (OAuth2AccessCode authUrl tokenUrl) = object - [ "flow" .= ("accessCode" :: Text) - , "authorizationUrl" .= authUrl - , "tokenUrl" .= tokenUrl ] - -instance ToJSON OAuth2Params where +instance (Eq p, ToJSON p, AesonDefaultValue p) =>ToJSON (OAuth2Flow p) where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON OAuth2Flows where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding @@ -1237,6 +1257,10 @@ instance ToJSON SecuritySchemeType where toJSON (SecuritySchemeOAuth2 params) = toJSON params <+> object [ "type" .= ("oauth2" :: Text) ] + toJSON (SecuritySchemeOpenIdConnect url) = object + [ "type" .= ("openIdConnect" :: Text) + , "openIdConnectUrl" .= url + ] instance ToJSON Swagger where toJSON a = sopSwaggerGenericToJSON a & @@ -1332,9 +1356,6 @@ instance ToJSON Encoding where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding -instance ToJSON SecurityDefinitions where - toJSON (SecurityDefinitions sd) = toJSON sd - instance ToJSON Reference where toJSON (Reference ref) = object [ "$ref" .= ref ] @@ -1379,20 +1400,10 @@ instance ToJSON AdditionalProperties where -- Manual FromJSON instances -- ======================================================================= -instance FromJSON OAuth2Flow where - parseJSON (Object o) = do - (flow :: Text) <- o .: "flow" - case flow of - "implicit" -> OAuth2Implicit <$> o .: "authorizationUrl" - "password" -> OAuth2Password <$> o .: "tokenUrl" - "application" -> OAuth2Application <$> o .: "tokenUrl" - "accessCode" -> OAuth2AccessCode - <$> o .: "authorizationUrl" - <*> o .: "tokenUrl" - _ -> empty - parseJSON _ = empty +instance (Eq p, FromJSON p, AesonDefaultValue p) => FromJSON (OAuth2Flow p) where + parseJSON = sopSwaggerGenericParseJSON -instance FromJSON OAuth2Params where +instance FromJSON OAuth2Flows where parseJSON = sopSwaggerGenericParseJSON instance FromJSON SecuritySchemeType where @@ -1402,6 +1413,7 @@ instance FromJSON SecuritySchemeType where "http" -> pure SecuritySchemeHttp "apiKey" -> SecuritySchemeApiKey <$> parseJSON js "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js + "openIdConnect" -> SecuritySchemeOpenIdConnect <$> (o .: "openIdConnectUrl") _ -> empty parseJSON _ = empty @@ -1509,9 +1521,6 @@ instance FromJSON MediaTypeObject where instance FromJSON Encoding where parseJSON = sopSwaggerGenericParseJSON -instance FromJSON SecurityDefinitions where - parseJSON js = SecurityDefinitions <$> parseJSON js - instance FromJSON Reference where parseJSON (Object o) = Reference <$> o .: "$ref" parseJSON _ = empty @@ -1573,8 +1582,10 @@ instance HasSwaggerAesonOptions Components where swaggerAesonOptions _ = mkSwaggerAesonOptions "components" instance HasSwaggerAesonOptions Header where swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema" -instance HasSwaggerAesonOptions OAuth2Params where - swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow" +instance AesonDefaultValue p => HasSwaggerAesonOptions (OAuth2Flow p) where + swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "params" +instance HasSwaggerAesonOptions OAuth2Flows where + swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows" instance HasSwaggerAesonOptions Operation where swaggerAesonOptions _ = mkSwaggerAesonOptions "operation" instance HasSwaggerAesonOptions Param where @@ -1612,7 +1623,11 @@ instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where instance AesonDefaultValue Components instance AesonDefaultValue (ParamSchema s) -instance AesonDefaultValue OAuth2Flow +instance AesonDefaultValue OAuth2ImplicitFlow +instance AesonDefaultValue OAuth2PasswordFlow +instance AesonDefaultValue OAuth2ClientCredentialsFlow +instance AesonDefaultValue OAuth2AuthorizationCodeFlow +instance AesonDefaultValue p => AesonDefaultValue (OAuth2Flow p) instance AesonDefaultValue Responses instance AesonDefaultValue ParamAnySchema instance AesonDefaultValue SecuritySchemeType @@ -1620,4 +1635,3 @@ instance AesonDefaultValue (SwaggerType a) instance AesonDefaultValue MimeList where defaultValue = Just mempty instance AesonDefaultValue Info instance AesonDefaultValue ParamLocation -instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index bdaf154d..4d65c6ef 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -51,7 +51,12 @@ makeLensesWith swaggerFieldRules ''Responses makeFields ''Response makeLensesWith swaggerFieldRules ''SecurityScheme makeFields ''ApiKeyParams -makeFields ''OAuth2Params +makeFields ''OAuth2ImplicitFlow +makeFields ''OAuth2PasswordFlow +makeFields ''OAuth2ClientCredentialsFlow +makeFields ''OAuth2AuthorizationCodeFlow +makeFields ''OAuth2Flow +makeFields ''OAuth2Flows makeFields ''ExternalDocs makeFields ''Encoding makeFields ''Example @@ -103,12 +108,6 @@ instance At Responses where at n = responses . at n instance Ixed Operation where ix n = responses . ix n instance At Operation where at n = responses . at n -type instance Index SecurityDefinitions = Text -type instance IxValue SecurityDefinitions = SecurityScheme - -instance Ixed SecurityDefinitions where ix n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). ix n -instance At SecurityDefinitions where at n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). at n - instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema -- HasType instances diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs index b3ced6e0..1c4bb247 100644 --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -98,7 +98,12 @@ makeFieldLabels ''Responses makeFieldLabels ''Response makeFieldLabels ''SecurityScheme makeFieldLabels ''ApiKeyParams -makeFieldLabels ''OAuth2Params +makeFieldLabels ''OAuth2ImplicitFlow +makeFieldLabels ''OAuth2PasswordFlow +makeFieldLabels ''OAuth2ClientCredentialsFlow +makeFieldLabels ''OAuth2AuthorizationCodeFlow +makeFieldLabels ''OAuth2Flow +makeFieldLabels ''OAuth2Flows makeFieldLabels ''ExternalDocs makeFieldLabels ''Encoding makeFieldLabels ''Example From 0bf745e6cc53aaa6eda8e34d1874d36e618b3c3e Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Fri, 26 Jun 2020 15:21:52 +0300 Subject: [PATCH 11/25] Remove old types, migrate Param --- src/Data/Swagger.hs | 4 -- src/Data/Swagger/Internal.hs | 132 +++++++---------------------------- src/Data/Swagger/Lens.hs | 8 +-- src/Data/Swagger/Optics.hs | 101 --------------------------- 4 files changed, 26 insertions(+), 219 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index bb96a1d5..b02a28e3 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -38,8 +38,6 @@ module Data.Swagger ( -- * Swagger specification Swagger(..), - Host(..), - Scheme(..), Server(..), ServerVariable(..), Components(..), @@ -65,8 +63,6 @@ module Data.Swagger ( -- ** Parameters Param(..), - ParamAnySchema(..), - ParamOtherSchema(..), ParamLocation(..), ParamName, Header(..), diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 794d79ab..e022547e 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -179,6 +179,9 @@ data ServerVariable = ServerVariable , _serverVariableDescription :: Maybe Text } deriving (Eq, Show, Generic, Data, Typeable) +instance IsString Server where + fromString s = Server (fromString s) Nothing mempty + -- | Holds a set of reusable objects for different aspects of the OAS. -- All objects defined within the components object will have no effect on the API -- unless they are explicitly referenced from properties outside the components object. @@ -194,36 +197,6 @@ data Components = Components -- , _componentsCallbacks } deriving (Eq, Show, Generic, Data, Typeable) --- | The host (name or ip) serving the API. It MAY include a port. -data Host = Host - { _hostName :: HostName -- ^ Host name. - , _hostPort :: Maybe PortNumber -- ^ Optional port. - } deriving (Eq, Show, Generic, Typeable) - -instance IsString Host where - fromString s = Host s Nothing - -hostConstr :: Constr -hostConstr = mkConstr hostDataType "Host" [] Prefix - -hostDataType :: DataType -hostDataType = mkDataType "Data.Swagger.Host" [hostConstr] - -instance Data Host where - gunfold k z c = case constrIndex c of - 1 -> k (k (z (\name mport -> Host name (fromInteger <$> mport)))) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Host." - toConstr (Host _ _) = hostConstr - dataTypeOf _ = hostDataType - --- | The transfer protocol of the API. -data Scheme - = Http - | Https - | Ws - | Wss - deriving (Eq, Show, Generic, Data, Typeable) - -- | Describes the operations available on a single path. -- A @'PathItem'@ may be empty, due to ACL constraints. -- The path itself is still exposed to the documentation viewer @@ -421,6 +394,9 @@ instance Data MimeList where toConstr (MimeList _) = mimeListConstr dataTypeOf _ = mimeListDataType +-- TODO style +-- TODO example + -- | Describes a single operation parameter. -- A unique parameter is defined by a combination of a name and location. data Param = Param @@ -438,27 +414,21 @@ data Param = Param -- Otherwise, the property MAY be included and its default value is @False@. , _paramRequired :: Maybe Bool - -- | Parameter schema. - , _paramSchema :: ParamAnySchema - } deriving (Eq, Show, Generic, Data, Typeable) - -data ParamAnySchema - = ParamBody (Referenced Schema) - | ParamOther ParamOtherSchema - deriving (Eq, Show, Generic, Data, Typeable) + -- | Specifies that a parameter is deprecated and SHOULD be transitioned out of usage. + -- Default value is @false@. + , _paramDeprecated :: Maybe Bool -data ParamOtherSchema = ParamOtherSchema - { -- | The location of the parameter. - _paramOtherSchemaIn :: ParamLocation + -- | The location of the parameter. + , _paramIn :: ParamLocation -- | Sets the ability to pass empty-valued parameters. - -- This is valid only for either @'ParamQuery'@ or @'ParamFormData'@ - -- and allows you to send a parameter with a name only or an empty value. - -- Default value is @False@. + -- This is valid only for 'ParamQuery' parameters and allows sending + -- a parameter with an empty value. Default value is @false@. , _paramOtherSchemaAllowEmptyValue :: Maybe Bool - , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema - } deriving (Eq, Show, Generic, Typeable, Data) + -- | Parameter schema. + , _paramSchema :: Maybe (Referenced Schema) + } deriving (Eq, Show, Generic, Data, Typeable) data Example = Example { -- | Short description for the example. @@ -561,10 +531,11 @@ deriving instance Typeable 'SwaggerKindNormal deriving instance Typeable 'SwaggerKindParamOtherSchema deriving instance Typeable 'SwaggerKindSchema +-- TODO remove type family SwaggerKindType (k :: SwaggerKind *) :: * type instance SwaggerKindType ('SwaggerKindNormal t) = t type instance SwaggerKindType 'SwaggerKindSchema = Schema -type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema +--type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema data SwaggerType t where SwaggerString :: SwaggerType t @@ -967,7 +938,6 @@ deriveGeneric ''OAuth2Flow deriveGeneric ''OAuth2Flows deriveGeneric ''Operation deriveGeneric ''Param -deriveGeneric ''ParamOtherSchema deriveGeneric ''PathItem deriveGeneric ''Response deriveGeneric ''RequestBody @@ -1032,12 +1002,6 @@ instance Monoid Param where mempty = genericMempty mappend = (<>) -instance Semigroup ParamOtherSchema where - (<>) = genericMappend -instance Monoid ParamOtherSchema where - mempty = genericMempty - mappend = (<>) - instance Semigroup Header where (<>) = genericMappend instance Monoid Header where @@ -1086,6 +1050,12 @@ instance Monoid OAuth2Flows where mempty = genericMempty mappend = (<>) +instance Semigroup RequestBody where + (<>) = genericMappend +instance Monoid RequestBody where + mempty = genericMempty + mappend = (<>) + -- ======================================================================= -- SwaggerMonoid helper instances -- ======================================================================= @@ -1096,7 +1066,6 @@ instance SwaggerMonoid PathItem instance SwaggerMonoid Schema instance SwaggerMonoid (ParamSchema t) instance SwaggerMonoid Param -instance SwaggerMonoid ParamOtherSchema instance SwaggerMonoid Responses instance SwaggerMonoid Response instance SwaggerMonoid ExternalDocs @@ -1123,12 +1092,6 @@ instance Monoid a => SwaggerMonoid (Referenced a) where swaggerMappend (Inline x) (Inline y) = Inline (mappend x y) swaggerMappend _ y = y -instance SwaggerMonoid ParamAnySchema where - swaggerMempty = ParamOther swaggerMempty - swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y) - swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y) - swaggerMappend _ y = y - -- ======================================================================= -- Simple Generic-based ToJSON instances -- ======================================================================= @@ -1157,9 +1120,6 @@ instance ToJSON ApiKeyLocation where instance ToJSON ApiKeyParams where toJSON = genericToJSON (jsonPrefix "apiKey") -instance ToJSON Scheme where - toJSON = genericToJSON (jsonPrefix "") - instance ToJSON Tag where toJSON = genericToJSON (jsonPrefix "Tag") @@ -1212,9 +1172,6 @@ instance FromJSON ApiKeyLocation where instance FromJSON ApiKeyParams where parseJSON = genericParseJSON (jsonPrefix "apiKey") -instance FromJSON Scheme where - parseJSON = genericParseJSON (jsonPrefix "") - instance FromJSON Tag where parseJSON = genericParseJSON (jsonPrefix "Tag") @@ -1303,12 +1260,6 @@ instance ToJSON Components where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding -instance ToJSON Host where - toJSON (Host host mport) = toJSON $ - case mport of - Nothing -> host - Just port -> host ++ ":" ++ show port - instance ToJSON MimeList where toJSON (MimeList xs) = toJSON (map show xs) @@ -1316,14 +1267,6 @@ instance ToJSON Param where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding -instance ToJSON ParamAnySchema where - toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ] - toJSON (ParamOther s) = toJSON s - -instance ToJSON ParamOtherSchema where - toJSON = sopSwaggerGenericToJSON - toEncoding = sopSwaggerGenericToEncoding - instance ToJSON Responses where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding @@ -1466,34 +1409,12 @@ instance FromJSON (SwaggerItems 'SwaggerKindSchema) where instance FromJSON Components where parseJSON = sopSwaggerGenericParseJSON -instance FromJSON Host where - parseJSON (String s) = case map Text.unpack $ Text.split (== ':') s of - [host] -> return $ Host host Nothing - [host, port] -> case readMaybe port of - Nothing -> fail $ "Invalid port `" ++ port ++ "'" - Just p -> return $ Host host (Just (fromInteger p)) - _ -> fail $ "Invalid host `" ++ Text.unpack s ++ "'" - parseJSON _ = empty - instance FromJSON MimeList where parseJSON js = (MimeList . map fromString) <$> parseJSON js instance FromJSON Param where parseJSON = sopSwaggerGenericParseJSON -instance FromJSON ParamAnySchema where - parseJSON js@(Object o) = do - (i :: Text) <- o .: "in" - case i of - "body" -> do - schema <- o .: "schema" - ParamBody <$> parseJSON schema - _ -> ParamOther <$> parseJSON js - parseJSON _ = empty - -instance FromJSON ParamOtherSchema where - parseJSON = sopSwaggerGenericParseJSON - instance FromJSON Responses where parseJSON (Object o) = Responses <$> o .:? "default" @@ -1589,9 +1510,7 @@ instance HasSwaggerAesonOptions OAuth2Flows where 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" + swaggerAesonOptions _ = mkSwaggerAesonOptions "param" instance HasSwaggerAesonOptions PathItem where swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" instance HasSwaggerAesonOptions Response where @@ -1629,7 +1548,6 @@ instance AesonDefaultValue OAuth2ClientCredentialsFlow instance AesonDefaultValue OAuth2AuthorizationCodeFlow instance AesonDefaultValue p => AesonDefaultValue (OAuth2Flow p) instance AesonDefaultValue Responses -instance AesonDefaultValue ParamAnySchema instance AesonDefaultValue SecuritySchemeType instance AesonDefaultValue (SwaggerType a) instance AesonDefaultValue MimeList where defaultValue = Just mempty diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index 4d65c6ef..fbab5dff 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -33,15 +33,13 @@ makeFields ''Server --makeLensesWith swaggerFieldRules ''ServerVariable makeFields ''RequestBody makeFields ''MediaTypeObject -makeFields ''Host makeFields ''Info makeFields ''Contact makeFields ''License makeLensesWith swaggerFieldRules ''PathItem makeFields ''Tag makeFields ''Operation -makeFields ''Param -makeLensesWith swaggerFieldRules ''ParamOtherSchema +makeLensesWith swaggerFieldRules ''Param makeFields ''Header makeLensesWith swaggerFieldRules ''Schema makeFields ''NamedSchema @@ -63,8 +61,6 @@ makeFields ''Example makeFields ''Discriminator -- * Prisms --- ** 'ParamAnySchema' prisms -makePrisms ''ParamAnySchema -- ** 'SecuritySchemeType' prisms makePrisms ''SecuritySchemeType -- ** 'Referenced' prisms @@ -114,12 +110,10 @@ instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where param instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_ instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_ instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_ -instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_ -- HasDefault instances instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_ instance HasDefault Schema (Maybe Value) where default_ = paramSchema.default_ -instance HasDefault ParamOtherSchema (Maybe Value) where default_ = paramSchema.default_ -- OVERLAPPABLE instances diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs index 1c4bb247..4bf00dd4 100644 --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -80,7 +80,6 @@ makeFieldLabels ''Server makeFieldLabels ''ServerVariable makeFieldLabels ''RequestBody makeFieldLabels ''MediaTypeObject -makeFieldLabels ''Host makeFieldLabels ''Info makeFieldLabels ''Contact makeFieldLabels ''License @@ -88,7 +87,6 @@ makeFieldLabels ''PathItem makeFieldLabels ''Tag makeFieldLabels ''Operation makeFieldLabels ''Param -makeFieldLabels ''ParamOtherSchema makeFieldLabels ''Header makeFieldLabels ''Schema makeFieldLabels ''NamedSchema @@ -111,7 +109,6 @@ makeFieldLabels ''Discriminator -- Prisms -makePrismLabels ''ParamAnySchema makePrismLabels ''SecuritySchemeType makePrismLabels ''Referenced @@ -208,13 +205,6 @@ instance labelOptic = #paramSchema % #type {-# INLINE labelOptic #-} -instance - ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema) - , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema) - ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #type - {-# INLINE labelOptic #-} - -- #default instance @@ -235,12 +225,6 @@ instance labelOptic = #paramSchema % #default {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Value, b ~ Maybe Value - ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #default - {-# INLINE labelOptic #-} - -- #format instance @@ -261,12 +245,6 @@ instance labelOptic = #paramSchema % #format {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Format, b ~ Maybe Format - ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #format - {-# INLINE labelOptic #-} - -- #items instance @@ -290,13 +268,6 @@ instance labelOptic = #paramSchema % #items {-# INLINE labelOptic #-} -instance - ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema) - , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema) - ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #items - {-# INLINE labelOptic #-} - -- #maximum instance @@ -317,12 +288,6 @@ instance labelOptic = #paramSchema % #maximum {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #maximum - {-# INLINE labelOptic #-} - -- #exclusiveMaximum instance @@ -343,12 +308,6 @@ instance labelOptic = #paramSchema % #exclusiveMaximum {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #exclusiveMaximum - {-# INLINE labelOptic #-} - -- #minimum instance @@ -369,12 +328,6 @@ instance labelOptic = #paramSchema % #minimum {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #minimum - {-# INLINE labelOptic #-} - -- #exclusiveMinimum instance @@ -395,12 +348,6 @@ instance labelOptic = #paramSchema % #exclusiveMinimum {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #exclusiveMinimum - {-# INLINE labelOptic #-} - -- #maxLength instance @@ -421,12 +368,6 @@ instance labelOptic = #paramSchema % #maxLength {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #maxLength - {-# INLINE labelOptic #-} - -- #minLength instance @@ -447,12 +388,6 @@ instance labelOptic = #paramSchema % #minLength {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #minLength - {-# INLINE labelOptic #-} - -- #pattern instance @@ -473,12 +408,6 @@ instance labelOptic = #paramSchema % #pattern {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Text, b ~ Maybe Text - ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #pattern - {-# INLINE labelOptic #-} - -- #maxItems instance @@ -499,12 +428,6 @@ instance labelOptic = #paramSchema % #maxItems {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #maxItems - {-# INLINE labelOptic #-} - -- #minItems instance @@ -525,12 +448,6 @@ instance labelOptic = #paramSchema % #minItems {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #minItems - {-# INLINE labelOptic #-} - -- #uniqueItems instance @@ -551,12 +468,6 @@ instance labelOptic = #paramSchema % #uniqueItems {-# INLINE labelOptic #-} -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #uniqueItems - {-# INLINE labelOptic #-} - -- #enum instance @@ -577,12 +488,6 @@ instance labelOptic = #paramSchema % #enum {-# INLINE labelOptic #-} -instance - ( a ~ Maybe [Value], b ~ Maybe [Value] - ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #enum - {-# INLINE labelOptic #-} - -- #multipleOf instance @@ -602,9 +507,3 @@ instance ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where labelOptic = #paramSchema % #multipleOf {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #multipleOf - {-# INLINE labelOptic #-} From 808798032902e909c6a8c32fe65c34021ea369b3 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Fri, 26 Jun 2020 16:59:54 +0300 Subject: [PATCH 12/25] SwaggerSpec passes --- src/Data/Swagger.hs | 1 + src/Data/Swagger/Internal.hs | 72 +- src/Data/Swagger/Lens.hs | 4 +- src/Data/Swagger/Optics.hs | 32 +- test/Data/Swagger/SchemaSpec.hs | 14 +- test/Data/SwaggerSpec.hs | 1563 ++++++++----------------------- test/SpecCommon.hs | 2 +- 7 files changed, 480 insertions(+), 1208 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index b02a28e3..0d4980af 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -90,6 +90,7 @@ module Data.Swagger ( -- ** Security SecurityScheme(..), SecuritySchemeType(..), + SecurityDefinitions(..), SecurityRequirement(..), -- *** API key diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index e022547e..886b04f9 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -684,8 +684,6 @@ data NamedSchema = NamedSchema -- | Regex pattern for @string@ type. type Pattern = Text --- TODO examples for params - 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@ @@ -785,7 +783,7 @@ data Header = Header { -- | A short description of the header. _headerDescription :: Maybe Text - , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header) + , _headerSchema :: ParamSchema ('SwaggerKindNormal Header) } deriving (Eq, Show, Generic, Data, Typeable) -- | The location of the API key. @@ -867,6 +865,10 @@ data SecurityScheme = SecurityScheme , _securitySchemeDescription :: Maybe Text } deriving (Eq, Show, Generic, Data, Typeable) +newtype SecurityDefinitions + = SecurityDefinitions (Definitions SecurityScheme) + deriving (Eq, Show, Generic, Data, Typeable) + -- | Lists the required security schemes to execute this operation. -- The object can have multiple security schemes declared in it which are all required -- (that is, there is a logical AND between the schemes). @@ -932,6 +934,7 @@ data AdditionalProperties -- Generic instances ------------------------------------------------------------------------------- +deriveGeneric ''Server deriveGeneric ''Components deriveGeneric ''Header deriveGeneric ''OAuth2Flow @@ -1044,12 +1047,38 @@ instance Monoid Operation where mempty = genericMempty mappend = (<>) +instance Semigroup (OAuth2Flow p) where + l@OAuth2Flow{ _oAath2RefreshUrl = lUrl, _oAuth2Scopes = lScopes } + <> OAuth2Flow { _oAath2RefreshUrl = rUrl, _oAuth2Scopes = rScopes } = + l { _oAath2RefreshUrl = swaggerMappend lUrl rUrl, _oAuth2Scopes = lScopes <> rScopes } + +-- swaggerMappend has First-like semantics, and here we need mappend'ing under Maybes. instance Semigroup OAuth2Flows where - (<>) = genericMappend + l <> r = OAuth2Flows + { _oAuth2FlowsImplicit = _oAuth2FlowsImplicit l <> _oAuth2FlowsImplicit r + , _oAuth2FlowsPassword = _oAuth2FlowsPassword l <> _oAuth2FlowsPassword r + , _oAuth2FlowsClientCredentials = _oAuth2FlowsClientCredentials l <> _oAuth2FlowsClientCredentials r + , _oAuth2FlowsAuthorizationCode = _oAuth2FlowsAuthorizationCode l <> _oAuth2FlowsAuthorizationCode r + } + instance Monoid OAuth2Flows where mempty = genericMempty mappend = (<>) +instance Semigroup SecurityScheme where + SecurityScheme (SecuritySchemeOAuth2 lFlows) lDesc + <> SecurityScheme (SecuritySchemeOAuth2 rFlows) rDesc = + SecurityScheme (SecuritySchemeOAuth2 $ lFlows <> rFlows) (swaggerMappend lDesc rDesc) + l <> _ = l + +instance Semigroup SecurityDefinitions where + (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) = + SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2 + +instance Monoid SecurityDefinitions where + mempty = SecurityDefinitions InsOrdHashMap.empty + mappend = (<>) + instance Semigroup RequestBody where (<>) = genericMappend instance Monoid RequestBody where @@ -1108,9 +1137,6 @@ instance ToJSON Contact where instance ToJSON License where toJSON = genericToJSON (jsonPrefix "License") -instance ToJSON Server where - toJSON = genericToJSON (jsonPrefix "Server") - instance ToJSON ServerVariable where toJSON = genericToJSON (jsonPrefix "ServerVariable") @@ -1160,9 +1186,6 @@ instance FromJSON Contact where instance FromJSON License where parseJSON = genericParseJSON (jsonPrefix "License") -instance FromJSON Server where - parseJSON = genericParseJSON (jsonPrefix "Server") - instance FromJSON ServerVariable where parseJSON = genericParseJSON (jsonPrefix "ServerVariable") @@ -1211,9 +1234,10 @@ instance ToJSON SecuritySchemeType where toJSON (SecuritySchemeApiKey params) = toJSON params <+> object [ "type" .= ("apiKey" :: Text) ] - toJSON (SecuritySchemeOAuth2 params) - = toJSON params - <+> object [ "type" .= ("oauth2" :: Text) ] + toJSON (SecuritySchemeOAuth2 params) = object + [ "type" .= ("oauth2" :: Text) + , "flows" .= toJSON params + ] toJSON (SecuritySchemeOpenIdConnect url) = object [ "type" .= ("openIdConnect" :: Text) , "openIdConnectUrl" .= url @@ -1226,6 +1250,10 @@ instance ToJSON Swagger where else id toEncoding = sopSwaggerGenericToEncoding +instance ToJSON Server where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON SecurityScheme where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding @@ -1299,6 +1327,9 @@ instance ToJSON Encoding where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON SecurityDefinitions where + toJSON (SecurityDefinitions sd) = toJSON sd + instance ToJSON Reference where toJSON (Reference ref) = object [ "$ref" .= ref ] @@ -1355,7 +1386,7 @@ instance FromJSON SecuritySchemeType where case t of "http" -> pure SecuritySchemeHttp "apiKey" -> SecuritySchemeApiKey <$> parseJSON js - "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js + "oauth2" -> SecuritySchemeOAuth2 <$> (o .: "flows") "openIdConnect" -> SecuritySchemeOpenIdConnect <$> (o .: "openIdConnectUrl") _ -> empty parseJSON _ = empty @@ -1363,6 +1394,9 @@ instance FromJSON SecuritySchemeType where instance FromJSON Swagger where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON Server where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON SecurityScheme where parseJSON = sopSwaggerGenericParseJSON @@ -1433,6 +1467,9 @@ instance FromJSON Operation where instance FromJSON PathItem where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON SecurityDefinitions where + parseJSON js = SecurityDefinitions <$> parseJSON js + instance FromJSON RequestBody where parseJSON = sopSwaggerGenericParseJSON @@ -1499,10 +1536,12 @@ instance FromJSON AdditionalProperties where parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b parseJSON js = AdditionalPropertiesSchema <$> parseJSON js +instance HasSwaggerAesonOptions Server where + swaggerAesonOptions _ = mkSwaggerAesonOptions "server" instance HasSwaggerAesonOptions Components where swaggerAesonOptions _ = mkSwaggerAesonOptions "components" instance HasSwaggerAesonOptions Header where - swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema" + swaggerAesonOptions _ = mkSwaggerAesonOptions "header" instance AesonDefaultValue p => HasSwaggerAesonOptions (OAuth2Flow p) where swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "params" instance HasSwaggerAesonOptions OAuth2Flows where @@ -1526,7 +1565,7 @@ instance HasSwaggerAesonOptions SecurityScheme where instance HasSwaggerAesonOptions Schema where swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" instance HasSwaggerAesonOptions Swagger where - swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.3")] + swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")] instance HasSwaggerAesonOptions Example where swaggerAesonOptions _ = mkSwaggerAesonOptions "example" instance HasSwaggerAesonOptions Encoding where @@ -1540,6 +1579,7 @@ instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" +instance AesonDefaultValue Server instance AesonDefaultValue Components instance AesonDefaultValue (ParamSchema s) instance AesonDefaultValue OAuth2ImplicitFlow diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index fbab5dff..cbe0f6b7 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -107,12 +107,12 @@ instance At Operation where at n = responses . at n instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema -- HasType instances -instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_ +instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = schema.type_ instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_ instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_ -- HasDefault instances -instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_ +instance HasDefault Header (Maybe Value) where default_ = schema.default_ instance HasDefault Schema (Maybe Value) where default_ = paramSchema.default_ -- OVERLAPPABLE instances diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs index 4bf00dd4..3290651c 100644 --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -188,7 +188,7 @@ instance ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header)) , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header)) ) => LabelOptic "type" A_Lens Header Header a b where - labelOptic = #paramSchema % #type + labelOptic = #schema % #type {-# INLINE labelOptic #-} instance @@ -210,7 +210,7 @@ instance instance ( a ~ Maybe Value, b ~ Maybe Value ) => LabelOptic "default" A_Lens Header Header a b where - labelOptic = #paramSchema % #default + labelOptic = #schema % #default {-# INLINE labelOptic #-} instance @@ -230,7 +230,7 @@ instance instance ( a ~ Maybe Format, b ~ Maybe Format ) => LabelOptic "format" A_Lens Header Header a b where - labelOptic = #paramSchema % #format + labelOptic = #schema % #format {-# INLINE labelOptic #-} instance @@ -251,7 +251,7 @@ instance ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header)) , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header)) ) => LabelOptic "items" A_Lens Header Header a b where - labelOptic = #paramSchema % #items + labelOptic = #schema % #items {-# INLINE labelOptic #-} instance @@ -273,7 +273,7 @@ instance instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "maximum" A_Lens Header Header a b where - labelOptic = #paramSchema % #maximum + labelOptic = #schema % #maximum {-# INLINE labelOptic #-} instance @@ -293,7 +293,7 @@ instance instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where - labelOptic = #paramSchema % #exclusiveMaximum + labelOptic = #schema % #exclusiveMaximum {-# INLINE labelOptic #-} instance @@ -313,7 +313,7 @@ instance instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "minimum" A_Lens Header Header a b where - labelOptic = #paramSchema % #minimum + labelOptic = #schema % #minimum {-# INLINE labelOptic #-} instance @@ -333,7 +333,7 @@ instance instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where - labelOptic = #paramSchema % #exclusiveMinimum + labelOptic = #schema % #exclusiveMinimum {-# INLINE labelOptic #-} instance @@ -353,7 +353,7 @@ instance instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "maxLength" A_Lens Header Header a b where - labelOptic = #paramSchema % #maxLength + labelOptic = #schema % #maxLength {-# INLINE labelOptic #-} instance @@ -373,7 +373,7 @@ instance instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "minLength" A_Lens Header Header a b where - labelOptic = #paramSchema % #minLength + labelOptic = #schema % #minLength {-# INLINE labelOptic #-} instance @@ -393,7 +393,7 @@ instance instance ( a ~ Maybe Text, b ~ Maybe Text ) => LabelOptic "pattern" A_Lens Header Header a b where - labelOptic = #paramSchema % #pattern + labelOptic = #schema % #pattern {-# INLINE labelOptic #-} instance @@ -413,7 +413,7 @@ instance instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "maxItems" A_Lens Header Header a b where - labelOptic = #paramSchema % #maxItems + labelOptic = #schema % #maxItems {-# INLINE labelOptic #-} instance @@ -433,7 +433,7 @@ instance instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "minItems" A_Lens Header Header a b where - labelOptic = #paramSchema % #minItems + labelOptic = #schema % #minItems {-# INLINE labelOptic #-} instance @@ -453,7 +453,7 @@ instance instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "uniqueItems" A_Lens Header Header a b where - labelOptic = #paramSchema % #uniqueItems + labelOptic = #schema % #uniqueItems {-# INLINE labelOptic #-} instance @@ -473,7 +473,7 @@ instance instance ( a ~ Maybe [Value], b ~ Maybe [Value] ) => LabelOptic "enum" A_Lens Header Header a b where - labelOptic = #paramSchema % #enum + labelOptic = #schema % #enum {-# INLINE labelOptic #-} instance @@ -493,7 +493,7 @@ instance instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "multipleOf" A_Lens Header Header a b where - labelOptic = #paramSchema % #multipleOf + labelOptic = #schema % #multipleOf {-# INLINE labelOptic #-} instance diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs index 9750d1c6..8364e72e 100644 --- a/test/Data/Swagger/SchemaSpec.hs +++ b/test/Data/Swagger/SchemaSpec.hs @@ -24,37 +24,37 @@ import Test.Hspec import qualified Data.HashMap.Strict as HM import Data.Time.LocalTime -checkToSchema :: ToSchema a => Proxy a -> Value -> Spec +checkToSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec checkToSchema proxy js = toSchema proxy <=> js -checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec +checkSchemaName :: (HasCallStack, ToSchema a) => Maybe String -> Proxy a -> Spec checkSchemaName sname proxy = it ("schema name is " ++ show sname) $ schemaName proxy `shouldBe` fmap Text.pack sname -checkDefs :: ToSchema a => Proxy a -> [String] -> Spec +checkDefs :: (HasCallStack, ToSchema a) => Proxy a -> [String] -> Spec checkDefs proxy names = it ("uses these definitions " ++ show names) $ InsOrdHashMap.keys defs `shouldBe` map Text.pack names where defs = execDeclare (declareNamedSchema proxy) mempty -checkProperties :: ToSchema a => Proxy a -> [String] -> Spec +checkProperties :: (HasCallStack, 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 :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec checkInlinedSchema proxy js = toInlinedSchema proxy <=> js -checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec +checkInlinedSchemas :: (HasCallStack, ToSchema a) => [String] -> Proxy a -> Value -> Spec checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js where (defs, s) = runDeclare (declareSchema proxy) mempty -checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec +checkInlinedRecSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js where (defs, s) = runDeclare (declareSchema proxy) mempty diff --git a/test/Data/SwaggerSpec.hs b/test/Data/SwaggerSpec.hs index 46ce52f7..517233b0 100644 --- a/test/Data/SwaggerSpec.hs +++ b/test/Data/SwaggerSpec.hs @@ -21,14 +21,6 @@ import Test.Hspec hiding (example) spec :: Spec spec = do - describe "host" $ do - it "can decode the host port" $ do - let h = Just $ Host "localhost" (Just (fromInteger 8000)) - swagger :: Swagger - swagger = swaggerExample - & host .~ h - parsed :: Swagger = either error id $ eitherDecode' $ encode swagger - parsed ^. host `shouldBe` h describe "License Object" $ licenseExample <=> licenseExampleJSON describe "Contact Object" $ contactExample <=> contactExampleJSON describe "Info Object" $ infoExample <=> infoExampleJSON @@ -48,9 +40,11 @@ spec = do describe "Swagger Object" $ do context "Example with no paths" $ emptyPathsFieldExample <=> emptyPathsFieldExampleJSON context "Todo Example" $ swaggerExample <=> swaggerExampleJSON - context "PetStore Example" $ + context "PetStore Example" $ do it "decodes successfully" $ do fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: Swagger) -> True; _ -> False) + it "roundtrips: fmap toJSON . fromJSON" $ do + (toJSON :: Swagger -> Value) <$> fromJSON petstoreExampleJSON `shouldBe` Success petstoreExampleJSON main :: IO () main = hspec spec @@ -133,34 +127,23 @@ operationExample = mempty & summary ?~ "Updates a pet in the store with form data" & description ?~ "" & operationId ?~ "updatePetWithForm" - & consumes ?~ MimeList ["application/x-www-form-urlencoded"] - & produces ?~ MimeList ["application/json", "application/xml"] - & parameters .~ map Inline - [ mempty - & name .~ "petId" - & description ?~ "ID of pet that needs to be updated" - & required ?~ True - & schema .~ ParamOther (stringSchema ParamPath) - , mempty - & name .~ "name" - & description ?~ "Updated name of the pet" - & required ?~ False - & schema .~ ParamOther (stringSchema ParamFormData) - , mempty - & name .~ "status" - & description ?~ "Updated status of the pet" - & required ?~ False - & schema .~ ParamOther (stringSchema ParamFormData) - ] - + & parameters .~ [Inline (mempty + & name .~ "petId" + & description ?~ "ID of pet that needs to be updated" + & required ?~ True + & in_ .~ ParamPath + & schema ?~ Inline (mempty & type_ ?~ SwaggerString))] + & requestBody ?~ Inline ( + mempty & content . at "application/x-www-form-urlencoded" ?~ (mempty & schema ?~ (Inline (mempty + & properties . at "petId" ?~ Inline (mempty + & description ?~ "Updated name of the pet" + & type_ ?~ SwaggerString) + & properties . at "status" ?~ Inline (mempty + & description ?~ "Updated status of the pet" + & type_ ?~ SwaggerString))))) & at 200 ?~ "Pet updated." & at 405 ?~ "Invalid input" & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]] - where - stringSchema :: ParamLocation -> ParamOtherSchema - stringSchema loc = mempty - & in_ .~ loc - & type_ ?~ SwaggerString operationExampleJSON :: Value operationExampleJSON = [aesonQQ| @@ -171,36 +154,35 @@ operationExampleJSON = [aesonQQ| "summary": "Updates a pet in the store with form data", "description": "", "operationId": "updatePetWithForm", - "consumes": [ - "application/x-www-form-urlencoded" - ], - "produces": [ - "application/json", - "application/xml" - ], "parameters": [ { - "name": "petId", - "in": "path", - "description": "ID of pet that needs to be updated", "required": true, - "type": "string" - }, - { - "name": "name", - "in": "formData", - "description": "Updated name of the pet", - "required": false, - "type": "string" - }, - { - "name": "status", - "in": "formData", - "description": "Updated status of the pet", - "required": false, - "type": "string" + "schema": { + "type": "string" + }, + "in": "path", + "name": "petId", + "description": "ID of pet that needs to be updated" } ], + "requestBody": { + "content": { + "application/x-www-form-urlencoded": { + "schema": { + "properties": { + "petId": { + "type": "string", + "description": "Updated name of the pet" + }, + "status": { + "type": "string", + "description": "Updated status of the pet" + } + } + } + } + } + }, "responses": { "200": { "description": "Pet updated." @@ -251,24 +233,21 @@ schemaSimpleModelExample = mempty schemaSimpleModelExampleJSON :: Value schemaSimpleModelExampleJSON = [aesonQQ| -{ - "type": "object", - "required": [ - "name" - ], +{ "required": [ "name" ], "properties": { "name": { "type": "string" }, "address": { - "$ref": "#/definitions/Address" + "$ref": "#/components/schemas/Address" }, "age": { - "type": "integer", "format": "int32", - "minimum": 0 + "minimum": 0, + "type": "integer" } - } + }, + "type": "object" } |] @@ -401,16 +380,16 @@ paramsDefinitionExample = & name .~ "skip" & description ?~ "number of items to skip" & required ?~ True - & schema .~ ParamOther (mempty - & in_ .~ ParamQuery + & in_ .~ ParamQuery + & schema ?~ Inline (mempty & type_ ?~ SwaggerInteger & format ?~ "int32" )) , ("limitParam", mempty & name .~ "limit" & description ?~ "max records to return" & required ?~ True - & schema .~ ParamOther (mempty - & in_ .~ ParamQuery + & in_ .~ ParamQuery + & schema ?~ Inline (mempty & type_ ?~ SwaggerInteger & format ?~ "int32" )) ] @@ -422,16 +401,20 @@ paramsDefinitionExampleJSON = [aesonQQ| "in": "query", "description": "number of items to skip", "required": true, - "type": "integer", - "format": "int32" + "schema": { + "type": "integer", + "format": "int32" + } }, "limitParam": { "name": "limit", "in": "query", "description": "max records to return", "required": true, - "type": "integer", - "format": "int32" + "schema": { + "type": "integer", + "format": "int32" + } } } |] @@ -467,39 +450,45 @@ securityDefinitionsExample = SecurityDefinitions { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader) , _securitySchemeDescription = Nothing }) , ("petstore_auth", SecurityScheme - { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params - { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog" - , _oauth2Scopes = - [ ("write:pets", "modify pets in your account") - , ("read:pets", "read your pets") ] } ) + { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow + { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" + , _oAath2RefreshUrl = Nothing + , _oAuth2Scopes = + [ ("write:pets", "modify pets in your account") + , ("read:pets", "read your pets") ] } ) , _securitySchemeDescription = Nothing }) ] securityDefinitionsExampleJSON :: Value securityDefinitionsExampleJSON = [aesonQQ| { "api_key": { - "type": "apiKey", + "in": "header", "name": "api_key", - "in": "header" + "type": "apiKey" }, "petstore_auth": { "type": "oauth2", - "authorizationUrl": "http://swagger.io/api/oauth/dialog", - "flow": "implicit", - "scopes": { - "write:pets": "modify pets in your account", - "read:pets": "read your pets" + "flows": { + "implicit": { + "scopes": { + "write:pets": "modify pets in your account", + "read:pets": "read your pets" + }, + "authorizationUrl": "http://swagger.io/api/oauth/dialog" + } } } } + |] oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions oAuth2SecurityDefinitionsReadExample = SecurityDefinitions [ ("petstore_auth", SecurityScheme - { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params - { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog" - , _oauth2Scopes = + { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow + { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" + , _oAath2RefreshUrl = Nothing + , _oAuth2Scopes = [ ("read:pets", "read your pets") ] } ) , _securitySchemeDescription = Nothing }) ] @@ -507,10 +496,11 @@ oAuth2SecurityDefinitionsReadExample = SecurityDefinitions oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions [ ("petstore_auth", SecurityScheme - { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params - { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog" - , _oauth2Scopes = - [ ("write:pets", "modify pets in your account") ] } ) + { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow + { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" + , _oAath2RefreshUrl = Nothing + , _oAuth2Scopes = + [ ("write:pets", "modify pets in your account") ] } ) , _securitySchemeDescription = Nothing }) ] @@ -524,11 +514,14 @@ oAuth2SecurityDefinitionsExampleJSON = [aesonQQ| { "petstore_auth": { "type": "oauth2", - "authorizationUrl": "http://swagger.io/api/oauth/dialog", - "flow": "implicit", - "scopes": { - "write:pets": "modify pets in your account", - "read:pets": "read your pets" + "flows": { + "implicit": { + "scopes": { + "write:pets": "modify pets in your account", + "read:pets": "read your pets" + }, + "authorizationUrl": "http://swagger.io/api/oauth/dialog" + } } } } @@ -544,57 +537,54 @@ emptyPathsFieldExample = mempty emptyPathsFieldExampleJSON :: Value emptyPathsFieldExampleJSON = [aesonQQ| { - "swagger": "2.0", + "openapi": "3.0.0", "info": {"version": "", "title": ""}, - "paths": {} + "paths": {}, + "components": {} } |] swaggerExample :: Swagger swaggerExample = mempty - & basePath ?~ "/" - & schemes ?~ [Http] + -- & basePath ?~ "/" + -- & schemes ?~ [Http] & info .~ (mempty & version .~ "1.0" & title .~ "Todo API" & license ?~ "MIT" & license._Just.url ?~ URL "http://mit.com" - & description ?~ "This is a an API that tests servant-swagger support for a Todo API") + & description ?~ "This is an API that tests servant-swagger support for a Todo API") & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation) - & at 200 ?~ Inline (mempty + & responses . at 200 ?~ Inline (mempty & description .~ "OK" - & schema ?~ Inline (mempty - & type_ ?~ SwaggerObject - & example ?~ [aesonQQ| - { - "created": 100, - "description": "get milk" - } |] - & description ?~ "This is some real Todo right here" - & properties .~ - [ ("created", Inline $ mempty - & type_ ?~ SwaggerInteger - & format ?~ "int32") - , ("description", Inline (mempty & type_ ?~ SwaggerString))])) - & produces ?~ MimeList [ "application/json" ] + & content . at "application/json" ?~ (mempty + & schema ?~ Inline (mempty + & type_ ?~ SwaggerObject + & example ?~ [aesonQQ| + { + "created": 100, + "description": "get milk" + } |] + & description ?~ "This is some real Todo right here" + & properties .~ + [ ("created", Inline $ mempty + & type_ ?~ SwaggerInteger + & format ?~ "int32") + , ("description", Inline (mempty & type_ ?~ SwaggerString))]))) & parameters .~ [ Inline $ mempty & required ?~ True & name .~ "id" & description ?~ "TodoId param" - & schema .~ ParamOther (mempty - & in_ .~ ParamPath + & in_ .~ ParamPath + & schema ?~ Inline (mempty & type_ ?~ SwaggerString ) ] & tags .~ InsOrdHS.fromList [ "todo" ] )) swaggerExampleJSON :: Value swaggerExampleJSON = [aesonQQ| { - "swagger": "2.0", - "basePath": "/", - "schemes": [ - "http" - ], + "openapi": "3.0.0", "info": { "version": "1.0", "title": "Todo API", @@ -602,1085 +592,326 @@ swaggerExampleJSON = [aesonQQ| "url": "http://mit.com", "name": "MIT" }, - "description": "This is a an API that tests servant-swagger support for a Todo API" + "description": "This is an API that tests servant-swagger support for a Todo API" }, "paths": { "/todo/{id}": { "get": { - "responses": { - "200": { - "schema": { - "example": { - "created": 100, - "description": "get milk" - }, - "type": "object", - "description": "This is some real Todo right here", - "properties": { - "created": { - "format": "int32", - "type": "integer" - }, - "description": { - "type": "string" - } - } - }, - "description": "OK" - } - }, - "produces": [ - "application/json" + "tags": [ + "todo" ], "parameters": [ { "required": true, + "schema": { + "type": "string" + }, "in": "path", "name": "id", - "type": "string", "description": "TodoId param" } ], - "tags": [ - "todo" - ] + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "example": { + "created": 100, + "description": "get milk" + }, + "type": "object", + "description": "This is some real Todo right here", + "properties": { + "created": { + "format": "int32", + "type": "integer" + }, + "description": { + "type": "string" + } + } + } + } + }, + "description": "OK" + } + } } } - } + }, + "components": {} } |] petstoreExampleJSON :: Value petstoreExampleJSON = [aesonQQ| { - "swagger":"2.0", - "info":{ - "description":"This is a sample server Petstore server. You can find out more about Swagger at [http://swagger.io](http://swagger.io) or on [irc.freenode.net, #swagger](http://swagger.io/irc/). For this sample, you can use the api key `special-key` to test the authorization filters.", - "version":"1.0.0", - "title":"Swagger Petstore", - "termsOfService":"http://swagger.io/terms/", - "contact":{ - "email":"apiteam@swagger.io" - }, - "license":{ - "name":"Apache 2.0", - "url":"http://www.apache.org/licenses/LICENSE-2.0.html" - } - }, - "host":"petstore.swagger.io", - "basePath":"/v2", - "tags":[ - { - "name":"pet", - "description":"Everything about your Pets", - "externalDocs":{ - "description":"Find out more", - "url":"http://swagger.io" - } - }, - { - "name":"store", - "description":"Access to Petstore orders" - }, - { - "name":"user", - "description":"Operations about user", - "externalDocs":{ - "description":"Find out more about our store", - "url":"http://swagger.io" - } - } - ], - "schemes":[ - "http" - ], - "paths":{ - "/pet":{ - "post":{ - "tags":[ - "pet" - ], - "summary":"Add a new pet to the store", - "description":"", - "operationId":"addPet", - "consumes":[ - "application/json", - "application/xml" - ], - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"Pet object that needs to be added to the store", - "required":true, - "schema":{ - "$ref":"#/definitions/Pet" - } - } - ], - "responses":{ - "405":{ - "description":"Invalid input" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - }, - "put":{ - "tags":[ - "pet" - ], - "summary":"Update an existing pet", - "description":"", - "operationId":"updatePet", - "consumes":[ - "application/json", - "application/xml" - ], - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"Pet object that needs to be added to the store", - "required":true, - "schema":{ - "$ref":"#/definitions/Pet" - } - } - ], - "responses":{ - "400":{ - "description":"Invalid ID supplied" - }, - "404":{ - "description":"Pet not found" - }, - "405":{ - "description":"Validation exception" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - } - }, - "/pet/findByStatus":{ - "get":{ - "tags":[ - "pet" - ], - "summary":"Finds Pets by status", - "description":"Multiple status values can be provided with comma seperated strings", - "operationId":"findPetsByStatus", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"status", - "in":"query", - "description":"Status values that need to be considered for filter", - "required":true, - "type":"array", - "items":{ - "type":"string", - "enum":[ - "available", - "pending", - "sold" - ], - "default":"available" - }, - "collectionFormat":"csv" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "type":"array", - "items":{ - "$ref":"#/definitions/Pet" - } - } - }, - "400":{ - "description":"Invalid status value" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - } - }, - "/pet/findByTags":{ - "get":{ - "tags":[ - "pet" - ], - "summary":"Finds Pets by tags", - "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.", - "operationId":"findPetsByTags", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"tags", - "in":"query", - "description":"Tags to filter by", - "required":true, - "type":"array", - "items":{ - "type":"string" - }, - "collectionFormat":"csv" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "type":"array", - "items":{ - "$ref":"#/definitions/Pet" - } - } - }, - "400":{ - "description":"Invalid tag value" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - } - }, - "/pet/{petId}":{ - "get":{ - "tags":[ - "pet" - ], - "summary":"Find pet by ID", - "description":"Returns a single pet", - "operationId":"getPetById", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"petId", - "in":"path", - "description":"ID of pet to return", - "required":true, - "type":"integer", - "format":"int64" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "$ref":"#/definitions/Pet" - } - }, - "400":{ - "description":"Invalid ID supplied" - }, - "404":{ - "description":"Pet not found" - } - }, - "security":[ - { - "api_key": [] - } - ] - }, - "post":{ - "tags":[ - "pet" - ], - "summary":"Updates a pet in the store with form data", - "description":"", - "operationId":"updatePetWithForm", - "consumes":[ - "application/x-www-form-urlencoded" - ], - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"petId", - "in":"path", - "description":"ID of pet that needs to be updated", - "required":true, - "type":"integer", - "format":"int64" - }, - { - "name":"name", - "in":"formData", - "description":"Updated name of the pet", - "required":false, - "type":"string" - }, - { - "name":"status", - "in":"formData", - "description":"Updated status of the pet", - "required":false, - "type":"string" - } - ], - "responses":{ - "405":{ - "description":"Invalid input" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - }, - "delete":{ - "tags":[ - "pet" - ], - "summary":"Deletes a pet", - "description":"", - "operationId":"deletePet", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"api_key", - "in":"header", - "required":false, - "type":"string" - }, - { - "name":"petId", - "in":"path", - "description":"Pet id to delete", - "required":true, - "type":"integer", - "format":"int64" - } - ], - "responses":{ - "400":{ - "description":"Invalid pet value" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - } - }, - "/pet/{petId}/uploadImage":{ - "post":{ - "tags":[ - "pet" - ], - "summary":"uploads an image", - "description":"", - "operationId":"uploadFile", - "consumes":[ - "multipart/form-data" - ], - "produces":[ - "application/json" - ], - "parameters":[ - { - "name":"petId", - "in":"path", - "description":"ID of pet to update", - "required":true, - "type":"integer", - "format":"int64" - }, - { - "name":"additionalMetadata", - "in":"formData", - "description":"Additional data to pass to server", - "required":false, - "type":"string" - }, - { - "name":"file", - "in":"formData", - "description":"file to upload", - "required":false, - "type":"file" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "$ref":"#/definitions/ApiResponse" - } - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - } - }, - "/store/inventory":{ - "get":{ - "tags":[ - "store" - ], - "summary":"Returns pet inventories by status", - "description":"Returns a map of status codes to quantities", - "operationId":"getInventory", - "produces":[ - "application/json" - ], - "parameters": [], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "type":"object", - "additionalProperties":{ - "type":"integer", - "format":"int32" - } - } - } - }, - "security":[ - { - "api_key": [] - } - ] - } - }, - "/store/order":{ - "post":{ - "tags":[ - "store" - ], - "summary":"Place an order for a pet", - "description":"", - "operationId":"placeOrder", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"order placed for purchasing the pet", - "required":true, - "schema":{ - "$ref":"#/definitions/Order" - } - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "$ref":"#/definitions/Order" - } - }, - "400":{ - "description":"Invalid Order" - } - } - } - }, - "/store/order/{orderId}":{ - "get":{ - "tags":[ - "store" - ], - "summary":"Find purchase order by ID", - "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions", - "operationId":"getOrderById", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"orderId", - "in":"path", - "description":"ID of pet that needs to be fetched", - "required":true, - "type":"integer", - "maximum":5.0, - "minimum":1.0, - "format":"int64" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "$ref":"#/definitions/Order" - } - }, - "400":{ - "description":"Invalid ID supplied" - }, - "404":{ - "description":"Order not found" - } - } - }, - "delete":{ - "tags":[ - "store" - ], - "summary":"Delete purchase order by ID", - "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors", - "operationId":"deleteOrder", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"orderId", - "in":"path", - "description":"ID of the order that needs to be deleted", - "required":true, - "type":"string", - "minimum":1.0 - } - ], - "responses":{ - "400":{ - "description":"Invalid ID supplied" - }, - "404":{ - "description":"Order not found" - } - } - } - }, - "/user":{ - "post":{ - "tags":[ - "user" - ], - "summary":"Create user", - "description":"This can only be done by the logged in user.", - "operationId":"createUser", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"Created user object", - "required":true, - "schema":{ - "$ref":"#/definitions/User" - } - } - ], - "responses":{ - "default":{ - "description":"successful operation" - } + "openapi": "3.0.0", + "info": { + "version": "1.0.0", + "title": "Swagger Petstore", + "license": { + "name": "MIT" + } + }, + "servers": [ + { + "url": "http://petstore.swagger.io/v1" + } + ], + "paths": { + "/pets": { + "get": { + "summary": "List all pets", + "operationId": "listPets", + "tags": [ + "pets" + ], + "parameters": [ + { + "name": "limit", + "in": "query", + "description": "How many items to return at one time (max 100)", + "required": false, + "schema": { + "type": "integer", + "format": "int32" } - } - }, - "/user/createWithArray":{ - "post":{ - "tags":[ - "user" - ], - "summary":"Creates list of users with given input array", - "description":"", - "operationId":"createUsersWithArrayInput", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"List of user object", - "required":true, - "schema":{ - "type":"array", - "items":{ - "$ref":"#/definitions/User" - } + } + ], + "responses": { + "200": { + "description": "A paged array of pets", + "headers": { + "x-next": { + "description": "A link to the next page of responses", + "schema": { + "type": "string" + } + } + }, + "content": { + "application/json": { + "schema": { + "type": "array", + "items": { + "type": "object", + "required": [ + "id", + "name" + ], + "properties": { + "id": { + "type": "integer", + "format": "int64" + }, + "name": { + "type": "string" + }, + "tag": { + "type": "string" + } + } } - } - ], - "responses":{ - "default":{ - "description":"successful operation" - } + } + } } - } - }, - "/user/createWithList":{ - "post":{ - "tags":[ - "user" - ], - "summary":"Creates list of users with given input array", - "description":"", - "operationId":"createUsersWithListInput", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"List of user object", - "required":true, - "schema":{ - "type":"array", - "items":{ - "$ref":"#/definitions/User" - } + }, + "default": { + "description": "unexpected error", + "content": { + "application/json": { + "schema": { + "type": "object", + "required": [ + "code", + "message" + ], + "properties": { + "code": { + "type": "integer", + "format": "int32" + }, + "message": { + "type": "string" + } } - } - ], - "responses":{ - "default":{ - "description":"successful operation" - } + } + } } - } + } + } }, - "/user/login":{ - "get":{ - "tags":[ - "user" - ], - "summary":"Logs user into the system", - "description":"", - "operationId":"loginUser", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"username", - "in":"query", - "description":"The user name for login", - "required":true, - "type":"string" - }, - { - "name":"password", - "in":"query", - "description":"The password for login in clear text", - "required":true, - "type":"string" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "type":"string" - }, - "headers":{ - "X-Rate-Limit":{ - "type":"integer", - "format":"int32", - "description":"calls per hour allowed by the user" - }, - "X-Expires-After":{ - "type":"string", - "format":"date-time", - "description":"date in UTC when toekn expires" - } + "post": { + "summary": "Create a pet", + "operationId": "createPets", + "tags": [ + "pets" + ], + "responses": { + "201": { + "description": "Null response" + }, + "default": { + "description": "unexpected error", + "content": { + "application/json": { + "schema": { + "type": "object", + "required": [ + "code", + "message" + ], + "properties": { + "code": { + "type": "integer", + "format": "int32" + }, + "message": { + "type": "string" + } } - }, - "400":{ - "description":"Invalid username/password supplied" - } + } + } } - } - }, - "/user/logout":{ - "get":{ - "tags":[ - "user" - ], - "summary":"Logs out current logged in user session", - "description":"", - "operationId":"logoutUser", - "produces":[ - "application/xml", - "application/json" - ], - "parameters": [], - "responses":{ - "default":{ - "description":"successful operation" - } + } + } + } + }, + "/pets/{petId}": { + "get": { + "summary": "Info for a specific pet", + "operationId": "showPetById", + "tags": [ + "pets" + ], + "parameters": [ + { + "name": "petId", + "in": "path", + "required": true, + "description": "The id of the pet to retrieve", + "schema": { + "type": "string" } - } - }, - "/user/{username}":{ - "get":{ - "tags":[ - "user" - ], - "summary":"Get user by user name", - "description":"", - "operationId":"getUserByName", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"username", - "in":"path", - "description":"The name that needs to be fetched. Use user1 for testing. ", - "required":true, - "type":"string" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "$ref":"#/definitions/User" + } + ], + "responses": { + "200": { + "description": "Expected response to a valid request", + "content": { + "application/json": { + "schema": { + "type": "object", + "required": [ + "id", + "name" + ], + "properties": { + "id": { + "type": "integer", + "format": "int64" + }, + "name": { + "type": "string" + }, + "tag": { + "type": "string" + } } - }, - "400":{ - "description":"Invalid username supplied" - }, - "404":{ - "description":"User not found" - } + } + } } - }, - "put":{ - "tags":[ - "user" - ], - "summary":"Updated user", - "description":"This can only be done by the logged in user.", - "operationId":"updateUser", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"username", - "in":"path", - "description":"name that need to be deleted", - "required":true, - "type":"string" - }, - { - "in":"body", - "name":"body", - "description":"Updated user object", - "required":true, - "schema":{ - "$ref":"#/definitions/User" + }, + "default": { + "description": "unexpected error", + "content": { + "application/json": { + "schema": { + "type": "object", + "required": [ + "code", + "message" + ], + "properties": { + "code": { + "type": "integer", + "format": "int32" + }, + "message": { + "type": "string" + } } - } - ], - "responses":{ - "400":{ - "description":"Invalid user supplied" - }, - "404":{ - "description":"User not found" - } + } + } } - }, - "delete":{ - "tags":[ - "user" - ], - "summary":"Delete user", - "description":"This can only be done by the logged in user.", - "operationId":"deleteUser", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"username", - "in":"path", - "description":"The name that needs to be deleted", - "required":true, - "type":"string" - } - ], - "responses":{ - "400":{ - "description":"Invalid username supplied" - }, - "404":{ - "description":"User not found" - } - } - } - } - }, - "securityDefinitions":{ - "petstore_auth":{ - "type":"oauth2", - "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog", - "flow":"implicit", - "scopes":{ - "write:pets":"modify pets in your account", - "read:pets":"read your pets" - } - }, - "api_key":{ - "type":"apiKey", - "name":"api_key", - "in":"header" + } + } } - }, - "definitions":{ - "Order":{ - "type":"object", - "properties":{ - "id":{ - "type":"integer", - "format":"int64" - }, - "petId":{ - "type":"integer", - "format":"int64" - }, - "quantity":{ - "type":"integer", - "format":"int32" - }, - "shipDate":{ - "type":"string", - "format":"date-time" - }, - "status":{ - "type":"string", - "description":"Order Status", - "enum":[ - "placed", - "approved", - "delivered" - ] - }, - "complete":{ - "type":"boolean", - "default":false - } - }, - "xml":{ - "name":"Order" - } - }, - "Category":{ - "type":"object", - "properties":{ - "id":{ - "type":"integer", - "format":"int64" - }, - "name":{ - "type":"string" - } - }, - "xml":{ - "name":"Category" - } - }, - "User":{ - "type":"object", - "properties":{ - "id":{ - "type":"integer", - "format":"int64" - }, - "username":{ - "type":"string" - }, - "firstName":{ - "type":"string" - }, - "lastName":{ - "type":"string" - }, - "email":{ - "type":"string" - }, - "password":{ - "type":"string" - }, - "phone":{ - "type":"string" - }, - "userStatus":{ - "type":"integer", - "format":"int32", - "description":"User Status" - } - }, - "xml":{ - "name":"User" - } - }, - "Tag":{ - "type":"object", - "properties":{ - "id":{ - "type":"integer", - "format":"int64" - }, - "name":{ - "type":"string" - } - }, - "xml":{ - "name":"Tag" - } + } + }, + "components": { + "schemas": { + "Pet": { + "type": "object", + "required": [ + "id", + "name" + ], + "properties": { + "id": { + "type": "integer", + "format": "int64" + }, + "name": { + "type": "string" + }, + "tag": { + "type": "string" + } + } }, - "Pet":{ - "type":"object", - "required":[ - "name", - "photoUrls" - ], - "properties":{ - "id":{ - "type":"integer", - "format":"int64" - }, - "category":{ - "$ref":"#/definitions/Category" - }, - "name":{ - "type":"string", - "example":"doggie" + "Pets": { + "type": "array", + "items": { + "type": "object", + "required": [ + "id", + "name" + ], + "properties": { + "id": { + "type": "integer", + "format": "int64" }, - "photoUrls":{ - "type":"array", - "xml":{ - "name":"photoUrl", - "wrapped":true - }, - "items":{ - "type":"string" - } + "name": { + "type": "string" }, - "tags":{ - "type":"array", - "xml":{ - "name":"tag", - "wrapped":true - }, - "items":{ - "$ref":"#/definitions/Tag" - } - }, - "status":{ - "type":"string", - "description":"pet status in the store", - "enum":[ - "available", - "pending", - "sold" - ] + "tag": { + "type": "string" } - }, - "xml":{ - "name":"Pet" - } + } + } }, - "ApiResponse":{ - "type":"object", - "properties":{ - "code":{ - "type":"integer", - "format":"int32" - }, - "type":{ - "type":"string" - }, - "message":{ - "type":"string" - } - } + "Error": { + "type": "object", + "required": [ + "code", + "message" + ], + "properties": { + "code": { + "type": "integer", + "format": "int32" + }, + "message": { + "type": "string" + } + } } - }, - "externalDocs":{ - "description":"Find out more about Swagger", - "url":"http://swagger.io" - } + } + } } |] @@ -1702,7 +933,7 @@ compositionSchemaExampleJSON = [aesonQQ| "type": "object", "allOf": [ { - "$ref": "#/definitions/Other" + "$ref": "#/components/schemas/Other" }, { "type": "object", diff --git a/test/SpecCommon.hs b/test/SpecCommon.hs index c8c2e960..e944091c 100644 --- a/test/SpecCommon.hs +++ b/test/SpecCommon.hs @@ -16,7 +16,7 @@ isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys) isSubJSON x y = x == y -(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec +(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec x <=> js = do it "encodes correctly" $ do toJSON x `shouldBe` js From 84f3156507a0564d0cb4df7146f741f161985643 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Fri, 26 Jun 2020 17:02:56 +0300 Subject: [PATCH 13/25] SchemaSpec passes --- test/Data/Swagger/CommonTestTypes.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/test/Data/Swagger/CommonTestTypes.hs b/test/Data/Swagger/CommonTestTypes.hs index a799c068..18714c88 100644 --- a/test/Data/Swagger/CommonTestTypes.hs +++ b/test/Data/Swagger/CommonTestTypes.hs @@ -88,7 +88,7 @@ paintSchemaJSON = [aesonQQ| { "color": { - "$ref": "#/definitions/Color" + "$ref": "#/components/schemas/Color" } }, "required": ["color"] @@ -181,7 +181,7 @@ userGroupSchemaJSON :: Value userGroupSchemaJSON = [aesonQQ| { "type": "array", - "items": { "$ref": "#/definitions/UserId" }, + "items": { "$ref": "#/components/schemas/UserId" }, "uniqueItems": true } |] @@ -228,7 +228,7 @@ playerSchemaJSON = [aesonQQ| { "position": { - "$ref": "#/definitions/Point" + "$ref": "#/components/schemas/Point" } }, "required": ["position"] @@ -250,7 +250,7 @@ playersSchemaJSON = [aesonQQ| { "position": { - "$ref": "#/definitions/Point" + "$ref": "#/components/schemas/Point" } }, "required": ["position"] @@ -274,14 +274,14 @@ characterSchemaJSON = [aesonQQ| "type": "object", "properties": { - "PC": { "$ref": "#/definitions/Player" }, + "PC": { "$ref": "#/components/schemas/Player" }, "NPC": { "type": "object", "properties": { "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/definitions/Point" } + "npcPosition": { "$ref": "#/components/schemas/Point" } }, "required": ["npcName", "npcPosition"] } @@ -353,7 +353,7 @@ characterInlinedPlayerSchemaJSON = [aesonQQ| { "position": { - "$ref": "#/definitions/Point" + "$ref": "#/components/schemas/Point" } }, "required": ["position"] @@ -364,7 +364,7 @@ characterInlinedPlayerSchemaJSON = [aesonQQ| "properties": { "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/definitions/Point" } + "npcPosition": { "$ref": "#/components/schemas/Point" } }, "required": ["npcName", "npcPosition"] } @@ -482,7 +482,7 @@ myRoseTreeSchemaJSON = [aesonQQ| "type": "array", "items": { - "$ref": "#/definitions/RoseTree" + "$ref": "#/components/schemas/RoseTree" } } }, @@ -511,7 +511,7 @@ myRoseTreeSchemaJSON' = [aesonQQ| "type": "array", "items": { - "$ref": "#/definitions/myrosetree'" + "$ref": "#/components/schemas/myrosetree'" } } }, @@ -553,7 +553,7 @@ lightSchemaJSON = [aesonQQ| { "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] }, "LightFreq": { "type": "number", "format": "double" }, - "LightColor": { "$ref": "#/definitions/Color" }, + "LightColor": { "$ref": "#/components/schemas/Color" }, "LightWaveLength": { "type": "number", "format": "double" } }, "maxProperties": 1, From 27079c750ea4521b2707f959d13b0f0793ef5089 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sat, 4 Jul 2020 14:51:03 +0300 Subject: [PATCH 14/25] Doctests pass --- src/Data/Swagger.hs | 49 ++++++------ src/Data/Swagger/Internal.hs | 4 +- src/Data/Swagger/Internal/Schema.hs | 74 +++++++++---------- .../Swagger/Internal/Schema/Validation.hs | 2 +- src/Data/Swagger/Operation.hs | 23 +++--- src/Data/Swagger/Optics.hs | 26 +++---- 6 files changed, 91 insertions(+), 87 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 0d4980af..59c830bf 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -134,6 +134,7 @@ import Data.Swagger.Internal -- >>> import Data.Monoid -- >>> import Data.Proxy -- >>> import GHC.Generics +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL -- >>> :set -XDeriveGeneric -- >>> :set -XOverloadedStrings -- >>> :set -XOverloadedLists @@ -150,8 +151,8 @@ import Data.Swagger.Internal -- -- In this library you can use @'mempty'@ for a default/empty value. For instance: -- --- >>> encode (mempty :: Swagger) --- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"}}" +-- >>> BSL.putStrLn $ encode (mempty :: Swagger) +-- {"openapi":"3.0.0","info":{"version":"","title":""},"components":{}} -- -- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty. -- That is because these properties are actually required ones. @@ -159,13 +160,13 @@ import Data.Swagger.Internal -- You /should/ always override the default (empty) value for these properties, -- although it is not strictly necessary: -- --- >>> encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" } --- "{\"version\":\"1.0\",\"title\":\"Todo API\"}" +-- >>> BSL.putStrLn $ encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" } +-- {"version":"1.0","title":"Todo API"} -- -- You can merge two values using @'mappend'@ or its infix version @('<>')@: -- --- >>> encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" } --- "{\"version\":\"1.0\",\"title\":\"Todo API\"}" +-- >>> BSL.putStrLn $ encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" } +-- {"version":"1.0","title":"Todo API"} -- -- This can be useful for combining specifications of endpoints into a whole API specification: -- @@ -191,15 +192,14 @@ import Data.Swagger.Internal -- make it fairly simple to construct/modify any part of the specification: -- -- >>> :{ --- encode $ (mempty :: Swagger) --- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ] +-- BSL.putStrLn $ encode $ (mempty :: Swagger) +-- & components . schemas .~ [ ("User", mempty & type_ ?~ SwaggerString) ] -- & paths .~ -- [ ("/user", mempty & get ?~ (mempty --- & produces ?~ MimeList ["application/json"] --- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User")) +-- & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (Reference "User"))) -- & at 404 ?~ "User info not found")) ] -- :} --- "{\"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\"}}}" +-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"User info not found"},"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/User"}}},"description":"OK"}}}}},"components":{"schemas":{"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 @@ -211,30 +211,33 @@ import Data.Swagger.Internal -- common field is @'description'@. Many components of a Swagger specification -- can have descriptions, and you can use the same name for them: -- --- >>> encode $ (mempty :: Response) & description .~ "No content" --- "{\"description\":\"No content\"}" +-- >>> BSL.putStrLn $ encode $ (mempty :: Response) & description .~ "No content" +-- {"description":"No content"} -- >>> :{ --- encode $ (mempty :: Schema) +-- BSL.putStrLn $ encode $ (mempty :: Schema) -- & type_ ?~ SwaggerBoolean -- & description ?~ "To be or not to be" -- :} --- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}" +-- {"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. -- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@: -- --- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber --- "{\"type\":\"number\"}" +-- >>> BSL.putStrLn $ encode $ (mempty :: Header) & type_ ?~ SwaggerNumber +-- {"schema":{"type":"number"}} +-- +-- TODO this is no up-to-date ^, since in openapi 3 there is no ParamSchema madness, all objects +-- have Schemas as fields. -- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@ -- have direct access to it via @'at' code@. Example: -- -- >>> :{ --- encode $ (mempty :: Operation) +-- BSL.putStrLn $ encode $ (mempty :: Operation) -- & at 404 ?~ "Not found" -- :} --- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}" +-- {"responses":{"404":{"description":"Not found"}}} -- -- You might've noticed that @'type_'@ has an extra underscore in its name -- compared to, say, @'description'@ field accessor. @@ -281,10 +284,10 @@ import Data.Swagger.Internal -- >>> data Person = Person { name :: String, age :: Integer } deriving Generic -- >>> instance ToJSON Person -- >>> instance ToSchema Person --- >>> encode (Person "David" 28) --- "{\"age\":28,\"name\":\"David\"}" --- >>> encode $ toSchema (Proxy :: Proxy Person) --- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}" +-- >>> BSL.putStrLn $ encode (Person "David" 28) +-- {"age":28,"name":"David"} +-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Person) +-- {"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"type":"integer"}},"type":"object"} -- -- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a -- schema for basic enums like diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 886b04f9..9f094819 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -1427,10 +1427,10 @@ instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where -- >>> decode "{}" :: Maybe (SwaggerItems 'SwaggerKindSchema) -- Just (SwaggerItemsArray []) -- --- >>> eitherDecode "{\"$ref\":\"#/definitions/example\"}" :: Either String (SwaggerItems 'SwaggerKindSchema) +-- >>> eitherDecode "{\"$ref\":\"#/components/schemas/example\"}" :: Either String (SwaggerItems 'SwaggerKindSchema) -- Right (SwaggerItemsObject (Ref (Reference {getReference = "example"}))) -- --- >>> eitherDecode "[{\"$ref\":\"#/definitions/example\"}]" :: Either String (SwaggerItems 'SwaggerKindSchema) +-- >>> eitherDecode "[{\"$ref\":\"#/components/schemas/example\"}]" :: Either String (SwaggerItems 'SwaggerKindSchema) -- Right (SwaggerItemsArray [Ref (Reference {getReference = "example"})]) -- instance FromJSON (SwaggerItems 'SwaggerKindSchema) where diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index 210cc856..23339258 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -67,7 +67,7 @@ import Data.Swagger.SchemaOptions import Data.Swagger.Internal.TypeShape import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL import GHC.TypeLits (TypeError, ErrorMessage(..)) unnamed :: Schema -> NamedSchema @@ -151,13 +151,13 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema -- -- >>> toNamedSchema (Proxy :: Proxy String) ^. name -- Nothing --- >>> encode (toNamedSchema (Proxy :: Proxy String) ^. schema) --- "{\"type\":\"string\"}" +-- >>> BSL.putStrLn $ encode (toNamedSchema (Proxy :: Proxy String) ^. schema) +-- {"type":"string"} -- -- >>> toNamedSchema (Proxy :: Proxy Day) ^. name -- Just "Day" --- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema) --- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}" +-- >>> BSL.putStrLn $ encode (toNamedSchema (Proxy :: Proxy Day) ^. schema) +-- {"example":"2016-07-22","format":"date","type":"string"} toNamedSchema :: ToSchema a => Proxy a -> NamedSchema toNamedSchema = undeclare . declareNamedSchema @@ -173,22 +173,22 @@ schemaName = _namedSchemaName . toNamedSchema -- | Convert a type into a schema. -- --- >>> encode $ toSchema (Proxy :: Proxy Int8) --- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}" +-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Int8) +-- {"maximum":127,"minimum":-128,"type":"integer"} -- --- >>> encode $ toSchema (Proxy :: Proxy [Day]) --- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}" +-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy [Day]) +-- {"items":{"$ref":"#/components/schemas/Day"},"type":"array"} toSchema :: ToSchema a => Proxy a -> Schema toSchema = _namedSchemaSchema . toNamedSchema -- | Convert a type into a referenced schema if possible. -- Only named schemas can be referenced, nameless schemas are inlined. -- --- >>> encode $ toSchemaRef (Proxy :: Proxy Integer) --- "{\"type\":\"integer\"}" +-- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Integer) +-- {"type":"integer"} -- --- >>> encode $ toSchemaRef (Proxy :: Proxy Day) --- "{\"$ref\":\"#/definitions/Day\"}" +-- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Day) +-- {"$ref":"#/components/schemas/Day"} toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema toSchemaRef = undeclare . declareSchemaRef @@ -256,8 +256,8 @@ inlineAllSchemas = inlineSchemasWhen (const True) -- | Convert a type into a schema without references. -- --- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day]) --- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}" +-- >>> BSL.putStrLn $ encode $ toInlinedSchema (Proxy :: Proxy [Day]) +-- {"items":{"example":"2016-07-22","format":"date","type":"string"},"type":"array"} -- -- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema -- when inlining recursive schemas. @@ -309,19 +309,19 @@ passwordSchema = mempty -- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance. -- Produced schema can be used for further refinement. -- --- >>> encode $ sketchSchema "hello" --- "{\"example\":\"hello\",\"type\":\"string\"}" +-- >>> BSL.putStrLn $ encode $ sketchSchema "hello" +-- {"example":"hello","type":"string"} -- --- >>> encode $ sketchSchema (1, 2, 3) --- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}" +-- >>> BSL.putStrLn $ encode $ sketchSchema (1, 2, 3) +-- {"example":[1,2,3],"items":{"type":"number"},"type":"array"} -- --- >>> encode $ sketchSchema ("Jack", 25) --- "{\"example\":[\"Jack\",25],\"items\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"type\":\"array\"}" +-- >>> BSL.putStrLn $ encode $ sketchSchema ("Jack", 25) +-- {"example":["Jack",25],"items":[{"type":"string"},{"type":"number"}],"type":"array"} -- -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person --- >>> encode $ sketchSchema (Person "Jack" 25) --- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}" +-- >>> BSL.putStrLn $ encode $ sketchSchema (Person "Jack" 25) +-- {"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 @@ -353,19 +353,19 @@ sketchSchema = sketch . toJSON -- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance. -- Produced schema uses as much constraints as possible. -- --- >>> encode $ sketchStrictSchema "hello" --- "{\"maxLength\":5,\"pattern\":\"hello\",\"minLength\":5,\"type\":\"string\",\"enum\":[\"hello\"]}" +-- >>> BSL.putStrLn $ encode $ sketchStrictSchema "hello" +-- {"maxLength":5,"pattern":"hello","minLength":5,"type":"string","enum":["hello"]} -- --- >>> encode $ sketchStrictSchema (1, 2, 3) --- "{\"minItems\":3,\"uniqueItems\":true,\"items\":[{\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\",\"enum\":[1]},{\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\",\"enum\":[2]},{\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\",\"enum\":[3]}],\"maxItems\":3,\"type\":\"array\",\"enum\":[[1,2,3]]}" +-- >>> BSL.putStrLn $ encode $ sketchStrictSchema (1, 2, 3) +-- {"minItems":3,"uniqueItems":true,"items":[{"maximum":1,"minimum":1,"multipleOf":1,"type":"number","enum":[1]},{"maximum":2,"minimum":2,"multipleOf":2,"type":"number","enum":[2]},{"maximum":3,"minimum":3,"multipleOf":3,"type":"number","enum":[3]}],"maxItems":3,"type":"array","enum":[[1,2,3]]} -- --- >>> encode $ sketchStrictSchema ("Jack", 25) --- "{\"minItems\":2,\"uniqueItems\":true,\"items\":[{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]},{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]}],\"maxItems\":2,\"type\":\"array\",\"enum\":[[\"Jack\",25]]}" +-- >>> BSL.putStrLn $ encode $ sketchStrictSchema ("Jack", 25) +-- {"minItems":2,"uniqueItems":true,"items":[{"maxLength":4,"pattern":"Jack","minLength":4,"type":"string","enum":["Jack"]},{"maximum":25,"minimum":25,"multipleOf":25,"type":"number","enum":[25]}],"maxItems":2,"type":"array","enum":[["Jack",25]]} -- -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person --- >>> encode $ sketchStrictSchema (Person "Jack" 25) --- "{\"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\"}]}" +-- >>> BSL.putStrLn $ encode $ sketchStrictSchema (Person "Jack" 25) +-- {"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 @@ -565,8 +565,8 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar -- | Default schema for @'Bounded'@, @'Integral'@ types. -- --- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16) --- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}" +-- >>> BSL.putStrLn $ encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16) +-- {"maximum":32767,"minimum":-32768,"type":"integer"} toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema toSchemaBoundedIntegral _ = mempty & type_ ?~ SwaggerInteger @@ -598,8 +598,8 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> -- >>> instance ToSchema ButtonState -- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show) -- >>> type ImageUrl = T.Text --- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) --- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}" +-- >>> BSL.putStrLn $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) +-- {"properties":{"Neutral":{"type":"string"},"Focus":{"type":"string"},"Active":{"type":"string"},"Hover":{"type":"string"},"Disabled":{"type":"string"}},"type":"object"} -- -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. @@ -626,8 +626,8 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o -- >>> instance ToSchema ButtonState -- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show) -- >>> type ImageUrl = T.Text --- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) --- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}" +-- >>> BSL.putStrLn $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) +-- {"properties":{"Neutral":{"type":"string"},"Focus":{"type":"string"},"Active":{"type":"string"},"Hover":{"type":"string"},"Disabled":{"type":"string"}},"type":"object"} -- -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs index abe7c169..ff73578e 100644 --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -109,7 +109,7 @@ validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checke -- "type": "object", -- "properties": { -- "phone": { --- "$ref": "#/definitions/Phone" +-- "$ref": "#/components/schemas/Phone" -- }, -- "name": { -- "type": "string" diff --git a/src/Data/Swagger/Operation.hs b/src/Data/Swagger/Operation.hs index c4f2c0bc..907ad4a2 100644 --- a/src/Data/Swagger/Operation.hs +++ b/src/Data/Swagger/Operation.hs @@ -53,13 +53,14 @@ import qualified Data.HashSet.InsOrd as InsOrdHS -- >>> import Data.Aeson -- >>> import Data.Proxy -- >>> import Data.Time +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL -- | Prepend path piece to all operations of the spec. -- Leading and trailing slashes are trimmed/added automatically. -- -- >>> let api = (mempty :: Swagger) & paths .~ [("/info", mempty)] --- >>> encode $ prependPath "user/{user_id}" api ^. paths --- "{\"/user/{user_id}/info\":{}}" +-- >>> BSL.putStrLn $ encode $ prependPath "user/{user_id}" api ^. paths +-- {"/user/{user_id}/info":{}} prependPath :: FilePath -> Swagger -> Swagger prependPath path = paths %~ InsOrdHashMap.mapKeys (path ) where @@ -80,10 +81,10 @@ allOperations = paths.traverse.template -- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK" -- >>> 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\":{\"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\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" +-- >>> BSL.putStrLn $ encode api +-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"200":{"description":"OK"}}},"post":{"responses":{"200":{"description":"OK"}}}}},"components":{}} +-- >>> BSL.putStrLn $ encode $ api & operationsOf sub . at 404 ?~ "Not found" +-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"Not found"},"200":{"description":"OK"}}},"post":{"responses":{"200":{"description":"OK"}}}}},"components":{}} operationsOf :: Swagger -> Traversal' Swagger Operation operationsOf sub = paths.itraversed.withIndex.subops where @@ -121,8 +122,8 @@ applyTagsFor ops ts swag = swag -- -- FIXME doc -- --- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty --- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]" +-- >>> BSL.putStrLn $ encode $ runDeclare (declareResponse "application/json" (Proxy :: Proxy Day)) mempty +-- [{"Day":{"example":"2016-07-22","format":"date","type":"string"}},{"description":"","content":{"application/json":{"schema":{"$ref":"#/components/schemas/Day"}}}}] declareResponse :: ToSchema a => Text -> Proxy a -> Declare (Definitions Schema) Response declareResponse cType proxy = do s <- declareSchemaRef proxy @@ -140,9 +141,9 @@ declareResponse cType proxy = do -- Example: -- -- >>> 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\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}" +-- >>> let res = declareResponse "application/json" (Proxy :: Proxy Day) +-- >>> BSL.putStrLn $ encode $ api & setResponse 200 res +-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/Day"}}},"description":""}}}}},"components":{"schemas":{"Day":{"example":"2016-07-22","format":"date","type":"string"}}}} -- -- See also @'setResponseWith'@. setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs index 3290651c..5da9e225 100644 --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -17,33 +17,33 @@ -- >>> import Data.Aeson -- >>> import Optics.Core -- >>> :set -XOverloadedLabels +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL -- -- Example from the "Data.Swagger" module using @optics@: -- -- >>> :{ --- encode $ (mempty :: Swagger) --- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ] +-- BSL.putStrLn $ encode $ (mempty :: Swagger) +-- & #components % #schemas .~ [ ("User", mempty & #type ?~ SwaggerString) ] -- & #paths .~ -- [ ("/user", mempty & #get ?~ (mempty --- & #produces ?~ MimeList ["application/json"] --- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User")) +-- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User"))) -- & at 404 ?~ "User info not found")) ] -- :} --- "{\"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\"}}}" +-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"User info not found"},"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/User"}}},"description":"OK"}}}}},"components":{"schemas":{"User":{"type":"string"}}}} -- -- For convenience optics are defined as /labels/. It means that field accessor -- names can be overloaded for different types. One such common field is -- @#description@. Many components of a Swagger specification can have -- descriptions, and you can use the same name for them: -- --- >>> encode $ (mempty :: Response) & #description .~ "No content" --- "{\"description\":\"No content\"}" +-- >>> BSL.putStrLn $ encode $ (mempty :: Response) & #description .~ "No content" +-- {"description":"No content"} -- >>> :{ --- encode $ (mempty :: Schema) +-- BSL.putStrLn $ encode $ (mempty :: Schema) -- & #type ?~ SwaggerBoolean -- & #description ?~ "To be or not to be" -- :} --- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}" +-- {"description":"To be or not to be","type":"boolean"} -- -- @'ParamSchema'@ is basically the /base schema specification/ and many types -- contain it. So for convenience, all @'ParamSchema'@ fields are transitively @@ -51,17 +51,17 @@ -- access @'SwaggerType'@ of @'Header'@ schema without having to use -- @#paramSchema@: -- --- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber --- "{\"type\":\"number\"}" +-- >>> BSL.putStrLn $ encode $ (mempty :: Header) & #type ?~ SwaggerNumber +-- {"schema":{"type":"number"}} -- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and -- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example: -- -- >>> :{ --- encode $ (mempty :: Operation) +-- BSL.putStrLn $ encode $ (mempty :: Operation) -- & at 404 ?~ "Not found" -- :} --- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}" +-- {"responses":{"404":{"description":"Not found"}}} -- module Data.Swagger.Optics () where From 73de3166fb941653258714223c9407183b746a4c Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sat, 4 Jul 2020 18:48:55 +0300 Subject: [PATCH 15/25] Implement schemas for sum types --- src/Data/Swagger.hs | 34 +- src/Data/Swagger/Internal/Schema.hs | 125 +++--- .../Swagger/Internal/Schema/Validation.hs | 52 ++- src/Data/Swagger/Schema.hs | 4 - src/Data/Swagger/Schema/Generator.hs | 10 +- src/Data/Swagger/SchemaOptions.hs | 6 +- test/Data/Swagger/CommonTestTypes.hs | 397 ++++++++++++++---- test/Data/Swagger/Schema/ValidationSpec.hs | 4 +- 8 files changed, 431 insertions(+), 201 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 59c830bf..440a4c64 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -289,39 +289,7 @@ import Data.Swagger.Internal -- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Person) -- {"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"type":"integer"}},"type":"object"} -- --- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a --- schema for basic enums like --- --- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic --- >>> instance ToSchema SampleEnum --- >>> instance ToJSON SampleEnum --- --- and for sum types that have constructors with values --- --- >>> data SampleSumType = ChoiceInt Int | ChoiceString String deriving Generic --- >>> instance ToSchema SampleSumType --- >>> instance ToJSON SampleSumType --- --- we can not derive a valid schema for a mix of the above. The following will result in a type error --- --- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic --- >>> instance ToSchema BadMixedType --- ... --- ... error: --- ... • Cannot derive Generic-based Swagger Schema for BadMixedType --- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors). --- ... Swagger does not have a good representation for these types. --- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema --- ... that matches aeson's Generic-based toJSON, --- ... but that's not supported by some Swagger tools. --- ... --- ... In the instance declaration for ‘ToSchema BadMixedType’ --- --- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON': --- --- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic --- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions --- >>> instance ToJSON BadMixedType +-- TODO mention oneOf -- -- $manipulation diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index 23339258..f7781548 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -22,12 +22,13 @@ module Data.Swagger.Internal.Schema where import Prelude () import Prelude.Compat -import Control.Lens +import Control.Lens hiding (allOf) import Data.Data.Lens (template) import Control.Monad import Control.Monad.Writer -import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..)) +import Data.Aeson (Object (..), SumEncoding (..), ToJSON (..), ToJSONKey (..), + ToJSONKeyFunction (..), Value (..)) import Data.Char import Data.Data (Data) import Data.Foldable (traverse_) @@ -41,6 +42,7 @@ import Data.IntSet (IntSet) import Data.IntMap (IntMap) import Data.List.NonEmpty.Compat (NonEmpty) import Data.Map (Map) +import Data.Maybe (fromMaybe) import Data.Proxy import Data.Scientific (Scientific) import Data.Fixed (Fixed, HasResolution, Pico) @@ -135,7 +137,7 @@ class ToSchema a where -- Note that the schema itself is included in definitions -- only if it is recursive (and thus needs its definition in scope). declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema - default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") => + default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => Proxy a -> Declare (Definitions Schema) NamedSchema declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions @@ -443,7 +445,9 @@ instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain instance ToSchema a => ToSchema (Maybe a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a) -instance (ToSchema a, ToSchema b) => ToSchema (Either a b) +instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where + -- To match Aeson instance + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField } instance ToSchema () where declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema) @@ -637,32 +641,17 @@ toSchemaBoundedEnumKeyMapping :: forall map key value. toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping -- | A configurable generic @'Schema'@ creator. -genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") => +genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema -genericDeclareSchema = genericDeclareSchemaUnrestricted +genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy -- | A configurable generic @'NamedSchema'@ creator. -- This function applied to @'defaultSchemaOptions'@ -- is used as the default for @'declareNamedSchema'@ -- when the type is an instance of @'Generic'@. -genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") => +genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema -genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted - --- | A configurable generic @'Schema'@ creator. --- --- Unlike 'genericDeclareSchema' also works for mixed sum types. --- Use with care since some Swagger tools do not support well schemas for mixed sum types. -genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema -genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy - --- | A configurable generic @'NamedSchema'@ creator. --- --- Unlike 'genericDeclareNamedSchema' also works for mixed sum types. --- Use with care since some Swagger tools do not support well schemas for mixed sum types. -genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) => - SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema -genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty +genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty -- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'. genericNameSchema :: forall a d f. @@ -791,56 +780,98 @@ instance ( GSumToSchema f , GSumToSchema g ) => GToSchema (f :+: g) where - gdeclareNamedSchema = gdeclareNamedSumSchema + -- Aeson does not unwrap unary record in sum types. + gdeclareNamedSchema opts p s = gdeclareNamedSumSchema (opts { unwrapUnaryRecords = False } )p s gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema -gdeclareNamedSumSchema opts proxy s - | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema) - | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema +gdeclareNamedSumSchema opts proxy _ + | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchemas) + | otherwise = do + (schemas, _) <- runWriterT declareSumSchema + return $ unnamed $ mempty + & type_ ?~ SwaggerObject + & oneOf ?~ (snd <$> schemas) where - declareSumSchema = gsumToSchema opts proxy s - (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema) + declareSumSchema = gsumToSchema opts proxy + (sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema) - toStringTag schema = mempty + toStringTag schemas = mempty & type_ ?~ SwaggerString - & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex) + & enum_ ?~ map (String . fst) sumSchemas type AllNullary = All class GSumToSchema (f :: * -> *) where - gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema + gsumToSchema :: SchemaOptions -> Proxy f -> WriterT AllNullary (Declare (Definitions Schema)) [(T.Text, Referenced 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) +-- | Convert one component of the sum to schema, to be later combined with @oneOf@. gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) => - Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema -gsumConToSchemaWith ref opts _ schema = schema - & type_ ?~ SwaggerObject - & properties . at tag ?~ ref - & maxProperties ?~ 1 - & minProperties ?~ 1 + Maybe (Referenced Schema) -> SchemaOptions -> Proxy (C1 c f) -> (T.Text, Referenced Schema) +gsumConToSchemaWith ref opts _ = (tag, schema) where + schema = case sumEncoding opts of + TaggedObject tagField contentsField -> + case ref of + -- If subschema is an object and constructor is a record, we add tag directly + -- to the record, as Aeson does it. + Just (Inline sub) | sub ^. type_ == Just SwaggerObject && isRecord -> Inline $ sub + & required <>~ [T.pack tagField] + & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag]) + + -- If it is not a record, we need to put subschema into "contents" field. + _ | not isRecord -> Inline $ mempty + & type_ ?~ SwaggerObject + & required .~ [T.pack tagField] + & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag]) + -- If constructor is nullary, there is no content. + & case ref of + Just r -> (properties . at (T.pack contentsField) ?~ r) . (required <>~ [T.pack contentsField]) + Nothing -> id + + -- In the remaining cases we combine "tag" object and "contents" object using allOf. + _ -> Inline $ mempty + & type_ ?~ SwaggerObject + & allOf ?~ [Inline $ mempty + & type_ ?~ SwaggerObject + & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField]) + & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])] + & if isRecord + then allOf . _Just <>~ [refOrNullary] + else allOf . _Just <>~ [Inline $ mempty & type_ ?~ SwaggerObject & properties . at (T.pack contentsField) ?~ refOrNullary] + UntaggedValue -> refOrEnum -- Aeson encodes nullary constructors as strings in this case. + ObjectWithSingleField -> Inline $ mempty + & type_ ?~ SwaggerObject + & required .~ [tag] + & properties . at tag ?~ refOrNullary + TwoElemArray -> error "unrepresentable in OpenAPI 3" + tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) + isRecord = conIsRecord (Proxy3 :: Proxy3 c f p) + refOrNullary = fromMaybe (Inline nullarySchema) ref + refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag]) ref gsumConToSchema :: (GToSchema (C1 c f), Constructor c) => - SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema -gsumConToSchema opts proxy schema = do + SchemaOptions -> Proxy (C1 c f) -> Declare (Definitions Schema) [(T.Text, Referenced Schema)] +gsumConToSchema opts proxy = do ref <- gdeclareSchemaRef opts proxy - return $ gsumConToSchemaWith ref opts proxy schema + return [gsumConToSchemaWith (Just ref) opts proxy] instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where - gsumToSchema opts proxy schema = do + gsumToSchema opts proxy = do tell (All False) - lift $ gsumConToSchema opts proxy schema + lift $ gsumConToSchema opts proxy instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where - gsumToSchema opts proxy schema = do + gsumToSchema opts proxy = do tell (All False) - lift $ gsumConToSchema opts proxy schema + lift $ gsumConToSchema opts proxy instance Constructor c => GSumToSchema (C1 c U1) where - gsumToSchema opts proxy = pure . gsumConToSchemaWith (Inline nullarySchema) opts proxy + gsumToSchema opts proxy = pure $ (:[]) $ gsumConToSchemaWith Nothing opts proxy data Proxy2 a b = Proxy2 diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs index ff73578e..c2e41e8a 100644 --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -12,6 +12,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module: Data.Swagger.Internal.Schema.Validation -- Copyright: (c) 2015 GetShopTV @@ -26,8 +27,8 @@ import Prelude () import Prelude.Compat import Control.Applicative -import Control.Lens -import Control.Monad (when) +import Control.Lens hiding (allOf) +import Control.Monad (forM, forM_, when) import Data.Aeson hiding (Result) import Data.Aeson.Encode.Pretty (encodePretty) @@ -473,22 +474,37 @@ inferParamSchemaTypes sch = concat validateSchemaType :: Value -> Validation Schema () validateSchemaType value = withSchema $ \sch -> - case (sch ^. type_, value) of - (Just SwaggerNull, Null) -> valid - (Just SwaggerBoolean, Bool _) -> valid - (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n) - (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n) - (Just SwaggerString, String s) -> sub_ paramSchema (validateString s) - (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs) - (Just SwaggerObject, Object o) -> validateObject o - (Nothing, Null) -> valid - (Nothing, Bool _) -> valid - -- Number by default - (Nothing, Number n) -> sub_ paramSchema (validateNumber n) - (Nothing, String s) -> sub_ paramSchema (validateString s) - (Nothing, Array xs) -> sub_ paramSchema (validateArray xs) - (Nothing, Object o) -> validateObject o - bad -> invalid $ "expected JSON value of type " ++ showType bad + case sch of + (view oneOf -> Just variants) -> do + res <- forM variants $ \var -> + (True <$ validateWithSchemaRef var value) <|> (return False) + case length $ filter id res of + 0 -> invalid $ "Value not valid under any of 'oneOf' schemas: " ++ show value + 1 -> valid + _ -> invalid $ "Value matches more than one of 'oneOf' schemas: " ++ show value + (view allOf -> Just variants) -> do + -- Default semantics for Validation Monad will abort when at least one + -- variant does not match. + forM_ variants $ \var -> + validateWithSchemaRef var value + + _ -> + case (sch ^. type_, value) of + (Just SwaggerNull, Null) -> valid + (Just SwaggerBoolean, Bool _) -> valid + (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n) + (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n) + (Just SwaggerString, String s) -> sub_ paramSchema (validateString s) + (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs) + (Just SwaggerObject, Object o) -> validateObject o + (Nothing, Null) -> valid + (Nothing, Bool _) -> valid + -- Number by default + (Nothing, Number n) -> sub_ paramSchema (validateNumber n) + (Nothing, String s) -> sub_ paramSchema (validateString s) + (Nothing, Array xs) -> sub_ paramSchema (validateArray xs) + (Nothing, Object o) -> validateObject o + bad -> invalid $ "expected JSON value of type " ++ showType bad validateParamSchemaType :: Value -> Validation (ParamSchema t) () validateParamSchemaType value = withSchema $ \sch -> diff --git a/src/Data/Swagger/Schema.hs b/src/Data/Swagger/Schema.hs index 1fa72b44..2e2043a8 100644 --- a/src/Data/Swagger/Schema.hs +++ b/src/Data/Swagger/Schema.hs @@ -32,10 +32,6 @@ module Data.Swagger.Schema ( paramSchemaToNamedSchema, paramSchemaToSchema, - -- ** Unrestricted versions - genericDeclareNamedSchemaUnrestricted, - genericDeclareSchemaUnrestricted, - -- * Schema templates passwordSchema, binarySchema, diff --git a/src/Data/Swagger/Schema/Generator.hs b/src/Data/Swagger/Schema/Generator.hs index a5cca577..faa8a9c4 100644 --- a/src/Data/Swagger/Schema/Generator.hs +++ b/src/Data/Swagger/Schema/Generator.hs @@ -30,6 +30,8 @@ import Test.QuickCheck.Property schemaGen :: Definitions Schema -> Schema -> Gen Value schemaGen _ schema | Just cases <- schema ^. paramSchema . enum_ = elements cases +schemaGen defns schema + | Just variants <- schema ^. oneOf = schemaGen defns =<< elements (dereference defns <$> variants) schemaGen defns schema = case schema ^. type_ of Nothing -> @@ -94,10 +96,10 @@ schemaGen defns schema = _ -> return [] x <- sequence $ gens <> additionalGens return . Object $ M.toHashMap x - where - dereference :: Definitions a -> Referenced a -> a - dereference _ (Inline a) = a - dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs + +dereference :: Definitions a -> Referenced a -> a +dereference _ (Inline a) = a +dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs genValue :: (ToSchema a) => Proxy a -> Gen Value genValue p = diff --git a/src/Data/Swagger/SchemaOptions.hs b/src/Data/Swagger/SchemaOptions.hs index 5abb9bdf..0f950225 100644 --- a/src/Data/Swagger/SchemaOptions.hs +++ b/src/Data/Swagger/SchemaOptions.hs @@ -22,6 +22,8 @@ data SchemaOptions = SchemaOptions , allNullaryToStringTag :: Bool -- | Hide the field name when a record constructor has only one field, like a newtype. , unwrapUnaryRecords :: Bool + -- | Specifies how to encode constructors of a sum datatype. + , sumEncoding :: Aeson.SumEncoding } -- | Default encoding @'SchemaOptions'@. @@ -33,6 +35,7 @@ data SchemaOptions = SchemaOptions -- , 'datatypeNameModifier' = id -- , 'allNullaryToStringTag' = True -- , 'unwrapUnaryRecords' = False +-- , 'sumEncoding' = 'Aeson.defaultTaggedObject' -- } -- @ defaultSchemaOptions :: SchemaOptions @@ -42,6 +45,7 @@ defaultSchemaOptions = SchemaOptions , datatypeNameModifier = id , allNullaryToStringTag = True , unwrapUnaryRecords = False + , sumEncoding = Aeson.defaultTaggedObject } -- | Convert 'Aeson.Options' to 'SchemaOptions'. @@ -56,7 +60,6 @@ defaultSchemaOptions = SchemaOptions -- Note that these fields have no effect on `SchemaOptions`: -- -- * 'Aeson.omitNothingFields' --- * 'Aeson.sumEncoding' -- * 'Aeson.tagSingleConstructors' -- -- The rest is defined as in 'defaultSchemaOptions'. @@ -69,4 +72,5 @@ fromAesonOptions opts = defaultSchemaOptions , constructorTagModifier = Aeson.constructorTagModifier opts , allNullaryToStringTag = Aeson.allNullaryToStringTag opts , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts + , sumEncoding = Aeson.sumEncoding opts } diff --git a/test/Data/Swagger/CommonTestTypes.hs b/test/Data/Swagger/CommonTestTypes.hs index 18714c88..9b6c8a60 100644 --- a/test/Data/Swagger/CommonTestTypes.hs +++ b/test/Data/Swagger/CommonTestTypes.hs @@ -271,106 +271,192 @@ instance ToSchema Character characterSchemaJSON :: Value characterSchemaJSON = [aesonQQ| { - "type": "object", - "properties": + "oneOf": [ { - "PC": { "$ref": "#/components/schemas/Player" }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/components/schemas/Point" } - }, - "required": ["npcName", "npcPosition"] + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "PC" + ] + }, + "contents": { + "$ref": "#/components/schemas/Player" } + } }, - "maxProperties": 1, - "minProperties": 1 + { + "required": [ + "npcName", + "npcPosition", + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "NPC" + ] + }, + "npcPosition": { + "$ref": "#/components/schemas/Point" + }, + "npcName": { + "type": "string" + } + } + } + ], + "type": "object" } + |] characterInlinedSchemaJSON :: Value characterInlinedSchemaJSON = [aesonQQ| { - "type": "object", - "properties": + "oneOf": [ { - "PC": - { + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "PC" + ] + }, + "contents": { + "required": [ + "position" + ], "type": "object", - "properties": - { - "position": - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] + "properties": { + "position": { + "required": [ + "x", + "y" + ], + "type": "object", + "properties": { + "x": { + "format": "double", + "type": "number" + }, + "y": { + "format": "double", + "type": "number" } - }, - "required": ["position"] + } + } + } + } + } + }, + { + "required": [ + "npcName", + "npcPosition", + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "NPC" + ] }, - "NPC": - { + "npcPosition": { + "required": [ + "x", + "y" + ], "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] - } + "properties": { + "x": { + "format": "double", + "type": "number" }, - "required": ["npcName", "npcPosition"] + "y": { + "format": "double", + "type": "number" + } + } + }, + "npcName": { + "type": "string" } - }, - "maxProperties": 1, - "minProperties": 1 + } + } + ], + "type": "object" } |] characterInlinedPlayerSchemaJSON :: Value characterInlinedPlayerSchemaJSON = [aesonQQ| { - "type": "object", - "properties": + "oneOf": [ { - "PC": - { - "type": "object", - "properties": - { - "position": - { - "$ref": "#/components/schemas/Point" - } - }, - "required": ["position"] + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "PC" + ] }, - "NPC": - { + "contents": { + "required": [ + "position" + ], "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/components/schemas/Point" } - }, - "required": ["npcName", "npcPosition"] + "properties": { + "position": { + "$ref": "#/components/schemas/Point" + } + } } + } }, - "maxProperties": 1, - "minProperties": 1 + { + "required": [ + "npcName", + "npcPosition", + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "NPC" + ] + }, + "npcPosition": { + "$ref": "#/components/schemas/Point" + }, + "npcName": { + "type": "string" + } + } + } + ], + "type": "object" } |] @@ -542,42 +628,169 @@ data Light deriving (Generic) instance ToSchema Light where - declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { unwrapUnaryRecords = True } lightSchemaJSON :: Value lightSchemaJSON = [aesonQQ| { - "type": "object", - "properties": + "oneOf": [ + { + "required": [ + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "NoLight" + ] + } + } + }, { - "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] }, - "LightFreq": { "type": "number", "format": "double" }, - "LightColor": { "$ref": "#/components/schemas/Color" }, - "LightWaveLength": { "type": "number", "format": "double" } + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightFreq" + ] + }, + "contents": { + "format": "double", + "type": "number" + } + } + }, + { + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightColor" + ] + }, + "contents": { + "$ref": "#/components/schemas/Color" + } + } }, - "maxProperties": 1, - "minProperties": 1 + { + "required": [ + "waveLength", + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightWaveLength" + ] + }, + "waveLength": { + "format": "double", + "type": "number" + } + } + } + ], + "type": "object" } |] lightInlinedSchemaJSON :: Value lightInlinedSchemaJSON = [aesonQQ| { - "type": "object", - "properties": + "oneOf": [ { - "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] }, - "LightFreq": { "type": "number", "format": "double" }, - "LightColor": - { + "required": [ + "tag" + ], + "type": "object", + "properties": { + "tag": { "type": "string", - "enum": ["Red", "Green", "Blue"] + "enum": [ + "NoLight" + ] + } + } + }, + { + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightFreq" + ] }, - "LightWaveLength": { "type": "number", "format": "double" } + "contents": { + "format": "double", + "type": "number" + } + } }, - "maxProperties": 1, - "minProperties": 1 + { + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightColor" + ] + }, + "contents": { + "type": "string", + "enum": [ + "Red", + "Green", + "Blue" + ] + } + } + }, + { + "required": [ + "waveLength", + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightWaveLength" + ] + }, + "waveLength": { + "format": "double", + "type": "number" + } + } + } + ], + "type": "object" } |] diff --git a/test/Data/Swagger/Schema/ValidationSpec.hs b/test/Data/Swagger/Schema/ValidationSpec.hs index beade4b3..404c3cdb 100644 --- a/test/Data/Swagger/Schema/ValidationSpec.hs +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -188,10 +188,10 @@ instance Arbitrary MyRoseTree where data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic) instance ToSchema Light where - declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { Data.Swagger.sumEncoding = ObjectWithSingleField } instance ToJSON Light where - toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField } + toJSON = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = ObjectWithSingleField } instance Arbitrary Light where arbitrary = oneof From 506f211b45a7c6e1088f69041dfd3605404d957c Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sat, 4 Jul 2020 19:22:11 +0300 Subject: [PATCH 16/25] Drop GHC 8.0 & 8.2 from cabal --- swagger2.cabal | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/swagger2.cabal b/swagger2.cabal index a24d8761..f2a96ff3 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -23,11 +23,9 @@ extra-source-files: , CHANGELOG.md , examples/*.hs tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 + GHC ==8.4.4 || ==8.6.5 - || ==8.8.1 + || ==8.8.3 || ==8.10.1 custom-setup @@ -59,16 +57,16 @@ library -- GHC boot libraries build-depends: - base >=4.9 && <4.15 - , bytestring >=0.10.8.1 && <0.11 - , containers >=0.5.7.1 && <0.7 - , template-haskell >=2.11.1.0 && <2.17 - , time >=1.6.0.1 && <1.10 - , transformers >=0.5.2.0 && <0.6 + base >=4.11.1.0 && <4.15 + , bytestring >=0.10.8.2 && <0.11 + , containers >=0.5.11.0 && <0.7 + , template-haskell >=2.13.0.0 && <2.17 + , time >=1.8.0.2 && <1.10 + , transformers >=0.5.5.0 && <0.6 build-depends: mtl >=2.2.2 && <2.3 - , text >=1.2.3.0 && <1.3 + , text >=1.2.3.1 && <1.3 -- other dependencies build-depends: From 5887ee33e4ebc3b41053192d0eef97efe0448f7a Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sat, 4 Jul 2020 19:22:49 +0300 Subject: [PATCH 17/25] haskell-ci regenerate --- .travis.yml | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/.travis.yml b/.travis.yml index cf3170f4..0678d7f9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -8,7 +8,7 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.10 +# version: 0.10.1 # version: ~> 1.0 language: c @@ -39,8 +39,8 @@ jobs: - compiler: ghc-8.10.1 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}} os: linux - - compiler: ghc-8.8.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.2"]}} + - compiler: ghc-8.8.3 + addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}} os: linux - compiler: ghc-8.6.5 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}} @@ -48,12 +48,6 @@ jobs: - compiler: ghc-8.4.4 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}} os: linux - - compiler: ghc-8.2.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.0.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}} - os: linux before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC" @@ -102,8 +96,8 @@ install: - touch cabal.project - | echo "packages: ." >> cabal.project - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package swagger2' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" + - echo 'package swagger2' >> cabal.project + - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" - | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true @@ -129,8 +123,8 @@ script: - touch cabal.project - | echo "packages: ${PKGDIR_swagger2}" >> cabal.project - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package swagger2' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" + - echo 'package swagger2' >> cabal.project + - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" - | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true @@ -146,10 +140,10 @@ script: # cabal check... - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check) # haddock... - - if [ $HCNUMVER -ge 80400 ] ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi + - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all # Building without installed constraints for packages in global-db... - rm -f cabal.project.local - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all -# REGENDATA ("0.10",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"]) +# REGENDATA ("0.10.1",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"]) # EOF From 55662c8083c4c79c0c1da6a78eb762ec7b6bb2bc Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Thu, 9 Jul 2020 11:54:25 +0300 Subject: [PATCH 18/25] Add tests for different SumEncoding flavors --- test/Data/Swagger/Schema/ValidationSpec.hs | 30 ++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/test/Data/Swagger/Schema/ValidationSpec.hs b/test/Data/Swagger/Schema/ValidationSpec.hs index 404c3cdb..5d06dd70 100644 --- a/test/Data/Swagger/Schema/ValidationSpec.hs +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -91,6 +91,8 @@ spec = do prop "Paint" $ shouldValidate (Proxy :: Proxy Paint) prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree) prop "Light" $ shouldValidate (Proxy :: Proxy Light) + prop "Light TaggedObject" $ shouldValidate (Proxy :: Proxy LightTaggedObject) + prop "Light UntaggedValue" $ shouldValidate (Proxy :: Proxy LightUntaggedValue) prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages) prop "Version" $ shouldValidate (Proxy :: Proxy Version) prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm) @@ -203,6 +205,34 @@ instance Arbitrary Light where invalidLightToJSON :: Light -> Value invalidLightToJSON = genericToJSON defaultOptions +-- Check all SumEncoding flavors. + +newtype LightTaggedObject = LightTaggedObject Light + deriving (Show) + +instance ToJSON LightTaggedObject where + toJSON (LightTaggedObject light) = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = defaultTaggedObject } light + +instance ToSchema LightTaggedObject where + declareNamedSchema _ = + genericDeclareNamedSchema defaultSchemaOptions { Data.Swagger.sumEncoding = defaultTaggedObject } (Proxy :: Proxy Light) + +instance Arbitrary LightTaggedObject where + arbitrary = LightTaggedObject <$> arbitrary + +newtype LightUntaggedValue = LightUntaggedValue Light + deriving (Show) + +instance ToJSON LightUntaggedValue where + toJSON (LightUntaggedValue light) = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = UntaggedValue } light + +instance ToSchema LightUntaggedValue where + declareNamedSchema _ = + genericDeclareNamedSchema defaultSchemaOptions { Data.Swagger.sumEncoding = UntaggedValue } (Proxy :: Proxy Light) + +instance Arbitrary LightUntaggedValue where + arbitrary = LightUntaggedValue <$> arbitrary + -- ======================================================================== -- ButtonImages (bounded enum key mapping) -- ======================================================================== From ee9223ec692f1ba6d2b7c7f420ccb7e54d144480 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Thu, 9 Jul 2020 14:27:30 +0300 Subject: [PATCH 19/25] Add style for parameters, remove kinds OpenAPI 3.0 unified schemas for parameters, now Parameter object directly references Schema object, and ParamSchema becomes not needed. Moreover, encoding of arrays and objects in parameters is now more uniform, using `style` property on the parameter itself. --- src/Data/Swagger.hs | 12 +- src/Data/Swagger/Internal.hs | 354 +++++------------- src/Data/Swagger/Internal/ParamSchema.hs | 24 +- src/Data/Swagger/Internal/Schema.hs | 2 +- .../Swagger/Internal/Schema/Validation.hs | 55 ++- src/Data/Swagger/Lens.hs | 45 +-- src/Data/Swagger/Optics.hs | 147 +------- test/Data/Swagger/ParamSchemaSpec.hs | 3 +- 8 files changed, 177 insertions(+), 465 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 440a4c64..0a8b3c2a 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -59,7 +59,7 @@ module Data.Swagger ( SwaggerType(..), Format, Definitions, - CollectionFormat(..), + Style(..), -- ** Parameters Param(..), @@ -220,16 +220,6 @@ import Data.Swagger.Internal -- :} -- {"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. --- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@: --- --- >>> BSL.putStrLn $ encode $ (mempty :: Header) & type_ ?~ SwaggerNumber --- {"schema":{"type":"number"}} --- --- TODO this is no up-to-date ^, since in openapi 3 there is no ParamSchema madness, all objects --- have Schemas as fields. --- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@ -- have direct access to it via @'at' code@. Example: -- diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 9f094819..a6577b8c 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -338,6 +338,29 @@ data MediaTypeObject = MediaTypeObject , _mediaTypeObjectEncoding :: InsOrdHashMap Text Encoding } deriving (Eq, Show, Generic, Data, Typeable) +-- | In order to support common ways of serializing simple parameters, a set of style values are defined. +data Style + = StyleMatrix + -- ^ Path-style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + | StyleLabel + -- ^ Label style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + | StyleForm + -- ^ Form style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + -- This option replaces @collectionFormat@ with a @csv@ (when @explode@ is false) or @multi@ + -- (when explode is true) value from OpenAPI 2.0. + | StyleSimple + -- ^ Simple style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + -- This option replaces @collectionFormat@ with a @csv@ value from OpenAPI 2.0. + | StyleSpaceDelimited + -- ^ Space separated array values. + -- This option replaces @collectionFormat@ equal to @ssv@ from OpenAPI 2.0. + | StylePipeDelimited + -- ^ Pipe separated array values. + -- This option replaces @collectionFormat@ equal to @pipes@ from OpenAPI 2.0. + | StyleDeepObject + -- ^ Provides a simple way of rendering nested objects using form parameters. + deriving (Eq, Show, Generic, Data, Typeable) + data Encoding = Encoding { -- | The Content-Type for encoding a specific property. -- Default value depends on the property type: for @string@ @@ -355,11 +378,11 @@ data Encoding = Encoding , _encodingHeaders :: InsOrdHashMap Text (Referenced Header) -- | Describes how a specific property value will be serialized depending on its type. - -- See Parameter Object for details on the style property. + -- See 'Param' Object for details on the style property. -- The behavior follows the same values as query parameters, including default values. -- This property SHALL be ignored if the request body media type -- is not @application/x-www-form-urlencoded@. - , _encodingStyle :: Maybe Text -- TODO enum + , _encodingStyle :: Maybe Style -- | When this is true, property values of type @array@ or @object@ generate -- separate parameters for each value of the array, @@ -424,10 +447,38 @@ data Param = Param -- | Sets the ability to pass empty-valued parameters. -- This is valid only for 'ParamQuery' parameters and allows sending -- a parameter with an empty value. Default value is @false@. - , _paramOtherSchemaAllowEmptyValue :: Maybe Bool + , _paramAllowEmptyValue :: Maybe Bool -- | Parameter schema. , _paramSchema :: Maybe (Referenced Schema) + + -- | Describes how the parameter value will be serialized depending + -- on the type of the parameter value. Default values (based on value of '_paramIn'): + -- for 'ParamQuery' - 'StyleForm'; for 'ParamPath' - 'StyleSimple'; for 'ParamHeader' - 'StyleSimple'; + -- for 'ParamCookie' - 'StyleForm'. + , _paramStyle :: Maybe Style + + -- | When this is true, parameter values of type @array@ or @object@ + -- generate separate parameters for each value of the array or key-value pair of the map. + -- For other types of parameters this property has no effect. + -- When style is @form@, the default value is true. For all other styles, the default value is false. + , _paramExplode :: Maybe Bool + + -- | Example of the parameter's potential value. + -- The example SHOULD match the specified schema and encoding properties if present. + -- The '_paramExample' field is mutually exclusive of the '_paramExamples' field. + -- Furthermore, if referencing a schema that contains an example, the example value + -- SHALL override the example provided by the schema. To represent examples of media types + -- that cannot naturally be represented in JSON or YAML, a string value can contain + -- the example with escaping where necessary. + , _paramExample :: Maybe Value + + -- | Examples of the parameter's potential value. + -- Each example SHOULD contain a value in the correct format as specified + -- in the parameter encoding. The '_paramExamples' field is mutually exclusive of the '_paramExample' field. + -- Furthermore, if referencing a schema that contains an example, + -- the examples value SHALL override the example provided by the schema. + , _paramExamples :: InsOrdHashMap Text (Referenced Example) } deriving (Eq, Show, Generic, Data, Typeable) data Example = Example @@ -454,136 +505,26 @@ data Example = Example -- | 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 . +-- __Warning__: OpenAPI 3.0 does not support tuple arrays. However, OpenAPI 3.1 will, as +-- it will incorporate Json Schema mostly verbatim. -- -- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s. -- -- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s. -data SwaggerItems t where - 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) -deriving instance Show (SwaggerItems t) ---deriving instance Typeable (SwaggerItems t) - -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] - --- 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 - --- 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 - --- TODO remove -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 'SwaggerKindParamOtherSchema - SwaggerNull :: SwaggerType 'SwaggerKindSchema - SwaggerObject :: SwaggerType 'SwaggerKindSchema - deriving (Typeable) - -deriving instance Eq (SwaggerType t) -deriving instance Show (SwaggerType t) - -swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr -swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix - -swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType -swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs - -swaggerCommonTypes :: [SwaggerType k] -swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray] - -swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema] -swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile] - -swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema] -swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject] - -swaggerTypeConstrs :: [Constr] -swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema]) - ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject] - -instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where - gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes - toConstr = swaggerTypeConstr - dataTypeOf = swaggerTypeDataType - -instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where - gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes - toConstr = swaggerTypeConstr - dataTypeOf = swaggerTypeDataType - -instance Data (SwaggerType 'SwaggerKindSchema) where - gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes - toConstr = swaggerTypeConstr - dataTypeOf = swaggerTypeDataType +data SwaggerItems where + SwaggerItemsObject :: Referenced Schema -> SwaggerItems + SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems + deriving (Eq, Show, Typeable, Data) + +data SwaggerType where + SwaggerString :: SwaggerType + SwaggerNumber :: SwaggerType + SwaggerInteger :: SwaggerType + SwaggerBoolean :: SwaggerType + SwaggerArray :: SwaggerType + SwaggerNull :: SwaggerType + SwaggerObject :: SwaggerType + deriving (Eq, Show, Typeable, Generic, Data) data ParamLocation = -- | Parameters that are appended to the URL. @@ -601,42 +542,6 @@ data ParamLocation type Format = Text --- | Determines the format of the array. -data CollectionFormat t where - -- Comma separated values: @foo,bar@. - CollectionCSV :: CollectionFormat t - -- Space separated values: @foo bar@. - CollectionSSV :: CollectionFormat t - -- Tab separated values: @foo\\tbar@. - CollectionTSV :: CollectionFormat t - -- Pipe separated values: @foo|bar@. - CollectionPipes :: CollectionFormat t - -- 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 'SwaggerKindParamOtherSchema - deriving (Typeable) - -deriving instance Eq (CollectionFormat t) -deriving instance Show (CollectionFormat t) - -collectionFormatConstr :: CollectionFormat t -> Constr -collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix - -collectionFormatDataType :: DataType -collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $ - map collectionFormatConstr collectionCommonFormats - -collectionCommonFormats :: [CollectionFormat t] -collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ] - -instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where - gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats - toConstr = collectionFormatConstr - dataTypeOf _ = collectionFormatDataType - -deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema) - type ParamName = Text data Schema = Schema @@ -663,7 +568,7 @@ data Schema = Schema , _schemaMaxProperties :: Maybe Integer , _schemaMinProperties :: Maybe Integer - , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema + , _schemaParamSchema :: ParamSchema } deriving (Eq, Show, Generic, Data, Typeable) data Discriminator = Discriminator @@ -684,7 +589,7 @@ data NamedSchema = NamedSchema -- | Regex pattern for @string@ type. type Pattern = Text -data ParamSchema (t :: SwaggerKind *) = ParamSchema +data ParamSchema = 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. @@ -692,9 +597,9 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema -- Unlike JSON Schema this value MUST conform to the defined type for this parameter. _paramSchemaDefault :: Maybe Value - , _paramSchemaType :: Maybe (SwaggerType t) + , _paramSchemaType :: Maybe SwaggerType , _paramSchemaFormat :: Maybe Format - , _paramSchemaItems :: Maybe (SwaggerItems t) + , _paramSchemaItems :: Maybe SwaggerItems , _paramSchemaMaximum :: Maybe Scientific , _paramSchemaExclusiveMaximum :: Maybe Bool , _paramSchemaMinimum :: Maybe Scientific @@ -707,9 +612,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema , _paramSchemaUniqueItems :: Maybe Bool , _paramSchemaEnum :: Maybe [Value] , _paramSchemaMultipleOf :: Maybe Scientific - } deriving (Eq, Show, Generic, Typeable) - -deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k) + } deriving (Eq, Show, Generic, Typeable, Data) data Xml = Xml { -- | Replaces the name of the element/attribute used for the described schema property. @@ -779,11 +682,13 @@ instance IsString Response where type HeaderName = Text + +-- TODO this is mostly a copy of 'Param'. data Header = Header { -- | A short description of the header. _headerDescription :: Maybe Text - , _headerSchema :: ParamSchema ('SwaggerKindNormal Header) + , _headerSchema :: Maybe (Referenced Schema) } deriving (Eq, Show, Generic, Data, Typeable) -- | The location of the API key. @@ -993,9 +898,9 @@ instance Monoid Schema where mempty = genericMempty mappend = (<>) -instance Semigroup (ParamSchema t) where +instance Semigroup ParamSchema where (<>) = genericMappend -instance Monoid (ParamSchema t) where +instance Monoid ParamSchema where mempty = genericMempty mappend = (<>) @@ -1093,7 +998,7 @@ instance SwaggerMonoid Info instance SwaggerMonoid Components instance SwaggerMonoid PathItem instance SwaggerMonoid Schema -instance SwaggerMonoid (ParamSchema t) +instance SwaggerMonoid ParamSchema instance SwaggerMonoid Param instance SwaggerMonoid Responses instance SwaggerMonoid Response @@ -1104,7 +1009,7 @@ instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a) instance SwaggerMonoid MimeList deriving instance SwaggerMonoid URL -instance SwaggerMonoid (SwaggerType t) where +instance SwaggerMonoid SwaggerType where swaggerMempty = SwaggerString swaggerMappend _ y = y @@ -1125,6 +1030,12 @@ instance Monoid a => SwaggerMonoid (Referenced a) where -- Simple Generic-based ToJSON instances -- ======================================================================= +instance ToJSON Style where + toJSON = genericToJSON (jsonPrefix "Style") + +instance ToJSON SwaggerType where + toJSON = genericToJSON (jsonPrefix "Swagger") + instance ToJSON ParamLocation where toJSON = genericToJSON (jsonPrefix "Param") @@ -1174,6 +1085,12 @@ instance ToJSON OAuth2AuthorizationCodeFlow where -- Simple Generic-based FromJSON instances -- ======================================================================= +instance FromJSON Style where + parseJSON = genericParseJSON (jsonPrefix "Style") + +instance FromJSON SwaggerType where + parseJSON = genericParseJSON (jsonPrefix "Swagger") + instance FromJSON ParamLocation where parseJSON = genericParseJSON (jsonPrefix "Param") @@ -1272,10 +1189,7 @@ instance ToJSON Header where -- >>> encode (SwaggerItemsArray []) -- "{\"example\":[],\"items\":{},\"maxItems\":0}" -- -instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where - toJSON (SwaggerItemsPrimitive fmt schema) = object - [ "collectionFormat" .= fmt - , "items" .= schema ] +instance ToJSON SwaggerItems where toJSON (SwaggerItemsObject x) = object [ "items" .= x ] toJSON (SwaggerItemsArray []) = object [ "items" .= object [] @@ -1344,24 +1258,7 @@ instance ToJSON (Referenced RequestBody) where toJSON = referencedToJSON "#/comp instance ToJSON (Referenced Example) where toJSON = referencedToJSON "#/components/examples/" instance ToJSON (Referenced Header) where toJSON = referencedToJSON "#/components/headers/" -instance ToJSON (SwaggerType t) where - toJSON SwaggerArray = "array" - toJSON SwaggerString = "string" - toJSON SwaggerInteger = "integer" - toJSON SwaggerNumber = "number" - toJSON SwaggerBoolean = "boolean" - toJSON SwaggerFile = "file" - toJSON SwaggerNull = "null" - toJSON SwaggerObject = "object" - -instance ToJSON (CollectionFormat t) where - toJSON CollectionCSV = "csv" - toJSON CollectionSSV = "ssv" - toJSON CollectionTSV = "tsv" - toJSON CollectionPipes = "pipes" - toJSON CollectionMulti = "multi" - -instance ToJSON (ParamSchema k) where +instance ToJSON ParamSchema where -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`? toJSON = sopSwaggerGenericToJSONWithOpts $ mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" @@ -1412,28 +1309,7 @@ instance FromJSON Schema where instance FromJSON Header where parseJSON = sopSwaggerGenericParseJSON -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 FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where - parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive - <$> o .:? "collectionFormat" - <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o)) - --- | --- --- >>> decode "{}" :: Maybe (SwaggerItems 'SwaggerKindSchema) --- Just (SwaggerItemsArray []) --- --- >>> eitherDecode "{\"$ref\":\"#/components/schemas/example\"}" :: Either String (SwaggerItems 'SwaggerKindSchema) --- Right (SwaggerItemsObject (Ref (Reference {getReference = "example"}))) --- --- >>> eitherDecode "[{\"$ref\":\"#/components/schemas/example\"}]" :: Either String (SwaggerItems 'SwaggerKindSchema) --- Right (SwaggerItemsArray [Ref (Reference {getReference = "example"})]) --- -instance FromJSON (SwaggerItems 'SwaggerKindSchema) where +instance FromJSON SwaggerItems where parseJSON js@(Object obj) | null obj = pure $ SwaggerItemsArray [] -- Nullary schema. | otherwise = SwaggerItemsObject <$> parseJSON js @@ -1506,30 +1382,7 @@ instance FromJSON (Referenced Header) where parseJSON = referencedParseJSON "# instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") -instance FromJSON (SwaggerType 'SwaggerKindSchema) where - parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject] - -instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where - parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile] - -instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where - parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray] - -instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where - parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] - --- 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] - -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 +instance FromJSON ParamSchema where parseJSON = sopSwaggerGenericParseJSON instance FromJSON AdditionalProperties where @@ -1571,17 +1424,12 @@ instance HasSwaggerAesonOptions Example where instance HasSwaggerAesonOptions Encoding where swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" -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 +instance HasSwaggerAesonOptions ParamSchema where swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" instance AesonDefaultValue Server instance AesonDefaultValue Components -instance AesonDefaultValue (ParamSchema s) +instance AesonDefaultValue ParamSchema instance AesonDefaultValue OAuth2ImplicitFlow instance AesonDefaultValue OAuth2PasswordFlow instance AesonDefaultValue OAuth2ClientCredentialsFlow @@ -1589,7 +1437,7 @@ instance AesonDefaultValue OAuth2AuthorizationCodeFlow instance AesonDefaultValue p => AesonDefaultValue (OAuth2Flow p) instance AesonDefaultValue Responses instance AesonDefaultValue SecuritySchemeType -instance AesonDefaultValue (SwaggerType a) +instance AesonDefaultValue SwaggerType instance AesonDefaultValue MimeList where defaultValue = Just mempty instance AesonDefaultValue Info instance AesonDefaultValue ParamLocation diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs index b927fb6f..0ca82019 100644 --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -50,20 +50,20 @@ import qualified Data.ByteString.Lazy as BSL import GHC.TypeLits (TypeError, ErrorMessage(..)) -- | Default schema for binary data (any sequence of octets). -binaryParamSchema :: ParamSchema t +binaryParamSchema :: ParamSchema binaryParamSchema = mempty & type_ ?~ SwaggerString & format ?~ "binary" -- | Default schema for binary data (base64 encoded). -byteParamSchema :: ParamSchema t +byteParamSchema :: ParamSchema byteParamSchema = mempty & type_ ?~ SwaggerString & format ?~ "byte" -- | Default schema for password string. -- @"password"@ format is used to hint UIs the input needs to be obscured. -passwordParamSchema :: ParamSchema t +passwordParamSchema :: ParamSchema passwordParamSchema = mempty & type_ ?~ SwaggerString & format ?~ "password" @@ -108,8 +108,8 @@ class ToParamSchema a where -- -- >>> encode $ toParamSchema (Proxy :: Proxy Integer) -- "{\"type\":\"integer\"}" - toParamSchema :: Proxy a -> ParamSchema t - default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t + toParamSchema :: Proxy a -> ParamSchema + default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema toParamSchema = genericToParamSchema defaultSchemaOptions instance {-# OVERLAPPING #-} ToParamSchema String where @@ -151,7 +151,7 @@ instance ToParamSchema Word64 where -- -- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8) -- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}" -toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t +toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema toParamSchemaBoundedIntegral _ = mempty & type_ ?~ SwaggerInteger & minimum_ ?~ fromInteger (toInteger (minBound :: a)) @@ -181,7 +181,7 @@ instance ToParamSchema Float where & type_ ?~ SwaggerNumber & format ?~ "float" -timeParamSchema :: String -> ParamSchema t +timeParamSchema :: String -> ParamSchema timeParamSchema fmt = mempty & type_ ?~ SwaggerString & format ?~ T.pack fmt @@ -236,7 +236,7 @@ type family ToParamSchemaByteStringError bs where ToParamSchemaByteStringError bs = TypeError ( 'Text "Impossible to have an instance " :<>: ShowType (ToParamSchema bs) :<>: Text "." :$$: 'Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead." - :$$: 'Text "Consider using byteParamSchema or binaryParamSchema templates." ) + :$$: 'Text "Consider using byteParamSchema or binaryParamSchemaemplates." ) instance ToParamSchemaByteStringError BS.ByteString => ToParamSchema BS.ByteString where toParamSchema = error "impossible" instance ToParamSchemaByteStringError BSL.ByteString => ToParamSchema BSL.ByteString where toParamSchema = error "impossible" @@ -254,7 +254,7 @@ instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = t instance ToParamSchema a => ToParamSchema [a] where toParamSchema _ = mempty & type_ ?~ SwaggerArray - & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a)) + & items ?~ SwaggerItemsObject (Inline $ mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)) instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a]) instance ToParamSchema a => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a]) @@ -287,11 +287,11 @@ instance ToParamSchema UUID where -- >>> data Color = Red | Blue deriving Generic -- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color) -- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}" -genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t +genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty class GToParamSchema (f :: * -> *) where - gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t + gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema -> ParamSchema instance GToParamSchema f => GToParamSchema (D1 d f) where gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f) @@ -309,7 +309,7 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g)) class GEnumParamSchema (f :: * -> *) where - genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t + genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema -> ParamSchema instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g) diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index f7781548..f56cc7ef 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -737,7 +737,7 @@ gdeclareSchemaRef opts proxy = do return $ Ref (Reference name) _ -> Inline <$> gdeclareSchema opts proxy -appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema) +appendItem :: Referenced Schema -> Maybe SwaggerItems -> Maybe SwaggerItems appendItem x Nothing = Just (SwaggerItemsArray [x]) appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x])) appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject" diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs index c2e41e8a..46f51007 100644 --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -298,23 +298,23 @@ validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js) -- | Validate JSON @'Value'@ with Swagger @'Schema'@. validateWithSchema :: Value -> Validation Schema () -validateWithSchema value = do - validateSchemaType value - sub_ paramSchema $ validateEnum value +validateWithSchema val = do + validateSchemaType val + sub_ paramSchema $ validateEnum val -- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@. -validateWithParamSchema :: Value -> Validation (ParamSchema t) () -validateWithParamSchema value = do - validateParamSchemaType value - validateEnum value +validateWithParamSchema :: Value -> Validation ParamSchema () +validateWithParamSchema val = do + validateParamSchemaType val + validateEnum val -validateInteger :: Scientific -> Validation (ParamSchema t) () +validateInteger :: Scientific -> Validation ParamSchema () validateInteger n = do when (not (isInteger n)) $ invalid ("not an integer") validateNumber n -validateNumber :: Scientific -> Validation (ParamSchema t) () +validateNumber :: Scientific -> Validation ParamSchema () validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do let exMax = Just True == sch ^. exclusiveMaximum exMin = Just True == sch ^. exclusiveMinimum @@ -331,7 +331,7 @@ validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do when (not (isInteger (n / k))) $ invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n) -validateString :: Text -> Validation (ParamSchema t) () +validateString :: Text -> Validation ParamSchema () validateString s = do check maxLength $ \n -> when (len > fromInteger n) $ @@ -348,7 +348,7 @@ validateString s = do where len = Text.length s -validateArray :: Vector Value -> Validation (ParamSchema t) () +validateArray :: Vector Value -> Validation ParamSchema () validateArray xs = do check maxItems $ \n -> when (len > fromInteger n) $ @@ -359,7 +359,6 @@ validateArray xs = do invalid ("array is too short (size should be >=" ++ show n ++ ")") check items $ \case - SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs SwaggerItemsArray itemSchemas -> do when (len /= length itemSchemas) $ @@ -419,11 +418,11 @@ validateObject o = withSchema $ \sch -> unknownProperty pname = invalid $ "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema" -validateEnum :: Value -> Validation (ParamSchema t) () -validateEnum value = do +validateEnum :: Value -> Validation ParamSchema () +validateEnum val = do check enum_ $ \xs -> - when (value `notElem` xs) $ - invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value) + when (val `notElem` xs) $ + invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show val) -- | Infer schema type based on used properties. -- @@ -431,7 +430,7 @@ validateEnum value = do -- -- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}" -- Just [SwaggerObject] -inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema] +inferSchemaTypes :: Schema -> [SwaggerType] inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++ [ SwaggerObject | any ($ sch) [ has (additionalProperties._Just) @@ -453,7 +452,7 @@ inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++ -- -- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}" -- Just [SwaggerInteger] -inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t] +inferParamSchemaTypes :: ParamSchema -> [SwaggerType] inferParamSchemaTypes sch = concat [ [ SwaggerArray | any ($ sch) [ has (items._Just) @@ -473,23 +472,23 @@ inferParamSchemaTypes sch = concat ] validateSchemaType :: Value -> Validation Schema () -validateSchemaType value = withSchema $ \sch -> +validateSchemaType val = withSchema $ \sch -> case sch of (view oneOf -> Just variants) -> do res <- forM variants $ \var -> - (True <$ validateWithSchemaRef var value) <|> (return False) + (True <$ validateWithSchemaRef var val) <|> (return False) case length $ filter id res of - 0 -> invalid $ "Value not valid under any of 'oneOf' schemas: " ++ show value + 0 -> invalid $ "Value not valid under any of 'oneOf' schemas: " ++ show val 1 -> valid - _ -> invalid $ "Value matches more than one of 'oneOf' schemas: " ++ show value + _ -> invalid $ "Value matches more than one of 'oneOf' schemas: " ++ show val (view allOf -> Just variants) -> do -- Default semantics for Validation Monad will abort when at least one -- variant does not match. forM_ variants $ \var -> - validateWithSchemaRef var value + validateWithSchemaRef var val _ -> - case (sch ^. type_, value) of + case (sch ^. type_, val) of (Just SwaggerNull, Null) -> valid (Just SwaggerBoolean, Bool _) -> valid (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n) @@ -506,9 +505,9 @@ validateSchemaType value = withSchema $ \sch -> (Nothing, Object o) -> validateObject o bad -> invalid $ "expected JSON value of type " ++ showType bad -validateParamSchemaType :: Value -> Validation (ParamSchema t) () -validateParamSchemaType value = withSchema $ \sch -> - case (sch ^. type_, value) of +validateParamSchemaType :: Value -> Validation ParamSchema () +validateParamSchemaType val = withSchema $ \sch -> + case (sch ^. type_, val) of (Just SwaggerBoolean, Bool _) -> valid (Just SwaggerInteger, Number n) -> validateInteger n (Just SwaggerNumber, Number n) -> validateNumber n @@ -521,7 +520,7 @@ validateParamSchemaType value = withSchema $ \sch -> (Nothing, Array xs) -> validateArray xs bad -> invalid $ "expected JSON value of type " ++ showType bad -showType :: (Maybe (SwaggerType t), Value) -> String +showType :: (Maybe SwaggerType, Value) -> String showType (Just ty, _) = show ty showType (Nothing, Null) = "SwaggerNull" showType (Nothing, Bool _) = "SwaggerBoolean" diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index cbe0f6b7..e9d297d4 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -68,7 +68,7 @@ makePrisms ''Referenced -- ** 'SwaggerItems' prisms -_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema] +_SwaggerItemsArray :: Review SwaggerItems [Referenced Schema] _SwaggerItemsArray = unto (\x -> SwaggerItemsArray x) {- \x -> case x of @@ -77,7 +77,7 @@ _SwaggerItemsArray SwaggerItemsArray a -> Right a -} -_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema) +_SwaggerItemsObject :: Review SwaggerItems (Referenced Schema) _SwaggerItemsObject = unto (\x -> SwaggerItemsObject x) {- \x -> case x of @@ -86,9 +86,6 @@ _SwaggerItemsObject SwaggerItemsArray a -> Left (SwaggerItemsArray a) -} -_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t) -_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p) - -- ============================================================= -- More helpful instances for easier access to schema properties @@ -104,77 +101,75 @@ instance At Responses where at n = responses . at n instance Ixed Operation where ix n = responses . ix n instance At Operation where at n = responses . at n -instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema +instance HasParamSchema NamedSchema ParamSchema where paramSchema = schema.paramSchema -- HasType instances -instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = schema.type_ -instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_ -instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_ +instance HasType Schema (Maybe SwaggerType) where type_ = paramSchema.type_ +instance HasType NamedSchema (Maybe SwaggerType) where type_ = paramSchema.type_ -- HasDefault instances -instance HasDefault Header (Maybe Value) where default_ = schema.default_ instance HasDefault Schema (Maybe Value) where default_ = paramSchema.default_ -- OVERLAPPABLE instances instance {-# OVERLAPPABLE #-} - HasParamSchema s (ParamSchema t) + HasParamSchema s ParamSchema => HasFormat s (Maybe Format) where format = paramSchema.format instance {-# OVERLAPPABLE #-} - HasParamSchema s (ParamSchema t) - => HasItems s (Maybe (SwaggerItems t)) where + HasParamSchema s ParamSchema + => HasItems s (Maybe SwaggerItems) where items = paramSchema.items instance {-# OVERLAPPABLE #-} - HasParamSchema s (ParamSchema t) + HasParamSchema s ParamSchema => HasMaximum s (Maybe Scientific) where maximum_ = paramSchema.maximum_ -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasExclusiveMaximum s (Maybe Bool) where exclusiveMaximum = paramSchema.exclusiveMaximum -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasMinimum s (Maybe Scientific) where minimum_ = paramSchema.minimum_ -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasExclusiveMinimum s (Maybe Bool) where exclusiveMinimum = paramSchema.exclusiveMinimum -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasMaxLength s (Maybe Integer) where maxLength = paramSchema.maxLength -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasMinLength s (Maybe Integer) where minLength = paramSchema.minLength -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasPattern s (Maybe Text) where pattern = paramSchema.pattern -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasMaxItems s (Maybe Integer) where maxItems = paramSchema.maxItems -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasMinItems s (Maybe Integer) where minItems = paramSchema.minItems -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasUniqueItems s (Maybe Bool) where uniqueItems = paramSchema.uniqueItems -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasEnum s (Maybe [Value]) where enum_ = paramSchema.enum_ -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema => HasMultipleOf s (Maybe Scientific) where multipleOf = paramSchema.multipleOf diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs index 5da9e225..692acc33 100644 --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -45,15 +45,6 @@ -- :} -- {"description":"To be or not to be","type":"boolean"} -- --- @'ParamSchema'@ is basically the /base schema specification/ and many types --- contain it. So for convenience, all @'ParamSchema'@ fields are transitively --- made fields of the type that has it. For example, you can use @#type@ to --- access @'SwaggerType'@ of @'Header'@ schema without having to use --- @#paramSchema@: --- --- >>> BSL.putStrLn $ encode $ (mempty :: Header) & #type ?~ SwaggerNumber --- {"schema":{"type":"number"}} --- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and -- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example: -- @@ -119,8 +110,8 @@ instance , b ~ [Referenced Schema] ) => LabelOptic "_SwaggerItemsArray" A_Review - (SwaggerItems 'SwaggerKindSchema) - (SwaggerItems 'SwaggerKindSchema) + SwaggerItems + SwaggerItems a b where labelOptic = unto (\x -> SwaggerItemsArray x) @@ -131,25 +122,13 @@ instance , b ~ Referenced Schema ) => LabelOptic "_SwaggerItemsObject" A_Review - (SwaggerItems 'SwaggerKindSchema) - (SwaggerItems 'SwaggerKindSchema) + SwaggerItems + SwaggerItems a b where labelOptic = unto (\x -> SwaggerItemsObject x) {-# INLINE labelOptic #-} -instance - ( a ~ (Maybe (CollectionFormat t), ParamSchema t) - , b ~ (Maybe (CollectionFormat t), ParamSchema t) - ) => LabelOptic "_SwaggerItemsPrimitive" - A_Review - (SwaggerItems t) - (SwaggerItems t) - a - b where - labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p) - {-# INLINE labelOptic #-} - -- ============================================================= -- More helpful instances for easier access to schema properties @@ -176,8 +155,8 @@ instance At Operation where -- #paramSchema instance - ( a ~ ParamSchema 'SwaggerKindSchema - , b ~ ParamSchema 'SwaggerKindSchema + ( a ~ ParamSchema + , b ~ ParamSchema ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where labelOptic = #schema % #paramSchema {-# INLINE labelOptic #-} @@ -185,34 +164,21 @@ instance -- #type instance - ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header)) - , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header)) - ) => LabelOptic "type" A_Lens Header Header a b where - labelOptic = #schema % #type - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe (SwaggerType 'SwaggerKindSchema) - , b ~ Maybe (SwaggerType 'SwaggerKindSchema) + ( a ~ Maybe SwaggerType + , b ~ Maybe SwaggerType ) => LabelOptic "type" A_Lens Schema Schema a b where labelOptic = #paramSchema % #type {-# INLINE labelOptic #-} instance - ( a ~ Maybe (SwaggerType 'SwaggerKindSchema) - , b ~ Maybe (SwaggerType 'SwaggerKindSchema) + ( a ~ Maybe SwaggerType + , b ~ Maybe SwaggerType ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where labelOptic = #paramSchema % #type {-# INLINE labelOptic #-} -- #default -instance - ( a ~ Maybe Value, b ~ Maybe Value - ) => LabelOptic "default" A_Lens Header Header a b where - labelOptic = #schema % #default - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Value, b ~ Maybe Value ) => LabelOptic "default" A_Lens Schema Schema a b where @@ -227,12 +193,6 @@ instance -- #format -instance - ( a ~ Maybe Format, b ~ Maybe Format - ) => LabelOptic "format" A_Lens Header Header a b where - labelOptic = #schema % #format - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Format, b ~ Maybe Format ) => LabelOptic "format" A_Lens Schema Schema a b where @@ -248,34 +208,21 @@ instance -- #items instance - ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header)) - , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header)) - ) => LabelOptic "items" A_Lens Header Header a b where - labelOptic = #schema % #items - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema) - , b ~ Maybe (SwaggerItems 'SwaggerKindSchema) + ( a ~ Maybe SwaggerItems + , b ~ Maybe SwaggerItems ) => LabelOptic "items" A_Lens Schema Schema a b where labelOptic = #paramSchema % #items {-# INLINE labelOptic #-} instance - ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema) - , b ~ Maybe (SwaggerItems 'SwaggerKindSchema) + ( a ~ Maybe SwaggerItems + , b ~ Maybe SwaggerItems ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where labelOptic = #paramSchema % #items {-# INLINE labelOptic #-} -- #maximum -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "maximum" A_Lens Header Header a b where - labelOptic = #schema % #maximum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "maximum" A_Lens Schema Schema a b where @@ -290,12 +237,6 @@ instance -- #exclusiveMaximum -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where - labelOptic = #schema % #exclusiveMaximum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where @@ -310,12 +251,6 @@ instance -- #minimum -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "minimum" A_Lens Header Header a b where - labelOptic = #schema % #minimum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "minimum" A_Lens Schema Schema a b where @@ -330,12 +265,6 @@ instance -- #exclusiveMinimum -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where - labelOptic = #schema % #exclusiveMinimum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where @@ -350,12 +279,6 @@ instance -- #maxLength -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxLength" A_Lens Header Header a b where - labelOptic = #schema % #maxLength - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "maxLength" A_Lens Schema Schema a b where @@ -370,12 +293,6 @@ instance -- #minLength -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minLength" A_Lens Header Header a b where - labelOptic = #schema % #minLength - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "minLength" A_Lens Schema Schema a b where @@ -390,12 +307,6 @@ instance -- #pattern -instance - ( a ~ Maybe Text, b ~ Maybe Text - ) => LabelOptic "pattern" A_Lens Header Header a b where - labelOptic = #schema % #pattern - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Text, b ~ Maybe Text ) => LabelOptic "pattern" A_Lens Schema Schema a b where @@ -410,12 +321,6 @@ instance -- #maxItems -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxItems" A_Lens Header Header a b where - labelOptic = #schema % #maxItems - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "maxItems" A_Lens Schema Schema a b where @@ -430,12 +335,6 @@ instance -- #minItems -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minItems" A_Lens Header Header a b where - labelOptic = #schema % #minItems - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "minItems" A_Lens Schema Schema a b where @@ -450,12 +349,6 @@ instance -- #uniqueItems -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "uniqueItems" A_Lens Header Header a b where - labelOptic = #schema % #uniqueItems - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where @@ -470,12 +363,6 @@ instance -- #enum -instance - ( a ~ Maybe [Value], b ~ Maybe [Value] - ) => LabelOptic "enum" A_Lens Header Header a b where - labelOptic = #schema % #enum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe [Value], b ~ Maybe [Value] ) => LabelOptic "enum" A_Lens Schema Schema a b where @@ -490,12 +377,6 @@ instance -- #multipleOf -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "multipleOf" A_Lens Header Header a b where - labelOptic = #schema % #multipleOf - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where diff --git a/test/Data/Swagger/ParamSchemaSpec.hs b/test/Data/Swagger/ParamSchemaSpec.hs index 07238641..3df569ae 100644 --- a/test/Data/Swagger/ParamSchemaSpec.hs +++ b/test/Data/Swagger/ParamSchemaSpec.hs @@ -13,7 +13,6 @@ import Data.Proxy import GHC.Generics import Data.Swagger -import Data.Swagger.Internal (SwaggerKind(..)) import Data.Swagger.CommonTestTypes import SpecCommon @@ -23,7 +22,7 @@ import Data.Time.LocalTime import qualified Data.HashMap.Strict as HM checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec -checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js +checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema) <=> js spec :: Spec spec = do From c9830deff53fcec8225434783cd6da73a235085f Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Thu, 9 Jul 2020 16:32:17 +0300 Subject: [PATCH 20/25] Use MediaType instead of plain Text --- src/Data/Swagger/Internal.hs | 82 ++++++++++++++++++++++++----------- src/Data/Swagger/Operation.hs | 3 +- 2 files changed, 58 insertions(+), 27 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index a6577b8c..52a84821 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -19,26 +19,29 @@ module Data.Swagger.Internal where import Prelude () import Prelude.Compat -import Control.Lens ((&), (.~), (?~)) import Control.Applicative -import Data.Aeson hiding (Encoding) -import qualified Data.Aeson.Types as JSON -import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex) -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet.InsOrd (InsOrdHashSet) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Monoid (Monoid (..)) -import Data.Semigroup.Compat (Semigroup (..)) -import Data.Scientific (Scientific) -import Data.String (IsString(..)) -import Data.Text (Text) -import qualified Data.Text as Text -import GHC.Generics (Generic) -import Network.Socket (HostName, PortNumber) -import Network.HTTP.Media (MediaType) -import Text.Read (readMaybe) +import Control.Lens ((&), (.~), (?~)) +import Data.Aeson hiding (Encoding) +import qualified Data.Aeson.Types as JSON +import Data.Data (Constr, Data (..), DataType, Fixity (..), Typeable, + constrIndex, mkConstr, mkDataType) +import Data.Hashable (Hashable (..)) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet.InsOrd (InsOrdHashSet) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid (Monoid (..)) +import Data.Scientific (Scientific) +import Data.Semigroup.Compat (Semigroup (..)) +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import GHC.Generics (Generic) +import Network.HTTP.Media (MediaType, mainType, parameters, parseAccept, subType, (//), + (/:)) +import Network.Socket (HostName, PortNumber) +import Text.Read (readMaybe) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap @@ -304,6 +307,22 @@ data Operation = Operation , _operationServers :: [Server] } deriving (Eq, Show, Generic, Data, Typeable) +-- This instance should be in @http-media@. +instance Data MediaType where + gunfold k z c = case constrIndex c of + 1 -> k (k (k (z (\main sub params -> foldl (/:) (main // sub) (Map.toList params))))) + _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MediaType." + + toConstr _ = mediaTypeConstr + + dataTypeOf _ = mediaTypeData + +mediaTypeConstr = mkConstr mediaTypeData "MediaType" [] Prefix +mediaTypeData = mkDataType "MediaType" [mediaTypeConstr] + +instance Hashable MediaType where + hashWithSalt salt mt = salt `hashWithSalt` show mt + -- | Describes a single request body. data RequestBody = RequestBody { -- | A brief description of the request body. This could contain examples of use. @@ -314,7 +333,7 @@ data RequestBody = RequestBody -- The key is a media type or media type range and the value describes it. -- For requests that match multiple keys, only the most specific key is applicable. -- e.g. @text/plain@ overrides @text/*@ - , _requestBodyContent :: InsOrdHashMap {-MediaType-} Text MediaTypeObject -- FIXME Data MediaType + , _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject , _requestBodyRequired :: Maybe Bool } deriving (Eq, Show, Generic, Data, Typeable) @@ -369,7 +388,7 @@ data Encoding = Encoding -- for array – the default is defined based on the inner type. -- The value can be a specific media type (e.g. @application/json@), -- a wildcard media type (e.g. @image/*@), or a comma-separated list of the two types. - _encodingContentType :: Maybe Text + _encodingContentType :: Maybe MediaType -- | A map allowing additional information to be provided as headers, -- for example @Content-Disposition@. @Content-Type@ is described separately @@ -417,9 +436,6 @@ instance Data MimeList where toConstr (MimeList _) = mimeListConstr dataTypeOf _ = mimeListDataType --- TODO style --- TODO example - -- | Describes a single operation parameter. -- A unique parameter is defined by a combination of a name and location. data Param = Param @@ -669,7 +685,7 @@ data Response = Response -- The key is a media type or media type range and the value describes it. -- For responses that match multiple keys, only the most specific key is applicable. -- e.g. @text/plain@ overrides @text/*@. - , _responseContent :: InsOrdHashMap Text MediaTypeObject + , _responseContent :: InsOrdHashMap MediaType MediaTypeObject -- | Maps a header name to its definition. , _responseHeaders :: InsOrdHashMap HeaderName (Referenced Header) @@ -1137,7 +1153,14 @@ instance FromJSON OAuth2AuthorizationCodeFlow where -- Manual ToJSON instances -- ======================================================================= -instance (Eq p, ToJSON p, AesonDefaultValue p) =>ToJSON (OAuth2Flow p) where +instance ToJSON MediaType where + toJSON = toJSON . show + toEncoding = toEncoding . show + +instance ToJSONKey MediaType where + toJSONKey = JSON.toJSONKeyText (Text.pack . show) + +instance (Eq p, ToJSON p, AesonDefaultValue p) => ToJSON (OAuth2Flow p) where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding @@ -1271,6 +1294,13 @@ instance ToJSON AdditionalProperties where -- Manual FromJSON instances -- ======================================================================= +instance FromJSON MediaType where + parseJSON = withText "MediaType" $ \str -> + maybe (fail $ "Invalid media type literal " <> Text.unpack str) pure $ parseAccept $ encodeUtf8 str + +instance FromJSONKey MediaType where + fromJSONKey = FromJSONKeyTextParser (parseJSON . String) + instance (Eq p, FromJSON p, AesonDefaultValue p) => FromJSON (OAuth2Flow p) where parseJSON = sopSwaggerGenericParseJSON diff --git a/src/Data/Swagger/Operation.hs b/src/Data/Swagger/Operation.hs index 907ad4a2..3a926c79 100644 --- a/src/Data/Swagger/Operation.hs +++ b/src/Data/Swagger/Operation.hs @@ -40,6 +40,7 @@ import Data.Maybe (mapMaybe) import Data.Proxy import qualified Data.Set as Set import Data.Text (Text) +import Network.HTTP.Media (MediaType) import Data.Swagger.Declare import Data.Swagger.Internal @@ -124,7 +125,7 @@ applyTagsFor ops ts swag = swag -- -- >>> BSL.putStrLn $ encode $ runDeclare (declareResponse "application/json" (Proxy :: Proxy Day)) mempty -- [{"Day":{"example":"2016-07-22","format":"date","type":"string"}},{"description":"","content":{"application/json":{"schema":{"$ref":"#/components/schemas/Day"}}}}] -declareResponse :: ToSchema a => Text -> Proxy a -> Declare (Definitions Schema) Response +declareResponse :: ToSchema a => MediaType -> Proxy a -> Declare (Definitions Schema) Response declareResponse cType proxy = do s <- declareSchemaRef proxy return (mempty & content.at cType ?~ (mempty & schema ?~ s)) From 23caa6464426c86e85037af1168447256d5ce260 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Fri, 10 Jul 2020 15:39:55 +0300 Subject: [PATCH 21/25] Add Callback and Link --- src/Data/Swagger.hs | 2 + src/Data/Swagger/Internal.hs | 95 +++++++++++++++++++++++++++++++++--- src/Data/Swagger/Lens.hs | 1 + src/Data/Swagger/Optics.hs | 1 + 4 files changed, 92 insertions(+), 7 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 0a8b3c2a..1a42c50f 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -86,6 +86,8 @@ module Data.Swagger ( Responses(..), Response(..), HttpStatusCode, + Link(..), + Callback(..), -- ** Security SecurityScheme(..), diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 52a84821..fccf84a1 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -196,8 +196,8 @@ data Components = Components , _componentsRequestBodies :: Definitions RequestBody , _componentsHeader :: Definitions Header , _componentsSecuritySchemes :: Definitions SecurityScheme --- , _componentsLinks --- , _componentsCallbacks + , _componentsLinks :: Definitions Link + , _componentsCallbacks :: Definitions Callback } deriving (Eq, Show, Generic, Data, Typeable) -- | Describes the operations available on a single path. @@ -287,7 +287,11 @@ data Operation = Operation -- | The list of possible responses as they are returned from executing this operation. , _operationResponses :: Responses - -- TODO callbacks + -- | A map of possible out-of band callbacks related to the parent operation. + -- The key is a unique identifier for the 'Callback' Object. + -- Each value in the map is a 'Callback' Object that describes a request + -- that may be initiated by the API provider and the expected responses. + , _operationCallbacks :: InsOrdHashMap Text (Referenced Callback) -- | Declares this operation to be deprecated. -- Usage of the declared operation should be refrained. @@ -519,6 +523,42 @@ data Example = Example , _exampleExternalValue :: Maybe URL } deriving (Eq, Show, Generic, Typeable, Data) +data ExpressionOrValue + = Expression Text + | Value Value + deriving (Eq, Show, Generic, Typeable, Data) + +-- | The Link object represents a possible design-time link for a response. +-- The presence of a link does not guarantee the caller's ability to successfully invoke it, +-- rather it provides a known relationship and traversal mechanism between responses and other operations. +data Link = Link + { -- | A relative or absolute URI reference to an OAS operation. + -- This field is mutually exclusive of the '_linkOperationId' field, + -- and MUST point to an 'Operation' Object. Relative '_linkOperationRef' + -- values MAY be used to locate an existing 'Operation' Object in the OpenAPI definition. + _linkOperationRef :: Maybe Text + + -- | The name of an /existing/, resolvable OAS operation, as defined with a unique + -- '_operationOperationId'. This field is mutually exclusive of the '_linkOperationRef' field. + , _linkOperationId :: Maybe Text + + -- | A map representing parameters to pass to an operation as specified with '_linkOperationId' + -- or identified via '_linkOperationRef'. The key is the parameter name to be used, whereas + -- the value can be a constant or an expression to be evaluated and passed to the linked operation. + -- The parameter name can be qualified using the parameter location @[{in}.]{name}@ + -- for operations that use the same parameter name in different locations (e.g. path.id). + , _linkParameters :: InsOrdHashMap Text ExpressionOrValue + + -- | A literal value or @{expression}@ to use as a request body when calling the target operation. + , _linkRequestBody :: Maybe ExpressionOrValue + + -- | A description of the link. + , _linkDescription :: Maybe Text + + -- | A server object to be used by the target operation. + , _linkServer :: Maybe Server + } deriving (Eq, Show, Generic, Typeable, Data) + -- | Items for @'SwaggerArray'@ schemas. -- -- __Warning__: OpenAPI 3.0 does not support tuple arrays. However, OpenAPI 3.1 will, as @@ -690,19 +730,29 @@ data Response = Response -- | Maps a header name to its definition. , _responseHeaders :: InsOrdHashMap HeaderName (Referenced Header) - -- TODO links + -- | A map of operations links that can be followed from the response. + -- The key of the map is a short name for the link, following the naming + -- constraints of the names for 'Component' Objects. + , _responseLinks :: InsOrdHashMap Text (Referenced Link) } deriving (Eq, Show, Generic, Data, Typeable) instance IsString Response where - fromString s = Response (fromString s) mempty mempty + fromString s = Response (fromString s) mempty mempty mempty + +-- | A map of possible out-of band callbacks related to the parent operation. +-- Each value in the map is a 'PathItem' Object that describes a set of requests that +-- may be initiated by the API provider and the expected responses. +-- The key value used to identify the path item object is an expression, evaluated at runtime, +-- that identifies a URL to use for the callback operation. +newtype Callback = Callback (InsOrdHashMap Text PathItem) + deriving (Eq, Show, Generic, Data, Typeable) type HeaderName = Text - -- TODO this is mostly a copy of 'Param'. data Header = Header { -- | A short description of the header. - _headerDescription :: Maybe Text + _headerDescription :: Maybe HeaderName , _headerSchema :: Maybe (Referenced Schema) } deriving (Eq, Show, Generic, Data, Typeable) @@ -873,6 +923,7 @@ deriveGeneric ''ParamSchema deriveGeneric ''Swagger deriveGeneric ''Example deriveGeneric ''Encoding +deriveGeneric ''Link -- ======================================================================= -- Monoid instances @@ -1264,6 +1315,10 @@ instance ToJSON Encoding where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON Link where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON SecurityDefinitions where toJSON (SecurityDefinitions sd) = toJSON sd @@ -1280,6 +1335,8 @@ instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/compone instance ToJSON (Referenced RequestBody) where toJSON = referencedToJSON "#/components/requestBodies/" instance ToJSON (Referenced Example) where toJSON = referencedToJSON "#/components/examples/" instance ToJSON (Referenced Header) where toJSON = referencedToJSON "#/components/headers/" +instance ToJSON (Referenced Link) where toJSON = referencedToJSON "#/components/links/" +instance ToJSON (Referenced Callback) where toJSON = referencedToJSON "#/components/callbacks/" instance ToJSON ParamSchema where -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`? @@ -1290,6 +1347,13 @@ instance ToJSON AdditionalProperties where toJSON (AdditionalPropertiesAllowed b) = toJSON b toJSON (AdditionalPropertiesSchema s) = toJSON s +instance ToJSON ExpressionOrValue where + toJSON (Expression expr) = toJSON expr + toJSON (Value val) = toJSON val + +instance ToJSON Callback where + toJSON (Callback ps) = toJSON ps + -- ======================================================================= -- Manual FromJSON instances -- ======================================================================= @@ -1385,6 +1449,9 @@ instance FromJSON MediaTypeObject where instance FromJSON Encoding where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON Link where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON Reference where parseJSON (Object o) = Reference <$> o .: "$ref" parseJSON _ = empty @@ -1408,6 +1475,8 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "# instance FromJSON (Referenced RequestBody) where parseJSON = referencedParseJSON "#/components/requestBodies/" instance FromJSON (Referenced Example) where parseJSON = referencedParseJSON "#/components/examples/" instance FromJSON (Referenced Header) where parseJSON = referencedParseJSON "#/components/headers/" +instance FromJSON (Referenced Link) where parseJSON = referencedParseJSON "#/components/links/" +instance FromJSON (Referenced Callback) where parseJSON = referencedParseJSON "#/components/callbacks/" instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") @@ -1419,6 +1488,14 @@ instance FromJSON AdditionalProperties where parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b parseJSON js = AdditionalPropertiesSchema <$> parseJSON js +-- | All strings are parsed as expressions +instance FromJSON ExpressionOrValue where + parseJSON (String expr) = pure $ Expression expr + parseJSON v = pure $ Value v + +instance FromJSON Callback where + parseJSON = fmap Callback . parseJSON + instance HasSwaggerAesonOptions Server where swaggerAesonOptions _ = mkSwaggerAesonOptions "server" instance HasSwaggerAesonOptions Components where @@ -1454,6 +1531,9 @@ instance HasSwaggerAesonOptions Example where instance HasSwaggerAesonOptions Encoding where swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" +instance HasSwaggerAesonOptions Link where + swaggerAesonOptions _ = mkSwaggerAesonOptions "link" + instance HasSwaggerAesonOptions ParamSchema where swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" @@ -1471,3 +1551,4 @@ instance AesonDefaultValue SwaggerType instance AesonDefaultValue MimeList where defaultValue = Just mempty instance AesonDefaultValue Info instance AesonDefaultValue ParamLocation +instance AesonDefaultValue Link diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index e9d297d4..70b30833 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -59,6 +59,7 @@ makeFields ''ExternalDocs makeFields ''Encoding makeFields ''Example makeFields ''Discriminator +makeFields ''Link -- * Prisms -- ** 'SecuritySchemeType' prisms diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs index 692acc33..d38c461f 100644 --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -97,6 +97,7 @@ makeFieldLabels ''ExternalDocs makeFieldLabels ''Encoding makeFieldLabels ''Example makeFieldLabels ''Discriminator +makeFieldLabels ''Link -- Prisms From 69788075a4a321505305ef79b57c183409c0c68f Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sun, 26 Jul 2020 14:00:51 +0300 Subject: [PATCH 22/25] Document OpenAPI 3 oneOf in examples --- src/Data/Swagger.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 1a42c50f..13e5fb62 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -281,8 +281,17 @@ import Data.Swagger.Internal -- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Person) -- {"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"type":"integer"}},"type":"object"} -- --- TODO mention oneOf +-- This package implements OpenAPI 3.0 spec, which supports @oneOf@ in schemas, allowing any sum types +-- to be faithfully represented. All sum encodings supported by @aeson@ are supported here as well, with +-- an exception of 'Data.Aeson.TwoElemArray', since OpenAPI spec does not support heterogeneous arrays. -- +-- An example with 'Data.Aeson.TaggedObject' encoding: +-- +-- >>> data Error = ErrorNoUser { userId :: Int } | ErrorAccessDenied { requiredPermission :: String } deriving Generic +-- >>> instance ToJSON Error +-- >>> instance ToSchema Error +-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Error) +-- {"oneOf":[{"required":["userId","tag"],"type":"object","properties":{"tag":{"type":"string","enum":["ErrorNoUser"]},"userId":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}}},{"required":["requiredPermission","tag"],"type":"object","properties":{"tag":{"type":"string","enum":["ErrorAccessDenied"]},"requiredPermission":{"type":"string"}}}],"type":"object"} -- $manipulation -- Sometimes you have to work with an imported or generated @'Swagger'@. From 4fd02b40618b109b86a30359d5e85ad4cb2fc7d4 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Mon, 3 Aug 2020 16:19:58 +0300 Subject: [PATCH 23/25] Fix typos, add more fields --- src/Data/Swagger/Internal.hs | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index fccf84a1..2cc41a7a 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -194,7 +194,7 @@ data Components = Components , _componentsParameters :: Definitions Param , _componentsExamples :: Definitions Example , _componentsRequestBodies :: Definitions RequestBody - , _componentsHeader :: Definitions Header + , _componentsHeaders :: Definitions Header , _componentsSecuritySchemes :: Definitions SecurityScheme , _componentsLinks :: Definitions Link , _componentsCallbacks :: Definitions Callback @@ -339,6 +339,8 @@ data RequestBody = RequestBody -- e.g. @text/plain@ overrides @text/*@ , _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject + -- | Determines if the request body is required in the request. + -- Defaults to 'False'. , _requestBodyRequired :: Maybe Bool } deriving (Eq, Show, Generic, Data, Typeable) @@ -499,6 +501,10 @@ data Param = Param -- Furthermore, if referencing a schema that contains an example, -- the examples value SHALL override the example provided by the schema. , _paramExamples :: InsOrdHashMap Text (Referenced Example) + + -- TODO + -- _paramContent :: InsOrdHashMap MediaType MediaTypeObject + -- should be singleton. mutually exclusive with _paramSchema. } deriving (Eq, Show, Generic, Data, Typeable) data Example = Example @@ -749,11 +755,20 @@ newtype Callback = Callback (InsOrdHashMap Text PathItem) type HeaderName = Text --- TODO this is mostly a copy of 'Param'. +-- | Header fields have the same meaning as for 'Param'. +-- +-- Style is always treated as 'StyleSimple', as it is the only value allowed for headers. data Header = Header { -- | A short description of the header. _headerDescription :: Maybe HeaderName + , _headerRequired :: Maybe Bool + , _headerDeprecated :: Maybe Bool + , _headerAllowEmptyValue :: Maybe Bool + , _headerExplode :: Maybe Bool + , _headerExample :: Maybe Value + , _headerExamples :: InsOrdHashMap Text (Referenced Example) + , _headerSchema :: Maybe (Referenced Schema) } deriving (Eq, Show, Generic, Data, Typeable) From 11f8f97ebb3ba7f8bda1a93af771ad9496e04115 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Mon, 3 Aug 2020 17:11:47 +0300 Subject: [PATCH 24/25] Merge ParamSchema into Schema --- src/Data/Swagger.hs | 5 +- src/Data/Swagger/Internal.hs | 85 ++++------- src/Data/Swagger/Internal/ParamSchema.hs | 38 +++-- src/Data/Swagger/Internal/Schema.hs | 33 +--- .../Swagger/Internal/Schema/Validation.hs | 38 ++--- src/Data/Swagger/Lens.hs | 68 ++++----- src/Data/Swagger/Optics.hs | 142 +++--------------- src/Data/Swagger/ParamSchema.hs | 6 +- src/Data/Swagger/Schema.hs | 5 - src/Data/Swagger/Schema/Generator.hs | 2 +- test/Data/Swagger/ParamSchemaSpec.hs | 2 +- 11 files changed, 129 insertions(+), 295 deletions(-) diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 13e5fb62..7f47729d 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -73,7 +73,6 @@ module Data.Swagger ( Encoding(..), -- ** Schemas - ParamSchema(..), Schema(..), NamedSchema(..), SwaggerItems(..), @@ -220,7 +219,7 @@ import Data.Swagger.Internal -- & type_ ?~ SwaggerBoolean -- & description ?~ "To be or not to be" -- :} --- {"description":"To be or not to be","type":"boolean"} +-- {"type":"boolean","description":"To be or not to be"} -- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@ -- have direct access to it via @'at' code@. Example: @@ -279,7 +278,7 @@ import Data.Swagger.Internal -- >>> BSL.putStrLn $ encode (Person "David" 28) -- {"age":28,"name":"David"} -- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Person) --- {"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"type":"integer"}},"type":"object"} +-- {"required":["name","age"],"type":"object","properties":{"age":{"type":"integer"},"name":{"type":"string"}}} -- -- This package implements OpenAPI 3.0 spec, which supports @oneOf@ in schemas, allowing any sum types -- to be faithfully represented. All sum encodings supported by @aeson@ are supported here as well, with diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 2cc41a7a..196c8313 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -630,9 +630,33 @@ data Schema = Schema , _schemaMaxProperties :: Maybe Integer , _schemaMinProperties :: Maybe Integer - , _schemaParamSchema :: 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. + -- (Note: "default" has no meaning for required parameters.) + -- Unlike JSON Schema this value MUST conform to the defined type for this parameter. + _schemaDefault :: Maybe Value + + , _schemaType :: Maybe SwaggerType + , _schemaFormat :: Maybe Format + , _schemaItems :: Maybe SwaggerItems + , _schemaMaximum :: Maybe Scientific + , _schemaExclusiveMaximum :: Maybe Bool + , _schemaMinimum :: Maybe Scientific + , _schemaExclusiveMinimum :: Maybe Bool + , _schemaMaxLength :: Maybe Integer + , _schemaMinLength :: Maybe Integer + , _schemaPattern :: Maybe Pattern + , _schemaMaxItems :: Maybe Integer + , _schemaMinItems :: Maybe Integer + , _schemaUniqueItems :: Maybe Bool + , _schemaEnum :: Maybe [Value] + , _schemaMultipleOf :: Maybe Scientific } deriving (Eq, Show, Generic, Data, Typeable) +-- | Regex pattern for @string@ type. +type Pattern = Text + data Discriminator = Discriminator { -- | The name of the property in the payload that will hold the discriminator value. _discriminatorPropertyName :: Text @@ -648,34 +672,6 @@ data NamedSchema = NamedSchema , _namedSchemaSchema :: Schema } deriving (Eq, Show, Generic, Data, Typeable) --- | Regex pattern for @string@ type. -type Pattern = Text - -data ParamSchema = 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. - -- (Note: "default" has no meaning for required parameters.) - -- Unlike JSON Schema this value MUST conform to the defined type for this parameter. - _paramSchemaDefault :: Maybe Value - - , _paramSchemaType :: Maybe SwaggerType - , _paramSchemaFormat :: Maybe Format - , _paramSchemaItems :: Maybe SwaggerItems - , _paramSchemaMaximum :: Maybe Scientific - , _paramSchemaExclusiveMaximum :: Maybe Bool - , _paramSchemaMinimum :: Maybe Scientific - , _paramSchemaExclusiveMinimum :: Maybe Bool - , _paramSchemaMaxLength :: Maybe Integer - , _paramSchemaMinLength :: Maybe Integer - , _paramSchemaPattern :: Maybe Pattern - , _paramSchemaMaxItems :: Maybe Integer - , _paramSchemaMinItems :: Maybe Integer - , _paramSchemaUniqueItems :: Maybe Bool - , _paramSchemaEnum :: Maybe [Value] - , _paramSchemaMultipleOf :: Maybe Scientific - } deriving (Eq, Show, Generic, Typeable, Data) - data Xml = Xml { -- | Replaces the name of the element/attribute used for the described schema property. -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list. @@ -934,7 +930,6 @@ deriveGeneric ''MediaTypeObject deriveGeneric ''Responses deriveGeneric ''SecurityScheme deriveGeneric ''Schema -deriveGeneric ''ParamSchema deriveGeneric ''Swagger deriveGeneric ''Example deriveGeneric ''Encoding @@ -980,12 +975,6 @@ instance Monoid Schema where mempty = genericMempty mappend = (<>) -instance Semigroup ParamSchema where - (<>) = genericMappend -instance Monoid ParamSchema where - mempty = genericMempty - mappend = (<>) - instance Semigroup Param where (<>) = genericMappend instance Monoid Param where @@ -1080,7 +1069,6 @@ instance SwaggerMonoid Info instance SwaggerMonoid Components instance SwaggerMonoid PathItem instance SwaggerMonoid Schema -instance SwaggerMonoid ParamSchema instance SwaggerMonoid Param instance SwaggerMonoid Responses instance SwaggerMonoid Response @@ -1265,8 +1253,8 @@ instance ToJSON SecurityScheme where toEncoding = sopSwaggerGenericToEncoding instance ToJSON Schema where - toJSON = sopSwaggerGenericToJSON - toEncoding = sopSwaggerGenericToEncoding + toJSON = sopSwaggerGenericToJSONWithOpts $ + mkSwaggerAesonOptions "schema" & saoSubObject ?~ "items" instance ToJSON Header where toJSON = sopSwaggerGenericToJSON @@ -1353,11 +1341,6 @@ instance ToJSON (Referenced Header) where toJSON = referencedToJSON "#/compone instance ToJSON (Referenced Link) where toJSON = referencedToJSON "#/components/links/" instance ToJSON (Referenced Callback) where toJSON = referencedToJSON "#/components/callbacks/" -instance ToJSON ParamSchema where - -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`? - toJSON = sopSwaggerGenericToJSONWithOpts $ - mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" - instance ToJSON AdditionalProperties where toJSON (AdditionalPropertiesAllowed b) = toJSON b toJSON (AdditionalPropertiesSchema s) = toJSON s @@ -1409,10 +1392,11 @@ instance FromJSON SecurityScheme where instance FromJSON Schema where parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON where nullaryCleanup :: Schema -> Schema - nullaryCleanup s@Schema{_schemaParamSchema=ps} = - if _paramSchemaItems ps == Just (SwaggerItemsArray []) + nullaryCleanup s = + if _schemaItems s == Just (SwaggerItemsArray []) then s { _schemaExample = Nothing - , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } } + , _schemaMaxItems = Nothing + } else s instance FromJSON Header where @@ -1496,9 +1480,6 @@ instance FromJSON (Referenced Callback) where parseJSON = referencedParseJSON "# instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") -instance FromJSON ParamSchema where - parseJSON = sopSwaggerGenericParseJSON - instance FromJSON AdditionalProperties where parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b parseJSON js = AdditionalPropertiesSchema <$> parseJSON js @@ -1549,12 +1530,8 @@ instance HasSwaggerAesonOptions Encoding where instance HasSwaggerAesonOptions Link where swaggerAesonOptions _ = mkSwaggerAesonOptions "link" -instance HasSwaggerAesonOptions ParamSchema where - swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" - instance AesonDefaultValue Server instance AesonDefaultValue Components -instance AesonDefaultValue ParamSchema instance AesonDefaultValue OAuth2ImplicitFlow instance AesonDefaultValue OAuth2PasswordFlow instance AesonDefaultValue OAuth2ClientCredentialsFlow diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs index 0ca82019..30818bf2 100644 --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -50,25 +50,31 @@ import qualified Data.ByteString.Lazy as BSL import GHC.TypeLits (TypeError, ErrorMessage(..)) -- | Default schema for binary data (any sequence of octets). -binaryParamSchema :: ParamSchema -binaryParamSchema = mempty +binarySchema :: Schema +binarySchema = mempty & type_ ?~ SwaggerString & format ?~ "binary" -- | Default schema for binary data (base64 encoded). -byteParamSchema :: ParamSchema -byteParamSchema = mempty +byteSchema :: Schema +byteSchema = mempty & type_ ?~ SwaggerString & format ?~ "byte" -- | Default schema for password string. -- @"password"@ format is used to hint UIs the input needs to be obscured. -passwordParamSchema :: ParamSchema -passwordParamSchema = mempty +passwordSchema :: Schema +passwordSchema = mempty & type_ ?~ SwaggerString & format ?~ "password" --- | Convert a type into a plain @'ParamSchema'@. +-- | Convert a type into a plain @'Schema'@. +-- +-- In previous versions of the package there was a separate type called @ParamSchema@, which was +-- included in a greater 'Schema'. Now this is a single class, but distinction for schema generators +-- for "simple" types is preserved. +-- +-- 'ToParamSchema' is suited only for primitive-like types without nested fields and such. -- -- An example type and instance: -- @@ -108,8 +114,8 @@ class ToParamSchema a where -- -- >>> encode $ toParamSchema (Proxy :: Proxy Integer) -- "{\"type\":\"integer\"}" - toParamSchema :: Proxy a -> ParamSchema - default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema + toParamSchema :: Proxy a -> Schema + default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> Schema toParamSchema = genericToParamSchema defaultSchemaOptions instance {-# OVERLAPPING #-} ToParamSchema String where @@ -151,7 +157,7 @@ instance ToParamSchema Word64 where -- -- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8) -- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}" -toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema +toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema toParamSchemaBoundedIntegral _ = mempty & type_ ?~ SwaggerInteger & minimum_ ?~ fromInteger (toInteger (minBound :: a)) @@ -181,7 +187,7 @@ instance ToParamSchema Float where & type_ ?~ SwaggerNumber & format ?~ "float" -timeParamSchema :: String -> ParamSchema +timeParamSchema :: String -> Schema timeParamSchema fmt = mempty & type_ ?~ SwaggerString & format ?~ T.pack fmt @@ -254,7 +260,7 @@ instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = t instance ToParamSchema a => ToParamSchema [a] where toParamSchema _ = mempty & type_ ?~ SwaggerArray - & items ?~ SwaggerItemsObject (Inline $ mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)) + & items ?~ SwaggerItemsObject (Inline $ toParamSchema (Proxy :: Proxy a)) instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a]) instance ToParamSchema a => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a]) @@ -281,17 +287,17 @@ instance ToParamSchema UUID where & type_ ?~ SwaggerString & format ?~ "uuid" --- | A configurable generic @'ParamSchema'@ creator. +-- | A configurable generic @'Schema'@ creator. -- -- >>> :set -XDeriveGeneric -- >>> data Color = Red | Blue deriving Generic -- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color) -- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}" -genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema +genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty class GToParamSchema (f :: * -> *) where - gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema -> ParamSchema + gtoParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema instance GToParamSchema f => GToParamSchema (D1 d f) where gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f) @@ -309,7 +315,7 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g)) class GEnumParamSchema (f :: * -> *) where - genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema -> ParamSchema + genumParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g) diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index f56cc7ef..0e5df74d 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -289,25 +289,6 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs traverse_ usedNames (InsOrdHashMap.lookup name defs) Inline subschema -> usedNames subschema --- | Default schema for binary data (any sequence of octets). -binarySchema :: Schema -binarySchema = mempty - & type_ ?~ SwaggerString - & format ?~ "binary" - --- | Default schema for binary data (base64 encoded). -byteSchema :: Schema -byteSchema = mempty - & type_ ?~ SwaggerString - & format ?~ "byte" - --- | Default schema for password string. --- @"password"@ format is used to hint UIs the input needs to be obscured. -passwordSchema :: Schema -passwordSchema = mempty - & type_ ?~ SwaggerString - & format ?~ "password" - -- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance. -- Produced schema can be used for further refinement. -- @@ -323,7 +304,7 @@ passwordSchema = mempty -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person -- >>> BSL.putStrLn $ encode $ sketchSchema (Person "Jack" 25) --- {"required":["age","name"],"properties":{"age":{"type":"number"},"name":{"type":"string"}},"example":{"age":25,"name":"Jack"},"type":"object"} +-- {"example":{"age":25,"name":"Jack"},"required":["age","name"],"type":"object","properties":{"age":{"type":"number"},"name":{"type":"string"}}} sketchSchema :: ToJSON a => a -> Schema sketchSchema = sketch . toJSON where @@ -367,7 +348,7 @@ sketchSchema = sketch . toJSON -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person -- >>> BSL.putStrLn $ encode $ sketchStrictSchema (Person "Jack" 25) --- {"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"}]} +-- {"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"]}}} sketchStrictSchema :: ToJSON a => a -> Schema sketchStrictSchema = go . toJSON where @@ -603,7 +584,7 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> -- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show) -- >>> type ImageUrl = T.Text -- >>> BSL.putStrLn $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) --- {"properties":{"Neutral":{"type":"string"},"Focus":{"type":"string"},"Active":{"type":"string"},"Hover":{"type":"string"},"Disabled":{"type":"string"}},"type":"object"} +-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}} -- -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. @@ -631,7 +612,7 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o -- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show) -- >>> type ImageUrl = T.Text -- >>> BSL.putStrLn $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) --- {"properties":{"Neutral":{"type":"string"},"Focus":{"type":"string"},"Active":{"type":"string"},"Hover":{"type":"string"},"Disabled":{"type":"string"}},"type":"object"} +-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}} -- -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. @@ -667,14 +648,14 @@ gdatatypeSchemaName opts _ = case orig of orig = datatypeName (Proxy3 :: Proxy3 d f a) name = datatypeNameModifier opts orig --- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@. +-- | Construct 'NamedSchema' usinng 'ToParamSchema'. paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) => SchemaOptions -> Proxy a -> NamedSchema paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy) --- | Lift a plain @'ParamSchema'@ into a model @'Schema'@. +-- | Construct 'Schema' usinng 'ToParamSchema'. paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema -paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy +paramSchemaToSchema = toParamSchema nullarySchema :: Schema nullarySchema = mempty diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs index 46f51007..9c926b5e 100644 --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -205,7 +205,7 @@ instance Monad Result where -- | Validation configuration. data Config = Config - { -- | Pattern checker for @'_paramSchemaPattern'@ validation. + { -- | Pattern checker for @'_schemaPattern'@ validation. configPatternChecker :: Pattern -> Text -> Bool -- | Schema definitions in scope to resolve references. , configDefinitions :: Definitions Schema @@ -300,21 +300,15 @@ validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js) validateWithSchema :: Value -> Validation Schema () validateWithSchema val = do validateSchemaType val - sub_ paramSchema $ validateEnum val - --- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@. -validateWithParamSchema :: Value -> Validation ParamSchema () -validateWithParamSchema val = do - validateParamSchemaType val validateEnum val -validateInteger :: Scientific -> Validation ParamSchema () +validateInteger :: Scientific -> Validation Schema () validateInteger n = do when (not (isInteger n)) $ invalid ("not an integer") validateNumber n -validateNumber :: Scientific -> Validation ParamSchema () +validateNumber :: Scientific -> Validation Schema () validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do let exMax = Just True == sch ^. exclusiveMaximum exMin = Just True == sch ^. exclusiveMinimum @@ -331,7 +325,7 @@ validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do when (not (isInteger (n / k))) $ invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n) -validateString :: Text -> Validation ParamSchema () +validateString :: Text -> Validation Schema () validateString s = do check maxLength $ \n -> when (len > fromInteger n) $ @@ -348,7 +342,7 @@ validateString s = do where len = Text.length s -validateArray :: Vector Value -> Validation ParamSchema () +validateArray :: Vector Value -> Validation Schema () validateArray xs = do check maxItems $ \n -> when (len > fromInteger n) $ @@ -418,7 +412,7 @@ validateObject o = withSchema $ \sch -> unknownProperty pname = invalid $ "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema" -validateEnum :: Value -> Validation ParamSchema () +validateEnum :: Value -> Validation Schema () validateEnum val = do check enum_ $ \xs -> when (val `notElem` xs) $ @@ -431,7 +425,7 @@ validateEnum val = do -- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}" -- Just [SwaggerObject] inferSchemaTypes :: Schema -> [SwaggerType] -inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++ +inferSchemaTypes sch = inferParamSchemaTypes sch ++ [ SwaggerObject | any ($ sch) [ has (additionalProperties._Just) , has (maxProperties._Just) @@ -452,7 +446,7 @@ inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++ -- -- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}" -- Just [SwaggerInteger] -inferParamSchemaTypes :: ParamSchema -> [SwaggerType] +inferParamSchemaTypes :: Schema -> [SwaggerType] inferParamSchemaTypes sch = concat [ [ SwaggerArray | any ($ sch) [ has (items._Just) @@ -491,21 +485,21 @@ validateSchemaType val = withSchema $ \sch -> case (sch ^. type_, val) of (Just SwaggerNull, Null) -> valid (Just SwaggerBoolean, Bool _) -> valid - (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n) - (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n) - (Just SwaggerString, String s) -> sub_ paramSchema (validateString s) - (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs) + (Just SwaggerInteger, Number n) -> validateInteger n + (Just SwaggerNumber, Number n) -> validateNumber n + (Just SwaggerString, String s) -> validateString s + (Just SwaggerArray, Array xs) -> validateArray xs (Just SwaggerObject, Object o) -> validateObject o (Nothing, Null) -> valid (Nothing, Bool _) -> valid -- Number by default - (Nothing, Number n) -> sub_ paramSchema (validateNumber n) - (Nothing, String s) -> sub_ paramSchema (validateString s) - (Nothing, Array xs) -> sub_ paramSchema (validateArray xs) + (Nothing, Number n) -> validateNumber n + (Nothing, String s) -> validateString s + (Nothing, Array xs) -> validateArray xs (Nothing, Object o) -> validateObject o bad -> invalid $ "expected JSON value of type " ++ showType bad -validateParamSchemaType :: Value -> Validation ParamSchema () +validateParamSchemaType :: Value -> Validation Schema () validateParamSchemaType val = withSchema $ \sch -> case (sch ^. type_, val) of (Just SwaggerBoolean, Bool _) -> valid diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index 70b30833..20d269f0 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -29,8 +29,6 @@ import Data.Text (Text) makeFields ''Swagger makeFields ''Components makeFields ''Server --- conflict with enum of ParamSchema ---makeLensesWith swaggerFieldRules ''ServerVariable makeFields ''RequestBody makeFields ''MediaTypeObject makeFields ''Info @@ -43,7 +41,6 @@ makeLensesWith swaggerFieldRules ''Param makeFields ''Header makeLensesWith swaggerFieldRules ''Schema makeFields ''NamedSchema -makeLensesWith swaggerFieldRules ''ParamSchema makeFields ''Xml makeLensesWith swaggerFieldRules ''Responses makeFields ''Response @@ -102,75 +99,68 @@ instance At Responses where at n = responses . at n instance Ixed Operation where ix n = responses . ix n instance At Operation where at n = responses . at n -instance HasParamSchema NamedSchema ParamSchema where paramSchema = schema.paramSchema - --- HasType instances -instance HasType Schema (Maybe SwaggerType) where type_ = paramSchema.type_ -instance HasType NamedSchema (Maybe SwaggerType) where type_ = paramSchema.type_ - --- HasDefault instances -instance HasDefault Schema (Maybe Value) where default_ = paramSchema.default_ +instance HasType NamedSchema (Maybe SwaggerType) where type_ = schema.type_ -- OVERLAPPABLE instances instance {-# OVERLAPPABLE #-} - HasParamSchema s ParamSchema + HasSchema s Schema => HasFormat s (Maybe Format) where - format = paramSchema.format + format = schema.format instance {-# OVERLAPPABLE #-} - HasParamSchema s ParamSchema + HasSchema s Schema => HasItems s (Maybe SwaggerItems) where - items = paramSchema.items + items = schema.items instance {-# OVERLAPPABLE #-} - HasParamSchema s ParamSchema + HasSchema s Schema => HasMaximum s (Maybe Scientific) where - maximum_ = paramSchema.maximum_ + maximum_ = schema.maximum_ -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasExclusiveMaximum s (Maybe Bool) where - exclusiveMaximum = paramSchema.exclusiveMaximum + exclusiveMaximum = schema.exclusiveMaximum -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMinimum s (Maybe Scientific) where - minimum_ = paramSchema.minimum_ + minimum_ = schema.minimum_ -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasExclusiveMinimum s (Maybe Bool) where - exclusiveMinimum = paramSchema.exclusiveMinimum + exclusiveMinimum = schema.exclusiveMinimum -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMaxLength s (Maybe Integer) where - maxLength = paramSchema.maxLength + maxLength = schema.maxLength -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMinLength s (Maybe Integer) where - minLength = paramSchema.minLength + minLength = schema.minLength -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasPattern s (Maybe Text) where - pattern = paramSchema.pattern + pattern = schema.pattern -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMaxItems s (Maybe Integer) where - maxItems = paramSchema.maxItems + maxItems = schema.maxItems -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMinItems s (Maybe Integer) where - minItems = paramSchema.minItems + minItems = schema.minItems -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasUniqueItems s (Maybe Bool) where - uniqueItems = paramSchema.uniqueItems + uniqueItems = schema.uniqueItems -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasEnum s (Maybe [Value]) where - enum_ = paramSchema.enum_ + enum_ = schema.enum_ -instance {-# OVERLAPPABLE #-} HasParamSchema s ParamSchema +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMultipleOf s (Maybe Scientific) where - multipleOf = paramSchema.multipleOf + multipleOf = schema.multipleOf diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs index d38c461f..b108e050 100644 --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -43,7 +43,7 @@ -- & #type ?~ SwaggerBoolean -- & #description ?~ "To be or not to be" -- :} --- {"description":"To be or not to be","type":"boolean"} +-- {"type":"boolean","description":"To be or not to be"} -- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and -- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example: @@ -81,7 +81,6 @@ makeFieldLabels ''Param makeFieldLabels ''Header makeFieldLabels ''Schema makeFieldLabels ''NamedSchema -makeFieldLabels ''ParamSchema makeFieldLabels ''Xml makeFieldLabels ''Responses makeFieldLabels ''Response @@ -153,239 +152,132 @@ instance At Operation where at n = #responses % at n {-# INLINE at #-} --- #paramSchema - -instance - ( a ~ ParamSchema - , b ~ ParamSchema - ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where - labelOptic = #schema % #paramSchema - {-# INLINE labelOptic #-} - -- #type -instance - ( a ~ Maybe SwaggerType - , b ~ Maybe SwaggerType - ) => LabelOptic "type" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #type - {-# INLINE labelOptic #-} - instance ( a ~ Maybe SwaggerType , b ~ Maybe SwaggerType ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #type + labelOptic = #schema % #type {-# INLINE labelOptic #-} -- #default -instance - ( a ~ Maybe Value, b ~ Maybe Value - ) => LabelOptic "default" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #default - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Value, b ~ Maybe Value ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #default + labelOptic = #schema % #default {-# INLINE labelOptic #-} -- #format -instance - ( a ~ Maybe Format, b ~ Maybe Format - ) => LabelOptic "format" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #format - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Format, b ~ Maybe Format ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #format + labelOptic = #schema % #format {-# INLINE labelOptic #-} -- #items -instance - ( a ~ Maybe SwaggerItems - , b ~ Maybe SwaggerItems - ) => LabelOptic "items" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #items - {-# INLINE labelOptic #-} - instance ( a ~ Maybe SwaggerItems , b ~ Maybe SwaggerItems ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #items + labelOptic = #schema % #items {-# INLINE labelOptic #-} -- #maximum -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "maximum" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #maximum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #maximum + labelOptic = #schema % #maximum {-# INLINE labelOptic #-} -- #exclusiveMaximum -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #exclusiveMaximum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #exclusiveMaximum + labelOptic = #schema % #exclusiveMaximum {-# INLINE labelOptic #-} -- #minimum -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "minimum" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #minimum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #minimum + labelOptic = #schema % #minimum {-# INLINE labelOptic #-} -- #exclusiveMinimum -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #exclusiveMinimum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #exclusiveMinimum + labelOptic = #schema % #exclusiveMinimum {-# INLINE labelOptic #-} -- #maxLength -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxLength" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #maxLength - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #maxLength + labelOptic = #schema % #maxLength {-# INLINE labelOptic #-} -- #minLength -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minLength" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #minLength - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #minLength + labelOptic = #schema % #minLength {-# INLINE labelOptic #-} -- #pattern -instance - ( a ~ Maybe Text, b ~ Maybe Text - ) => LabelOptic "pattern" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #pattern - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Text, b ~ Maybe Text ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #pattern + labelOptic = #schema % #pattern {-# INLINE labelOptic #-} -- #maxItems -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxItems" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #maxItems - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #maxItems + labelOptic = #schema % #maxItems {-# INLINE labelOptic #-} -- #minItems -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minItems" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #minItems - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #minItems + labelOptic = #schema % #minItems {-# INLINE labelOptic #-} -- #uniqueItems -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #uniqueItems - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #uniqueItems + labelOptic = #schema % #uniqueItems {-# INLINE labelOptic #-} -- #enum -instance - ( a ~ Maybe [Value], b ~ Maybe [Value] - ) => LabelOptic "enum" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #enum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe [Value], b ~ Maybe [Value] ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #enum + labelOptic = #schema % #enum {-# INLINE labelOptic #-} -- #multipleOf -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #multipleOf - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #multipleOf + labelOptic = #schema % #multipleOf {-# INLINE labelOptic #-} diff --git a/src/Data/Swagger/ParamSchema.hs b/src/Data/Swagger/ParamSchema.hs index a1f851d2..046e241b 100644 --- a/src/Data/Swagger/ParamSchema.hs +++ b/src/Data/Swagger/ParamSchema.hs @@ -13,9 +13,9 @@ module Data.Swagger.ParamSchema ( toParamSchemaBoundedIntegral, -- * Schema templates - passwordParamSchema, - binaryParamSchema, - byteParamSchema, + passwordSchema, + binarySchema, + byteSchema, -- * Generic encoding configuration SchemaOptions(..), diff --git a/src/Data/Swagger/Schema.hs b/src/Data/Swagger/Schema.hs index 2e2043a8..2ae55c94 100644 --- a/src/Data/Swagger/Schema.hs +++ b/src/Data/Swagger/Schema.hs @@ -32,11 +32,6 @@ module Data.Swagger.Schema ( paramSchemaToNamedSchema, paramSchemaToSchema, - -- * Schema templates - passwordSchema, - binarySchema, - byteSchema, - -- * Sketching @'Schema'@s using @'ToJSON'@ sketchSchema, sketchStrictSchema, diff --git a/src/Data/Swagger/Schema/Generator.hs b/src/Data/Swagger/Schema/Generator.hs index faa8a9c4..7349a23e 100644 --- a/src/Data/Swagger/Schema/Generator.hs +++ b/src/Data/Swagger/Schema/Generator.hs @@ -29,7 +29,7 @@ import Test.QuickCheck.Property -- and cannot be inferred. schemaGen :: Definitions Schema -> Schema -> Gen Value schemaGen _ schema - | Just cases <- schema ^. paramSchema . enum_ = elements cases + | Just cases <- schema ^. enum_ = elements cases schemaGen defns schema | Just variants <- schema ^. oneOf = schemaGen defns =<< elements (dereference defns <$> variants) schemaGen defns schema = diff --git a/test/Data/Swagger/ParamSchemaSpec.hs b/test/Data/Swagger/ParamSchemaSpec.hs index 3df569ae..49c820c0 100644 --- a/test/Data/Swagger/ParamSchemaSpec.hs +++ b/test/Data/Swagger/ParamSchemaSpec.hs @@ -22,7 +22,7 @@ import Data.Time.LocalTime import qualified Data.HashMap.Strict as HM checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec -checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema) <=> js +checkToParamSchema proxy js = (toParamSchema proxy :: Schema) <=> js spec :: Spec spec = do From d193795211fb333c692809b15cb0a01298b0ed45 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Mon, 3 Aug 2020 17:18:09 +0300 Subject: [PATCH 25/25] More missed fields --- src/Data/Swagger/Internal.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index 196c8313..c3620e50 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -451,7 +451,7 @@ data Param = Param -- | A brief description of the parameter. -- This could contain examples of use. - -- GFM syntax can be used for rich text representation. + -- CommonMark syntax MAY be used for rich text representation. , _paramDescription :: Maybe Text -- | Determines whether this parameter is mandatory. @@ -471,6 +471,13 @@ data Param = Param -- a parameter with an empty value. Default value is @false@. , _paramAllowEmptyValue :: Maybe Bool + -- | Determines whether the parameter value SHOULD allow reserved characters, + -- as defined by [RFC3986](https://tools.ietf.org/html/rfc3986#section-2.2) + -- @:/?#[]@!$&'()*+,;=@ to be included without percent-encoding. + -- This property only applies to parameters with an '_paramIn' value of 'ParamQuery'. + -- The default value is 'False'. + , _paramAllowReserved :: Maybe Bool + -- | Parameter schema. , _paramSchema :: Maybe (Referenced Schema) @@ -868,7 +875,7 @@ data Tag = Tag _tagName :: TagName -- | A short description for the tag. - -- GFM syntax can be used for rich text representation. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. , _tagDescription :: Maybe Text -- | Additional external documentation for this tag. @@ -883,7 +890,7 @@ instance IsString Tag where -- | Allows referencing an external resource for extended documentation. data ExternalDocs = ExternalDocs { -- | A short description of the target documentation. - -- GFM syntax can be used for rich text representation. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. _externalDocsDescription :: Maybe Text -- | The URL for the target documentation.