diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +0.4 +--- +* Remove `Swagger`/`swagger` prefixes; +* Add `ToSchema` type class with default generic implementation; +* Add configurable generic `ToSchema` helpers; +* Add `doctest` test suite; +* Fixes: + * Fix `HasSchemaCommon` instance for `Schema`; + * Change `minimum`, `maximum` and `multipleOf` properties to be any number, + not necessarily an integer; + * Fix all warnings + 0.3 --- * Fixes: diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -6,78 +6,82 @@ -- and Swagger-Codegen to generate clients in various languages. -- Additional utilities can also take advantage of the resulting files, such as testing tools. module Data.Swagger ( + module Data.Swagger.Schema, + -- * Swagger specification Swagger(..), - SwaggerHost(..), - SwaggerScheme(..), + Host(..), + Scheme(..), -- * Info types - SwaggerInfo(..), - SwaggerContact(..), - SwaggerLicense(..), + Info(..), + Contact(..), + License(..), -- * Paths - SwaggerPaths(..), - SwaggerPathItem(..), + Paths(..), + PathItem(..), -- * Operations - SwaggerTag(..), - SwaggerOperation(..), + Tag(..), + Operation(..), -- * Types and formats - SwaggerParameterType(..), - SwaggerItemsType(..), - SwaggerSchemaType(..), - SwaggerFormat(..), - SwaggerCollectionFormat(..), - SwaggerItemsCollectionFormat(..), + ParameterType(..), + ItemsType(..), + SchemaType(..), + Format, + CollectionFormat(..), + ItemsCollectionFormat(..), -- * Parameters - SwaggerParameter(..), - SwaggerParameterSchema(..), - SwaggerParameterOtherSchema(..), - SwaggerParameterLocation(..), - SwaggerParamName(..), - SwaggerItems(..), - SwaggerHeader(..), - SwaggerExample(..), + Parameter(..), + ParameterSchema(..), + ParameterOtherSchema(..), + ParameterLocation(..), + ParamName, + Items(..), + Header(..), + Example(..), -- * Schema - SwaggerSchema(..), - SwaggerSchemaItems(..), - SwaggerSchemaCommon(..), - SwaggerXml(..), + Schema(..), + SchemaItems(..), + SchemaCommon(..), + Xml(..), -- * Responses - SwaggerResponses(..), - SwaggerResponse(..), + Responses(..), + Response(..), -- * Security - SwaggerSecurityScheme(..), - SwaggerSecuritySchemeType(..), - SwaggerSecurityRequirement(..), + SecurityScheme(..), + SecuritySchemeType(..), + SecurityRequirement(..), -- ** API key - SwaggerApiKeyParams(..), - SwaggerApiKeyLocation(..), + ApiKeyParams(..), + ApiKeyLocation(..), -- ** OAuth2 - SwaggerOAuth2Params(..), - SwaggerOAuth2Flow(..), - AuthorizationURL(..), - TokenURL(..), + OAuth2Params(..), + OAuth2Flow(..), + AuthorizationURL, + TokenURL, -- * External documentation - SwaggerExternalDocs(..), + ExternalDocs(..), -- * References - SwaggerReference(..), - SwaggerReferenced(..), + Reference(..), + Referenced(..), -- * Miscellaneous - SwaggerMimeList(..), + MimeList(..), URL(..), ) where + +import Data.Swagger.Schema import Data.Swagger.Internal diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -13,17 +13,15 @@ import Control.Monad import Data.Aeson import Data.Aeson.TH (deriveJSON) -import Data.Foldable (Foldable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid +import Data.Scientific (Scientific) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text -import Data.Traversable (Traversable) -import Data.Hashable (Hashable) import GHC.Generics (Generic) import Network (HostName, PortNumber) import Network.HTTP.Media (MediaType) @@ -35,117 +33,117 @@ data Swagger = Swagger { -- | Provides metadata about the API. -- The metadata can be used by the clients if needed. - _swaggerInfo :: SwaggerInfo + _info :: 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 SwaggerHost + , _host :: 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 + , _basePath :: 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 [SwaggerScheme] + , _schemes :: 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 :: SwaggerMimeList + , _consumes :: 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 :: SwaggerMimeList + , _produces :: MimeList -- | The available paths and operations for the API. - , _swaggerPaths :: SwaggerPaths + , _paths :: Paths -- | An object to hold data types produced and consumed by operations. - , _swaggerDefinitions :: HashMap Text SwaggerSchema + , _definitions :: HashMap Text Schema -- | An object to hold parameters that can be used across operations. -- This property does not define global parameters for all operations. - , _swaggerParameters :: HashMap Text SwaggerParameter + , _parameters :: HashMap Text Parameter -- | An object to hold responses that can be used across operations. -- This property does not define global responses for all operations. - , _swaggerResponses :: HashMap Text SwaggerResponse + , _responses :: HashMap Text Response -- | Security scheme definitions that can be used across the specification. - , _swaggerSecurityDefinitions :: HashMap Text SwaggerSecurityScheme + , _securityDefinitions :: HashMap Text SecurityScheme -- | 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). -- Individual operations can override this definition. - , _swaggerSecurity :: [SwaggerSecurityRequirement] + , _security :: [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. -- Each tag name in the list MUST be unique. - , _swaggerTags :: [SwaggerTag] + , _tags :: [Tag] -- | Additional external documentation. - , _swaggerExternalDocs :: Maybe SwaggerExternalDocs + , _externalDocs :: Maybe ExternalDocs } deriving (Eq, Show, Generic) -- | 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. -data SwaggerInfo = SwaggerInfo +data Info = Info { -- | The title of the application. - _swaggerInfoTitle :: Text + _infoTitle :: Text -- | A short description of the application. -- GFM syntax can be used for rich text representation. - , _swaggerInfoDescription :: Maybe Text + , _infoDescription :: Maybe Text -- | The Terms of Service for the API. - , _swaggerInfoTermsOfService :: Maybe Text + , _infoTermsOfService :: Maybe Text -- | The contact information for the exposed API. - , _swaggerInfoContact :: Maybe SwaggerContact + , _infoContact :: Maybe Contact -- | The license information for the exposed API. - , _swaggerInfoLicense :: Maybe SwaggerLicense + , _infoLicense :: Maybe License -- | Provides the version of the application API -- (not to be confused with the specification version). - , _swaggerInfoVersion :: Text + , _infoVersion :: Text } deriving (Eq, Show, Generic) -- | Contact information for the exposed API. -data SwaggerContact = SwaggerContact +data Contact = Contact { -- | The identifying name of the contact person/organization. - _swaggerContactName :: Maybe Text + _contactName :: Maybe Text -- | The URL pointing to the contact information. - , _swaggerContactUrl :: Maybe URL + , _contactUrl :: Maybe URL -- | The email address of the contact person/organization. - , _swaggerContactEmail :: Maybe Text + , _contactEmail :: Maybe Text } deriving (Eq, Show) -- | License information for the exposed API. -data SwaggerLicense = SwaggerLicense +data License = License { -- | The license name used for the API. - _swaggerLicenseName :: Text + _licenseName :: Text -- | A URL to the license used for the API. - , _swaggerLicenseUrl :: Maybe URL + , _licenseUrl :: Maybe URL } deriving (Eq, Show) -- | The host (name or ip) serving the API. It MAY include a port. -data SwaggerHost = SwaggerHost - { _swaggerHostName :: HostName -- ^ Host name. - , _swaggerHostPort :: Maybe PortNumber -- ^ Optional port. +data Host = Host + { _hostName :: HostName -- ^ Host name. + , _hostPort :: Maybe PortNumber -- ^ Optional port. } deriving (Eq, Show) -- | The transfer protocol of the API. -data SwaggerScheme +data Scheme = Http | Https | Ws @@ -153,305 +151,305 @@ deriving (Eq, Show) -- | The available paths and operations for the API. -data SwaggerPaths = SwaggerPaths +data Paths = Paths { -- | Holds the relative paths to the individual endpoints. - -- The path is appended to the @'swaggerBasePath'@ in order to construct the full URL. - _swaggerPathsMap :: HashMap FilePath SwaggerPathItem + -- The path is appended to the @'basePath'@ in order to construct the full URL. + _pathsMap :: HashMap FilePath PathItem } deriving (Eq, Show, Generic) -- | Describes the operations available on a single path. --- A @'SwaggerPathItem'@ may be empty, due to ACL constraints. +-- A @'PathItem'@ may be empty, due to ACL constraints. -- The path itself is still exposed to the documentation viewer -- but they will not know which operations and parameters are available. -data SwaggerPathItem = SwaggerPathItem +data PathItem = PathItem { -- | A definition of a GET operation on this path. - _swaggerPathItemGet :: Maybe SwaggerOperation + _pathItemGet :: Maybe Operation -- | A definition of a PUT operation on this path. - , _swaggerPathItemPut :: Maybe SwaggerOperation + , _pathItemPut :: Maybe Operation -- | A definition of a POST operation on this path. - , _swaggerPathItemPost :: Maybe SwaggerOperation + , _pathItemPost :: Maybe Operation -- | A definition of a DELETE operation on this path. - , _swaggerPathItemDelete :: Maybe SwaggerOperation + , _pathItemDelete :: Maybe Operation -- | A definition of a OPTIONS operation on this path. - , _swaggerPathItemOptions :: Maybe SwaggerOperation + , _pathItemOptions :: Maybe Operation -- | A definition of a HEAD operation on this path. - , _swaggerPathItemHead :: Maybe SwaggerOperation + , _pathItemHead :: Maybe Operation -- | A definition of a PATCH operation on this path. - , _swaggerPathItemPatch :: Maybe SwaggerOperation + , _pathItemPatch :: Maybe Operation -- | 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. -- A unique parameter is defined by a combination of a name and location. - , _swaggerPathItemParameters :: [SwaggerReferenced SwaggerParameter] + , _pathItemParameters :: [Referenced Parameter] } deriving (Eq, Show, Generic) -- | Describes a single API operation on a path. -data SwaggerOperation = SwaggerOperation +data Operation = Operation { -- | A list of tags for API documentation control. -- Tags can be used for logical grouping of operations by resources or any other qualifier. - _swaggerOperationTags :: [Text] + _operationTags :: [Text] -- | A short summary of what the operation does. -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters. - , _swaggerOperationSummary :: Maybe Text + , _operationSummary :: Maybe Text -- | A verbose explanation of the operation behavior. -- GFM syntax can be used for rich text representation. - , _swaggerOperationDescription :: Maybe Text + , _operationDescription :: Maybe Text -- | Additional external documentation for this operation. - , _swaggerOperationExternalDocs :: Maybe SwaggerExternalDocs + , _operationExternalDocs :: Maybe ExternalDocs -- | 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. - , _swaggerOperationOperationId :: Maybe Text + , _operationOperationId :: Maybe Text -- | A list of MIME types the operation can consume. - -- This overrides the @'swaggerConsumes'@. + -- This overrides the @'consumes'@. -- @Just []@ MAY be used to clear the global definition. - , _swaggerOperationConsumes :: Maybe SwaggerMimeList + , _operationConsumes :: Maybe MimeList -- | A list of MIME types the operation can produce. - -- This overrides the @'swaggerProduces'@. + -- This overrides the @'produces'@. -- @Just []@ MAY be used to clear the global definition. - , _swaggerOperationProduces :: Maybe SwaggerMimeList + , _operationProduces :: Maybe MimeList -- | A list of parameters that are applicable for this operation. - -- If a parameter is already defined at the @'SwaggerPathItem'@, + -- If a parameter is already defined at the @'PathItem'@, -- the new definition will override it, but can never remove it. -- The list MUST NOT include duplicated parameters. -- A unique parameter is defined by a combination of a name and location. - , _swaggerOperationParameters :: [SwaggerReferenced SwaggerParameter] + , _operationParameters :: [Referenced Parameter] -- | The list of possible responses as they are returned from executing this operation. - , _swaggerOperationResponses :: SwaggerResponses + , _operationResponses :: Responses -- | The transfer protocol for the operation. - -- The value overrides @'swaggerSchemes'@. - , _swaggerOperationSchemes :: Maybe [SwaggerScheme] + -- The value overrides @'schemes'@. + , _operationSchemes :: Maybe [Scheme] -- | Declares this operation to be deprecated. -- Usage of the declared operation should be refrained. -- Default value is @False@. - , _swaggerOperationDeprecated :: Maybe Bool + , _operationDeprecated :: Maybe Bool -- | A declaration of which security schemes are applied for this operation. -- The list of values describes alternative security schemes that can be used -- (that is, there is a logical OR between the security requirements). -- This definition overrides any declared top-level security. -- To remove a top-level security declaration, @Just []@ can be used. - , _swaggerOperationSecurity :: [SwaggerSecurityRequirement] + , _operationSecurity :: [SecurityRequirement] } deriving (Eq, Show, Generic) -newtype SwaggerMimeList = SwaggerMimeList { getSwaggerMimeList :: [MediaType] } +newtype MimeList = MimeList { getMimeList :: [MediaType] } deriving (Eq, Show, Monoid) -- | Describes a single operation parameter. -- A unique parameter is defined by a combination of a name and location. -data SwaggerParameter = SwaggerParameter +data Parameter = Parameter { -- | The name of the parameter. -- Parameter names are case sensitive. - _swaggerParameterName :: Text + _parameterName :: Text -- | A brief description of the parameter. -- This could contain examples of use. -- GFM syntax can be used for rich text representation. - , _swaggerParameterDescription :: Maybe Text + , _parameterDescription :: Maybe Text -- | Determines whether this parameter is mandatory. -- If the parameter is in "path", this property is required and its value MUST be true. -- Otherwise, the property MAY be included and its default value is @False@. - , _swaggerParameterRequired :: Maybe Bool + , _parameterRequired :: Maybe Bool -- | Parameter schema. - , _swaggerParameterSchema :: SwaggerParameterSchema + , _parameterSchema :: ParameterSchema } deriving (Eq, Show, Generic) -data SwaggerParameterSchema - = SwaggerParameterBody (SwaggerReferenced SwaggerSchema) - | SwaggerParameterOther SwaggerParameterOtherSchema +data ParameterSchema + = ParameterBody (Referenced Schema) + | ParameterOther ParameterOtherSchema deriving (Eq, Show) -data SwaggerParameterOtherSchema = SwaggerParameterOtherSchema +data ParameterOtherSchema = ParameterOtherSchema { -- | The location of the parameter. - _swaggerParameterOtherSchemaIn :: SwaggerParameterLocation + _parameterOtherSchemaIn :: ParameterLocation -- | The type of the parameter. -- Since the parameter is not located at the request body, -- it is limited to simple types (that is, not an object). - -- If type is @'SwaggerParamFile'@, the @consumes@ MUST be either + -- If type is @'ParamFile'@, the @consumes@ MUST be either -- "multipart/form-data" or " application/x-www-form-urlencoded" - -- and the parameter MUST be in @'SwaggerParameterFormData'@. - , _swaggerParameterOtherSchemaType :: SwaggerParameterType + -- and the parameter MUST be in @'ParameterFormData'@. + , _parameterOtherSchemaType :: ParameterType -- | The extending format for the previously mentioned type. - , _swaggerParameterOtherSchemaFormat :: Maybe SwaggerFormat + , _parameterOtherSchemaFormat :: Maybe Format -- | Sets the ability to pass empty-valued parameters. - -- This is valid only for either @'SwaggerParameterQuery'@ or @'SwaggerParameterFormData'@ + -- This is valid only for either @'ParameterQuery'@ or @'ParameterFormData'@ -- and allows you to send a parameter with a name only or an empty value. -- Default value is @False@. - , _swaggerParameterOtherSchemaAllowEmptyValue :: Maybe Bool + , _parameterOtherSchemaAllowEmptyValue :: Maybe Bool - -- | __Required if type is @'SwaggerParamArray'@__. + -- | __Required if type is @'ParamArray'@__. -- Describes the type of items in the array. - , _swaggerParameterOtherSchemaItems :: Maybe SwaggerItems + , _parameterOtherSchemaItems :: Maybe Items - -- | Determines the format of the array if @'SwaggerParamArray'@ is used. + -- | Determines the format of the array if @'ParamArray'@ is used. -- Default value is csv. - , _swaggerParameterOtherSchemaCollectionFormat :: Maybe SwaggerCollectionFormat + , _parameterOtherSchemaCollectionFormat :: Maybe CollectionFormat - , _swaggerParameterOtherSchemaCommon :: SwaggerSchemaCommon + , _parameterOtherSchemaCommon :: SchemaCommon } deriving (Eq, Show, Generic) -data SwaggerParameterType - = SwaggerParamString - | SwaggerParamNumber - | SwaggerParamInteger - | SwaggerParamBoolean - | SwaggerParamArray - | SwaggerParamFile +data ParameterType + = ParamString + | ParamNumber + | ParamInteger + | ParamBoolean + | ParamArray + | ParamFile deriving (Eq, Show) -data SwaggerParameterLocation +data ParameterLocation = -- | Parameters that are appended to the URL. -- For example, in @/items?id=###@, the query parameter is @id@. - SwaggerParameterQuery + ParameterQuery -- | Custom headers that are expected as part of the request. - | SwaggerParameterHeader + | ParameterHeader -- | Used together with Path Templating, where the parameter value is actually part of the operation's URL. -- This does not include the host or base path of the API. -- For example, in @/items/{itemId}@, the path parameter is @itemId@. - | SwaggerParameterPath + | ParameterPath -- | 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 @'SwaggerParamFile'@ type. + -- 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 ). - | SwaggerParameterFormData + | ParameterFormData deriving (Eq, Show) -type SwaggerFormat = Text +type Format = Text -- | Determines the format of the array. -data SwaggerCollectionFormat - = SwaggerCollectionCSV -- ^ Comma separated values: @foo,bar@. - | SwaggerCollectionSSV -- ^ Space separated values: @foo bar@. - | SwaggerCollectionTSV -- ^ Tab separated values: @foo\\tbar@. - | SwaggerCollectionPipes -- ^ Pipe separated values: @foo|bar@. - | SwaggerCollectionMulti -- ^ Corresponds to multiple parameter instances +data CollectionFormat + = CollectionCSV -- ^ Comma separated values: @foo,bar@. + | CollectionSSV -- ^ Space separated values: @foo bar@. + | CollectionTSV -- ^ Tab separated values: @foo\\tbar@. + | CollectionPipes -- ^ Pipe separated values: @foo|bar@. + | CollectionMulti -- ^ Corresponds to multiple parameter instances -- instead of multiple values for a single instance @foo=bar&foo=baz@. - -- This is valid only for parameters in @'SwaggerParameterQuery'@ or @'SwaggerParameterFormData'@. + -- This is valid only for parameters in @'ParameterQuery'@ or @'ParameterFormData'@. deriving (Eq, Show) -data SwaggerItemsType - = SwaggerItemsString - | SwaggerItemsNumber - | SwaggerItemsInteger - | SwaggerItemsBoolean - | SwaggerItemsArray +data ItemsType + = ItemsString + | ItemsNumber + | ItemsInteger + | ItemsBoolean + | ItemsArray deriving (Eq, Show) -data SwaggerSchemaType - = SwaggerSchemaArray - | SwaggerSchemaBoolean - | SwaggerSchemaInteger - | SwaggerSchemaNumber - | SwaggerSchemaNull - | SwaggerSchemaObject - | SwaggerSchemaString +data SchemaType + = SchemaArray + | SchemaBoolean + | SchemaInteger + | SchemaNumber + | SchemaNull + | SchemaObject + | SchemaString deriving (Eq, Show) -- | Determines the format of the nested array. -data SwaggerItemsCollectionFormat - = SwaggerItemsCollectionCSV -- ^ Comma separated values: @foo,bar@. - | SwaggerItemsCollectionSSV -- ^ Space separated values: @foo bar@. - | SwaggerItemsCollectionTSV -- ^ Tab separated values: @foo\\tbar@. - | SwaggerItemsCollectionPipes -- ^ Pipe separated values: @foo|bar@. +data ItemsCollectionFormat + = ItemsCollectionCSV -- ^ Comma separated values: @foo,bar@. + | ItemsCollectionSSV -- ^ Space separated values: @foo bar@. + | ItemsCollectionTSV -- ^ Tab separated values: @foo\\tbar@. + | ItemsCollectionPipes -- ^ Pipe separated values: @foo|bar@. deriving (Eq, Show) -type SwaggerParamName = Text +type ParamName = Text -data SwaggerSchema = SwaggerSchema - { _swaggerSchemaType :: SwaggerSchemaType - , _swaggerSchemaFormat :: Maybe SwaggerFormat - , _swaggerSchemaTitle :: Maybe Text - , _swaggerSchemaDescription :: Maybe Text - , _swaggerSchemaRequired :: [SwaggerParamName] +data Schema = Schema + { _schemaType :: SchemaType + , _schemaFormat :: Maybe Format + , _schemaTitle :: Maybe Text + , _schemaDescription :: Maybe Text + , _schemaRequired :: [ParamName] - , _swaggerSchemaItems :: Maybe SwaggerSchemaItems - , _swaggerSchemaAllOf :: Maybe [SwaggerSchema] - , _swaggerSchemaProperties :: HashMap Text (SwaggerReferenced SwaggerSchema) - , _swaggerSchemaAdditionalProperties :: Maybe SwaggerSchema + , _schemaItems :: Maybe SchemaItems + , _schemaAllOf :: Maybe [Schema] + , _schemaProperties :: HashMap Text (Referenced Schema) + , _schemaAdditionalProperties :: Maybe Schema - , _swaggerSchemaDiscriminator :: Maybe Text - , _swaggerSchemaReadOnly :: Maybe Bool - , _swaggerSchemaXml :: Maybe SwaggerXml - , _swaggerSchemaExternalDocs :: Maybe SwaggerExternalDocs - , _swaggerSchemaExample :: Maybe Value + , _schemaDiscriminator :: Maybe Text + , _schemaReadOnly :: Maybe Bool + , _schemaXml :: Maybe Xml + , _schemaExternalDocs :: Maybe ExternalDocs + , _schemaExample :: Maybe Value - , _swaggerSchemaMaxProperties :: Maybe Integer - , _swaggerSchemaMinProperties :: Maybe Integer + , _schemaMaxProperties :: Maybe Integer + , _schemaMinProperties :: Maybe Integer - , _swaggerSchemaCommon :: SwaggerSchemaCommon + , _schemaSchemaCommon :: SchemaCommon } deriving (Eq, Show, Generic) -data SwaggerSchemaItems - = SwaggerSchemaItemsObject (SwaggerReferenced SwaggerSchema) - | SwaggerSchemaItemsArray [SwaggerReferenced SwaggerSchema] +data SchemaItems + = SchemaItemsObject (Referenced Schema) + | SchemaItemsArray [Referenced Schema] deriving (Eq, Show) -data SwaggerSchemaCommon = SwaggerSchemaCommon +data SchemaCommon = SchemaCommon { -- | 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. - _swaggerSchemaDefault :: Maybe Value + _schemaCommonDefault :: Maybe Value - , _swaggerSchemaMaximum :: Maybe Integer - , _swaggerSchemaExclusiveMaximum :: Maybe Bool - , _swaggerSchemaMinimum :: Maybe Integer - , _swaggerSchemaExclusiveMinimum :: Maybe Bool - , _swaggerSchemaMaxLength :: Maybe Integer - , _swaggerSchemaMinLength :: Maybe Integer - , _swaggerSchemaPattern :: Maybe Text - , _swaggerSchemaMaxItems :: Maybe Integer - , _swaggerSchemaMinItems :: Maybe Integer - , _swaggerSchemaUniqueItems :: Maybe Bool - , _swaggerSchemaEnum :: Maybe [Value] - , _swaggerSchemaMultipleOf :: Maybe Integer + , _schemaCommonMaximum :: Maybe Scientific + , _schemaCommonExclusiveMaximum :: Maybe Bool + , _schemaCommonMinimum :: Maybe Scientific + , _schemaCommonExclusiveMinimum :: Maybe Bool + , _schemaCommonMaxLength :: Maybe Integer + , _schemaCommonMinLength :: Maybe Integer + , _schemaCommonPattern :: Maybe Text + , _schemaCommonMaxItems :: Maybe Integer + , _schemaCommonMinItems :: Maybe Integer + , _schemaCommonUniqueItems :: Maybe Bool + , _schemaCommonEnum :: Maybe [Value] + , _schemaCommonMultipleOf :: Maybe Scientific } deriving (Eq, Show, Generic) -data SwaggerXml = SwaggerXml +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. + -- When defined within the @'Items'@ (items), it will affect the name of the individual XML elements within the list. -- When defined alongside type being array (outside the items), -- it will affect the wrapping element and only if wrapped is true. -- If wrapped is false, it will be ignored. - _swaggerXmlName :: Maybe Text + _xmlName :: Maybe Text -- | The URL of the namespace definition. -- Value SHOULD be in the form of a URL. - , _swaggerXmlNamespace :: Maybe Text + , _xmlNamespace :: Maybe Text -- | The prefix to be used for the name. - , _swaggerXmlPrefix :: Maybe Text + , _xmlPrefix :: Maybe Text -- | Declares whether the property definition translates to an attribute instead of an element. -- Default value is @False@. - , _swaggerXmlAttribute :: Maybe Bool + , _xmlAttribute :: Maybe Bool -- | MAY be used only for an array definition. -- Signifies whether the array is wrapped @@ -459,25 +457,25 @@ -- or unwrapped (@\\@). -- Default value is @False@. -- The definition takes effect only when defined alongside type being array (outside the items). - , _swaggerXmlWrapped :: Maybe Bool + , _xmlWrapped :: Maybe Bool } deriving (Eq, Show, Generic) -data SwaggerItems = SwaggerItems +data Items = Items { -- | The internal type of the array. - _swaggerItemsType :: SwaggerItemsType + _itemsType :: ItemsType -- | The extending format for the previously mentioned type. - , _swaggerItemsFormat :: Maybe SwaggerFormat + , _itemsFormat :: Maybe Format - -- | __Required if type is @'SwaggerItemsArray'@.__ + -- | __Required if type is @'ItemsArray'@.__ -- Describes the type of items in the array. - , _swaggerItemsItems :: Maybe SwaggerItems + , _itemsItems :: Maybe Items -- | Determines the format of the array if type array is used. - -- Default value is @'SwaggerItemsCollectionCSV'@. - , _swaggerItemsCollectionFormat :: Maybe SwaggerItemsCollectionFormat + -- Default value is @'ItemsCollectionCSV'@. + , _itemsCollectionFormat :: Maybe ItemsCollectionFormat - , _swaggerItemsCommon :: SwaggerSchemaCommon + , _itemsCommon :: SchemaCommon } deriving (Eq, Show, Generic) -- | A container for the expected responses of an operation. @@ -485,76 +483,76 @@ -- It is not expected from the documentation to necessarily cover all possible HTTP response codes, -- since they may not be known in advance. -- However, it is expected from the documentation to cover a successful operation response and any known errors. -data SwaggerResponses = SwaggerResponses +data Responses = Responses { -- | The documentation of responses other than the ones declared for specific HTTP response codes. -- It can be used to cover undeclared responses. - _swaggerResponsesDefault :: Maybe (SwaggerReferenced SwaggerResponse) + _responsesDefault :: Maybe (Referenced Response) -- | Any HTTP status code can be used as the property name (one property per HTTP status code). -- Describes the expected response for those HTTP status codes. - , _swaggerResponsesResponses :: HashMap HttpStatusCode (SwaggerReferenced SwaggerResponse) + , _responsesResponses :: HashMap HttpStatusCode (Referenced Response) } deriving (Eq, Show, Generic) type HttpStatusCode = Int -- | Describes a single response from an API Operation. -data SwaggerResponse = SwaggerResponse +data Response = Response { -- | A short description of the response. -- GFM syntax can be used for rich text representation. - _swaggerResponseDescription :: Text + _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. - , _swaggerResponseSchema :: Maybe (SwaggerReferenced SwaggerSchema) + , _responseSchema :: Maybe (Referenced Schema) -- | A list of headers that are sent with the response. - , _swaggerResponseHeaders :: HashMap HeaderName SwaggerHeader + , _responseHeaders :: HashMap HeaderName Header -- | An example of the response message. - , _swaggerResponseExamples :: Maybe SwaggerExample + , _responseExamples :: Maybe Example } deriving (Eq, Show, Generic) type HeaderName = Text -data SwaggerHeader = SwaggerHeader +data Header = Header { -- | A short description of the header. - _swaggerHeaderDescription :: Maybe Text + _headerDescription :: Maybe Text -- | The type of the object. - , _swaggerHeaderType :: SwaggerItemsType + , _headerType :: ItemsType -- | The extending format for the previously mentioned type. See Data Type Formats for further details. - , _swaggerHeaderFormat :: Maybe SwaggerFormat + , _headerFormat :: Maybe Format - -- | __Required if type is @'SwaggerItemsArray'@__. + -- | __Required if type is @'ItemsArray'@__. -- Describes the type of items in the array. - , _swaggerHeaderItems :: Maybe SwaggerItems + , _headerItems :: Maybe Items -- | Determines the format of the array if type array is used. - -- Default value is @'SwaggerItemsCollectionCSV'@. - , _swaggerHeaderCollectionFormat :: Maybe SwaggerItemsCollectionFormat + -- Default value is @'ItemsCollectionCSV'@. + , _headerCollectionFormat :: Maybe ItemsCollectionFormat - , _swaggerHeaderCommon :: SwaggerSchemaCommon + , _headerCommon :: SchemaCommon } deriving (Eq, Show, Generic) -data SwaggerExample = SwaggerExample { getSwaggerExample :: Map MediaType Value } +data Example = Example { getExample :: Map MediaType Value } deriving (Eq, Show) -- | The location of the API key. -data SwaggerApiKeyLocation - = SwaggerApiKeyQuery - | SwaggerApiKeyHeader +data ApiKeyLocation + = ApiKeyQuery + | ApiKeyHeader deriving (Eq, Show) -data SwaggerApiKeyParams = SwaggerApiKeyParams +data ApiKeyParams = ApiKeyParams { -- | The name of the header or query parameter to be used. - _swaggerApiKeyName :: Text + _apiKeyName :: Text -- | The location of the API key. - , _swaggerApiKeyIn :: SwaggerApiKeyLocation + , _apiKeyIn :: ApiKeyLocation } deriving (Eq, Show) -- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL. @@ -563,74 +561,74 @@ -- | The token URL to be used for OAuth2 flow. This SHOULD be in the form of a URL. type TokenURL = Text -data SwaggerOAuth2Flow - = SwaggerOAuth2Implicit AuthorizationURL - | SwaggerOAuth2Password TokenURL - | SwaggerOAuth2Application TokenURL - | SwaggerOAuth2AccessCode AuthorizationURL TokenURL +data OAuth2Flow + = OAuth2Implicit AuthorizationURL + | OAuth2Password TokenURL + | OAuth2Application TokenURL + | OAuth2AccessCode AuthorizationURL TokenURL deriving (Eq, Show) -data SwaggerOAuth2Params = SwaggerOAuth2Params +data OAuth2Params = OAuth2Params { -- | The flow used by the OAuth2 security scheme. - _swaggerOAuth2Flow :: SwaggerOAuth2Flow + _oauth2Flow :: OAuth2Flow -- | The available scopes for the OAuth2 security scheme. - , _swaggerOAuth2Scopes :: HashMap Text Text + , _oauth2Scopes :: HashMap Text Text } deriving (Eq, Show, Generic) -data SwaggerSecuritySchemeType - = SwaggerSecuritySchemeBasic - | SwaggerSecuritySchemeApiKey SwaggerApiKeyParams - | SwaggerSecuritySchemeOAuth2 SwaggerOAuth2Params +data SecuritySchemeType + = SecuritySchemeBasic + | SecuritySchemeApiKey ApiKeyParams + | SecuritySchemeOAuth2 OAuth2Params deriving (Eq, Show) -data SwaggerSecurityScheme = SwaggerSecurityScheme +data SecurityScheme = SecurityScheme { -- | The type of the security scheme. - _swaggerSecuritySchemeType :: SwaggerSecuritySchemeType + _securitySchemeType :: SecuritySchemeType -- | A short description for security scheme. - , _swaggerSecuritySchemeDescription :: Maybe Text + , _securitySchemeDescription :: Maybe Text } deriving (Eq, Show, Generic) -- | 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). -newtype SwaggerSecurityRequirement = SwaggerSecurityRequirement - { getSwaggerSecurityRequirement :: HashMap Text [Text] +newtype SecurityRequirement = SecurityRequirement + { getSecurityRequirement :: HashMap Text [Text] } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON) --- | Allows adding meta data to a single tag that is used by @SwaggerOperation@. --- It is not mandatory to have a @SwaggerTag@ per tag used there. -data SwaggerTag = SwaggerTag +-- | Allows adding meta data to a single tag that is used by @Operation@. +-- It is not mandatory to have a @Tag@ per tag used there. +data Tag = Tag { -- | The name of the tag. - _swaggerTagName :: Text + _tagName :: Text -- | A short description for the tag. -- GFM syntax can be used for rich text representation. - , _swaggerTagDescription :: Maybe Text + , _tagDescription :: Maybe Text -- | Additional external documentation for this tag. - , _swaggerTagExternalDocs :: Maybe SwaggerExternalDocs + , _tagExternalDocs :: Maybe ExternalDocs } deriving (Eq, Show) -- | Allows referencing an external resource for extended documentation. -data SwaggerExternalDocs = SwaggerExternalDocs +data ExternalDocs = ExternalDocs { -- | A short description of the target documentation. -- GFM syntax can be used for rich text representation. - _swaggerExternalDocsDescription :: Maybe Text + _externalDocsDescription :: Maybe Text -- | The URL for the target documentation. - , _swaggerExternalDocsUrl :: URL + , _externalDocsUrl :: URL } deriving (Eq, Show, Generic) -- | A simple object to allow referencing other definitions in the specification. -- It can be used to reference parameters and responses that are defined at the top level for reuse. -newtype SwaggerReference = SwaggerReference { getSwaggerReference :: Text } +newtype Reference = Reference { getReference :: Text } deriving (Eq, Show) -data SwaggerReferenced a - = SwaggerRef SwaggerReference - | SwaggerInline a +data Referenced a + = Ref Reference + | Inline a deriving (Eq, Show) newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON) @@ -643,47 +641,47 @@ mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerInfo where +instance Monoid Info where mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerPaths where +instance Monoid Paths where mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerPathItem where +instance Monoid PathItem where mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerSchema where +instance Monoid Schema where mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerSchemaCommon where +instance Monoid SchemaCommon where mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerParameter where +instance Monoid Parameter where mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerParameterOtherSchema where +instance Monoid ParameterOtherSchema where mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerResponses where +instance Monoid Responses where mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerResponse where +instance Monoid Response where mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerExternalDocs where +instance Monoid ExternalDocs where mempty = genericMempty mappend = genericMappend -instance Monoid SwaggerOperation where +instance Monoid Operation where mempty = genericMempty mappend = genericMappend @@ -691,319 +689,319 @@ -- SwaggerMonoid helper instances -- ======================================================================= -instance SwaggerMonoid SwaggerInfo -instance SwaggerMonoid SwaggerPaths -instance SwaggerMonoid SwaggerPathItem -instance SwaggerMonoid SwaggerSchema -instance SwaggerMonoid SwaggerSchemaCommon -instance SwaggerMonoid SwaggerParameter -instance SwaggerMonoid SwaggerParameterOtherSchema -instance SwaggerMonoid SwaggerResponses -instance SwaggerMonoid SwaggerResponse -instance SwaggerMonoid SwaggerExternalDocs -instance SwaggerMonoid SwaggerOperation +instance SwaggerMonoid Info +instance SwaggerMonoid Paths +instance SwaggerMonoid PathItem +instance SwaggerMonoid Schema +instance SwaggerMonoid SchemaCommon +instance SwaggerMonoid Parameter +instance SwaggerMonoid ParameterOtherSchema +instance SwaggerMonoid Responses +instance SwaggerMonoid Response +instance SwaggerMonoid ExternalDocs +instance SwaggerMonoid Operation -instance SwaggerMonoid SwaggerMimeList +instance SwaggerMonoid MimeList deriving instance SwaggerMonoid URL -instance SwaggerMonoid SwaggerSchemaType where - swaggerMempty = SwaggerSchemaNull +instance SwaggerMonoid SchemaType where + swaggerMempty = SchemaNull swaggerMappend _ y = y -instance SwaggerMonoid SwaggerParameterType where - swaggerMempty = SwaggerParamString +instance SwaggerMonoid ParameterType where + swaggerMempty = ParamString swaggerMappend _ y = y -instance SwaggerMonoid SwaggerParameterLocation where - swaggerMempty = SwaggerParameterQuery +instance SwaggerMonoid ParameterLocation where + swaggerMempty = ParameterQuery swaggerMappend _ y = y -instance SwaggerMonoid (HashMap Text SwaggerSchema) where +instance SwaggerMonoid (HashMap Text Schema) where swaggerMempty = HashMap.empty swaggerMappend = HashMap.unionWith mappend -instance SwaggerMonoid (HashMap Text (SwaggerReferenced SwaggerSchema)) where +instance SwaggerMonoid (HashMap Text (Referenced Schema)) where swaggerMempty = HashMap.empty swaggerMappend = HashMap.unionWith swaggerMappend -instance Monoid a => SwaggerMonoid (SwaggerReferenced a) where - swaggerMempty = SwaggerInline mempty - swaggerMappend (SwaggerInline x) (SwaggerInline y) = SwaggerInline (x <> y) +instance Monoid a => SwaggerMonoid (Referenced a) where + swaggerMempty = Inline mempty + swaggerMappend (Inline x) (Inline y) = Inline (x <> y) swaggerMappend _ y = y -instance SwaggerMonoid (HashMap Text SwaggerParameter) where +instance SwaggerMonoid (HashMap Text Parameter) where swaggerMempty = HashMap.empty swaggerMappend = HashMap.unionWith mappend -instance SwaggerMonoid (HashMap Text SwaggerResponse) where +instance SwaggerMonoid (HashMap Text Response) where swaggerMempty = HashMap.empty swaggerMappend = flip HashMap.union -instance SwaggerMonoid (HashMap Text SwaggerSecurityScheme) where +instance SwaggerMonoid (HashMap Text SecurityScheme) where swaggerMempty = HashMap.empty swaggerMappend = flip HashMap.union -instance SwaggerMonoid (HashMap FilePath SwaggerPathItem) where +instance SwaggerMonoid (HashMap FilePath PathItem) where swaggerMempty = HashMap.empty swaggerMappend = HashMap.unionWith mappend -instance SwaggerMonoid (HashMap HeaderName SwaggerHeader) where +instance SwaggerMonoid (HashMap HeaderName Header) where swaggerMempty = HashMap.empty swaggerMappend = flip HashMap.union -instance SwaggerMonoid (HashMap HttpStatusCode (SwaggerReferenced SwaggerResponse)) where +instance SwaggerMonoid (HashMap HttpStatusCode (Referenced Response)) where swaggerMempty = HashMap.empty swaggerMappend = flip HashMap.union -instance SwaggerMonoid SwaggerParameterSchema where - swaggerMempty = SwaggerParameterOther swaggerMempty - swaggerMappend (SwaggerParameterBody x) (SwaggerParameterBody y) = SwaggerParameterBody (swaggerMappend x y) - swaggerMappend (SwaggerParameterOther x) (SwaggerParameterOther y) = SwaggerParameterOther (swaggerMappend x y) +instance SwaggerMonoid ParameterSchema where + swaggerMempty = ParameterOther swaggerMempty + swaggerMappend (ParameterBody x) (ParameterBody y) = ParameterBody (swaggerMappend x y) + swaggerMappend (ParameterOther x) (ParameterOther y) = ParameterOther (swaggerMappend x y) swaggerMappend _ y = y -- ======================================================================= -- TH derived ToJSON and FromJSON instances -- ======================================================================= -deriveJSON (jsonPrefix "SwaggerParameter") ''SwaggerParameterLocation -deriveJSON (jsonPrefix "SwaggerParam") ''SwaggerParameterType -deriveJSON' ''SwaggerInfo -deriveJSON' ''SwaggerContact -deriveJSON' ''SwaggerLicense -deriveJSON (jsonPrefix "SwaggerSchema") ''SwaggerSchemaType -deriveJSON (jsonPrefix "SwaggerItems") ''SwaggerItemsType -deriveJSON (jsonPrefix "SwaggerItemsCollection") ''SwaggerItemsCollectionFormat -deriveJSON (jsonPrefix "SwaggerCollection") ''SwaggerCollectionFormat -deriveJSON (jsonPrefix "SwaggerApiKey") ''SwaggerApiKeyLocation -deriveJSON (jsonPrefix "swaggerApiKey") ''SwaggerApiKeyParams -deriveJSON (jsonPrefix "swaggerSchema") ''SwaggerSchemaCommon -deriveJSONDefault ''SwaggerScheme -deriveJSON' ''SwaggerTag -deriveJSON' ''SwaggerExternalDocs +deriveJSON (jsonPrefix "Parameter") ''ParameterLocation +deriveJSON (jsonPrefix "Param") ''ParameterType +deriveJSON' ''Info +deriveJSON' ''Contact +deriveJSON' ''License +deriveJSON (jsonPrefix "Schema") ''SchemaType +deriveJSON (jsonPrefix "Items") ''ItemsType +deriveJSON (jsonPrefix "ItemsCollection") ''ItemsCollectionFormat +deriveJSON (jsonPrefix "Collection") ''CollectionFormat +deriveJSON (jsonPrefix "ApiKey") ''ApiKeyLocation +deriveJSON (jsonPrefix "apiKey") ''ApiKeyParams +deriveJSON' ''SchemaCommon +deriveJSONDefault ''Scheme +deriveJSON' ''Tag +deriveJSON' ''ExternalDocs -deriveToJSON' ''SwaggerOperation -deriveToJSON' ''SwaggerResponse -deriveToJSON' ''SwaggerPathItem -deriveToJSON' ''SwaggerXml +deriveToJSON' ''Operation +deriveToJSON' ''Response +deriveToJSON' ''PathItem +deriveToJSON' ''Xml -- ======================================================================= -- Manual ToJSON instances -- ======================================================================= -instance ToJSON SwaggerOAuth2Flow where - toJSON (SwaggerOAuth2Implicit authUrl) = object +instance ToJSON OAuth2Flow where + toJSON (OAuth2Implicit authUrl) = object [ "flow" .= ("implicit" :: Text) , "authorizationUrl" .= authUrl ] - toJSON (SwaggerOAuth2Password tokenUrl) = object + toJSON (OAuth2Password tokenUrl) = object [ "flow" .= ("password" :: Text) , "tokenUrl" .= tokenUrl ] - toJSON (SwaggerOAuth2Application tokenUrl) = object + toJSON (OAuth2Application tokenUrl) = object [ "flow" .= ("application" :: Text) , "tokenUrl" .= tokenUrl ] - toJSON (SwaggerOAuth2AccessCode authUrl tokenUrl) = object + toJSON (OAuth2AccessCode authUrl tokenUrl) = object [ "flow" .= ("accessCode" :: Text) , "authorizationUrl" .= authUrl , "tokenUrl" .= tokenUrl ] -instance ToJSON SwaggerOAuth2Params where - toJSON = genericToJSONWithSub "flow" (jsonPrefix "swaggerOAuth2") +instance ToJSON OAuth2Params where + toJSON = genericToJSONWithSub "flow" (jsonPrefix "oauth2") -instance ToJSON SwaggerSecuritySchemeType where - toJSON SwaggerSecuritySchemeBasic +instance ToJSON SecuritySchemeType where + toJSON SecuritySchemeBasic = object [ "type" .= ("basic" :: Text) ] - toJSON (SwaggerSecuritySchemeApiKey params) + toJSON (SecuritySchemeApiKey params) = toJSON params <+> object [ "type" .= ("apiKey" :: Text) ] - toJSON (SwaggerSecuritySchemeOAuth2 params) + toJSON (SecuritySchemeOAuth2 params) = toJSON params <+> object [ "type" .= ("oauth2" :: Text) ] instance ToJSON Swagger where - toJSON = addVersion . genericToJSON (jsonPrefix "swagger") + toJSON = addVersion . genericToJSON (jsonPrefix "") where addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o) addVersion _ = error "impossible" -instance ToJSON SwaggerSecurityScheme where - toJSON = genericToJSONWithSub "type" (jsonPrefix "swaggerSecurityScheme") +instance ToJSON SecurityScheme where + toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme") -instance ToJSON SwaggerSchema where - toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerSchema") +instance ToJSON Schema where + toJSON = genericToJSONWithSub "schemaCommon" (jsonPrefix "schema") -instance ToJSON SwaggerHeader where - toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerHeader") +instance ToJSON Header where + toJSON = genericToJSONWithSub "common" (jsonPrefix "header") -instance ToJSON SwaggerItems where - toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerItems") +instance ToJSON Items where + toJSON = genericToJSONWithSub "common" (jsonPrefix "items") -instance ToJSON SwaggerHost where - toJSON (SwaggerHost host mport) = toJSON $ +instance ToJSON Host where + toJSON (Host host mport) = toJSON $ case mport of Nothing -> host Just port -> host ++ ":" ++ show port -instance ToJSON SwaggerPaths where - toJSON (SwaggerPaths m) = toJSON m +instance ToJSON Paths where + toJSON (Paths m) = toJSON m -instance ToJSON SwaggerMimeList where - toJSON (SwaggerMimeList xs) = toJSON (map show xs) +instance ToJSON MimeList where + toJSON (MimeList xs) = toJSON (map show xs) -instance ToJSON SwaggerParameter where - toJSON = genericToJSONWithSub "schema" (jsonPrefix "swaggerParameter") +instance ToJSON Parameter where + toJSON = genericToJSONWithSub "schema" (jsonPrefix "parameter") -instance ToJSON SwaggerParameterSchema where - toJSON (SwaggerParameterBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ] - toJSON (SwaggerParameterOther s) = toJSON s +instance ToJSON ParameterSchema where + toJSON (ParameterBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ] + toJSON (ParameterOther s) = toJSON s -instance ToJSON SwaggerParameterOtherSchema where - toJSON = genericToJSONWithSub "common" (jsonPrefix "swaggerParameterOtherSchema") +instance ToJSON ParameterOtherSchema where + toJSON = genericToJSONWithSub "common" (jsonPrefix "parameterOtherSchema") -instance ToJSON SwaggerSchemaItems where - toJSON (SwaggerSchemaItemsObject x) = toJSON x - toJSON (SwaggerSchemaItemsArray xs) = toJSON xs +instance ToJSON SchemaItems where + toJSON (SchemaItemsObject x) = toJSON x + toJSON (SchemaItemsArray xs) = toJSON xs -instance ToJSON SwaggerResponses where - toJSON (SwaggerResponses def rs) = toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ] +instance ToJSON Responses where + toJSON (Responses def rs) = toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ] -instance ToJSON SwaggerExample where - toJSON = toJSON . Map.mapKeys show . getSwaggerExample +instance ToJSON Example where + toJSON = toJSON . Map.mapKeys show . getExample -instance ToJSON SwaggerReference where - toJSON (SwaggerReference ref) = object [ "$ref" .= ref ] +instance ToJSON Reference where + toJSON (Reference ref) = object [ "$ref" .= ref ] -instance ToJSON a => ToJSON (SwaggerReferenced a) where - toJSON (SwaggerRef ref) = toJSON ref - toJSON (SwaggerInline x) = toJSON x +instance ToJSON a => ToJSON (Referenced a) where + toJSON (Ref ref) = toJSON ref + toJSON (Inline x) = toJSON x -- ======================================================================= -- Manual FromJSON instances -- ======================================================================= -instance FromJSON SwaggerOAuth2Flow where +instance FromJSON OAuth2Flow where parseJSON (Object o) = do (flow :: Text) <- o .: "flow" case flow of - "implicit" -> SwaggerOAuth2Implicit <$> o .: "authorizationUrl" - "password" -> SwaggerOAuth2Password <$> o .: "tokenUrl" - "application" -> SwaggerOAuth2Application <$> o .: "tokenUrl" - "accessCode" -> SwaggerOAuth2AccessCode + "implicit" -> OAuth2Implicit <$> o .: "authorizationUrl" + "password" -> OAuth2Password <$> o .: "tokenUrl" + "application" -> OAuth2Application <$> o .: "tokenUrl" + "accessCode" -> OAuth2AccessCode <$> o .: "authorizationUrl" <*> o .: "tokenUrl" _ -> empty parseJSON _ = empty -instance FromJSON SwaggerOAuth2Params where - parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "swaggerOAuth2") +instance FromJSON OAuth2Params where + parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2") -instance FromJSON SwaggerSecuritySchemeType where - parseJSON json@(Object o) = do +instance FromJSON SecuritySchemeType where + parseJSON js@(Object o) = do (t :: Text) <- o .: "type" case t of - "basic" -> pure SwaggerSecuritySchemeBasic - "apiKey" -> SwaggerSecuritySchemeApiKey <$> parseJSON json - "oauth2" -> SwaggerSecuritySchemeOAuth2 <$> parseJSON json + "basic" -> pure SecuritySchemeBasic + "apiKey" -> SecuritySchemeApiKey <$> parseJSON js + "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js _ -> empty parseJSON _ = empty instance FromJSON Swagger where - parseJSON json@(Object o) = do + parseJSON js@(Object o) = do (version :: Text) <- o .: "swagger" when (version /= "2.0") empty - (genericParseJSON (jsonPrefix "swagger") - `withDefaults` [ "consumes" .= (mempty :: SwaggerMimeList) - , "produces" .= (mempty :: SwaggerMimeList) - , "security" .= ([] :: [SwaggerSecurityRequirement]) - , "tags" .= ([] :: [SwaggerTag]) - , "definitions" .= (mempty :: HashMap Text SwaggerSchema) - , "parameters" .= (mempty :: HashMap Text SwaggerParameter) - , "responses" .= (mempty :: HashMap Text SwaggerResponse) - , "securityDefinitions" .= (mempty :: HashMap Text SwaggerSecurityScheme) - ] ) json + (genericParseJSON (jsonPrefix "") + `withDefaults` [ "consumes" .= (mempty :: MimeList) + , "produces" .= (mempty :: MimeList) + , "security" .= ([] :: [SecurityRequirement]) + , "tags" .= ([] :: [Tag]) + , "definitions" .= (mempty :: HashMap Text Schema) + , "parameters" .= (mempty :: HashMap Text Parameter) + , "responses" .= (mempty :: HashMap Text Response) + , "securityDefinitions" .= (mempty :: HashMap Text SecurityScheme) + ] ) js parseJSON _ = empty -instance FromJSON SwaggerSecurityScheme where - parseJSON = genericParseJSONWithSub "type" (jsonPrefix "swaggerSecurityScheme") +instance FromJSON SecurityScheme where + parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme") -instance FromJSON SwaggerSchema where - parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerSchema") - `withDefaults` [ "properties" .= (mempty :: HashMap Text SwaggerSchema) - , "required" .= ([] :: [SwaggerParamName]) ] +instance FromJSON Schema where + parseJSON = genericParseJSONWithSub "schemaCommon" (jsonPrefix "schema") + `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema) + , "required" .= ([] :: [ParamName]) ] -instance FromJSON SwaggerHeader where - parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerHeader") +instance FromJSON Header where + parseJSON = genericParseJSONWithSub "common" (jsonPrefix "header") -instance FromJSON SwaggerItems where - parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerItems") +instance FromJSON Items where + parseJSON = genericParseJSONWithSub "common" (jsonPrefix "items") -instance FromJSON SwaggerHost where +instance FromJSON Host where parseJSON (String s) = case fromInteger <$> readMaybe portStr of Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'" - mport -> pure $ SwaggerHost host mport + mport -> pure $ Host host mport where (hostText, portText) = Text.breakOn ":" s [host, portStr] = map Text.unpack [hostText, portText] parseJSON _ = empty -instance FromJSON SwaggerPaths where - parseJSON json = SwaggerPaths <$> parseJSON json +instance FromJSON Paths where + parseJSON js = Paths <$> parseJSON js -instance FromJSON SwaggerMimeList where - parseJSON json = (SwaggerMimeList . map fromString) <$> parseJSON json +instance FromJSON MimeList where + parseJSON js = (MimeList . map fromString) <$> parseJSON js -instance FromJSON SwaggerParameter where - parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "swaggerParameter") +instance FromJSON Parameter where + parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "parameter") -instance FromJSON SwaggerParameterSchema where - parseJSON json@(Object o) = do +instance FromJSON ParameterSchema where + parseJSON js@(Object o) = do (i :: Text) <- o .: "in" case i of "body" -> do schema <- o .: "schema" - SwaggerParameterBody <$> parseJSON schema - _ -> SwaggerParameterOther <$> parseJSON json + ParameterBody <$> parseJSON schema + _ -> ParameterOther <$> parseJSON js parseJSON _ = empty -instance FromJSON SwaggerParameterOtherSchema where - parseJSON = genericParseJSONWithSub "common" (jsonPrefix "swaggerParameterOtherSchema") +instance FromJSON ParameterOtherSchema where + parseJSON = genericParseJSONWithSub "common" (jsonPrefix "parameterOtherSchema") -instance FromJSON SwaggerSchemaItems where - parseJSON json@(Object _) = SwaggerSchemaItemsObject <$> parseJSON json - parseJSON json@(Array _) = SwaggerSchemaItemsArray <$> parseJSON json +instance FromJSON SchemaItems where + parseJSON js@(Object _) = SchemaItemsObject <$> parseJSON js + parseJSON js@(Array _) = SchemaItemsArray <$> parseJSON js parseJSON _ = empty -instance FromJSON SwaggerResponses where - parseJSON (Object o) = SwaggerResponses +instance FromJSON Responses where + parseJSON (Object o) = Responses <$> o .:? "default" <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys) parseJSON _ = empty -instance FromJSON SwaggerExample where - parseJSON json = do - m <- parseJSON json - pure $ SwaggerExample (Map.mapKeys fromString m) +instance FromJSON Example where + parseJSON js = do + m <- parseJSON js + pure $ Example (Map.mapKeys fromString m) -instance FromJSON SwaggerResponse where - parseJSON = genericParseJSON (jsonPrefix "swaggerResponse") - `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName SwaggerHeader) ] +instance FromJSON Response where + parseJSON = genericParseJSON (jsonPrefix "response") + `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ] -instance FromJSON SwaggerOperation where - parseJSON = genericParseJSON (jsonPrefix "swaggerOperation") - `withDefaults` [ "security" .= ([] :: [SwaggerSecurityRequirement]) ] +instance FromJSON Operation where + parseJSON = genericParseJSON (jsonPrefix "operation") + `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) ] -instance FromJSON SwaggerPathItem where - parseJSON = genericParseJSON (jsonPrefix "swaggerPathItem") - `withDefaults` [ "parameters" .= ([] :: [SwaggerParameter]) ] +instance FromJSON PathItem where + parseJSON = genericParseJSON (jsonPrefix "pathItem") + `withDefaults` [ "parameters" .= ([] :: [Parameter]) ] -instance FromJSON SwaggerReference where - parseJSON (Object o) = SwaggerReference <$> o .: "$ref" +instance FromJSON Reference where + parseJSON (Object o) = Reference <$> o .: "$ref" parseJSON _ = empty -instance FromJSON a => FromJSON (SwaggerReferenced a) where - parseJSON json - = SwaggerRef <$> parseJSON json - <|> SwaggerInline <$> parseJSON json +instance FromJSON a => FromJSON (Referenced a) where + parseJSON js + = Ref <$> parseJSON js + <|> Inline <$> parseJSON js -instance FromJSON SwaggerXml where - parseJSON = genericParseJSON (jsonPrefix "swaggerXml") +instance FromJSON Xml where + parseJSON = genericParseJSON (jsonPrefix "xml") diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -15,7 +15,6 @@ import qualified Data.HashMap.Strict as HashMap import Data.Monoid import Data.Text (Text) -import Data.Traversable import GHC.Generics import Language.Haskell.TH import Text.Read (readMaybe) @@ -36,6 +35,7 @@ { fieldLabelModifier = modifier . drop 1 , constructorTagModifier = modifier , sumEncoding = ObjectWithSingleField + , omitNothingFields = True } where modifier = lowerFirstUppers . drop (length prefix) @@ -58,20 +58,20 @@ Object o -> let so = HashMap.lookupDefault (error "impossible") sub o in Object (HashMap.delete sub o) <+> so - _ -> error "impossible" + _ -> error "genericToJSONWithSub: subjson is not an object" genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a -genericParseJSONWithSub sub opts (Object o) = genericParseJSON opts json +genericParseJSONWithSub sub opts (Object o) = genericParseJSON opts js where - json = Object (HashMap.insert sub (Object o) o) -genericParseJSONWithSub _ _ _ = error "impossible" + js = Object (HashMap.insert sub (Object o) o) +genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object" (<+>) :: Value -> Value -> Value Object x <+> Object y = Object (x <> y) -_ <+> _ = error "impossible" +_ <+> _ = error "<+>: merging non-objects" withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a -withDefaults parser defs json@(Object _) = parser (json <+> object defs) +withDefaults parser defs js@(Object _) = parser (js <+> object defs) withDefaults _ _ _ = empty genericMempty :: (Generic a, GMonoid (Rep a)) => a diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -5,8 +5,8 @@ module Data.Swagger.Lens where import Control.Lens -import Control.Lens.TH import Data.Aeson (Value) +import Data.Scientific (Scientific) import Data.Swagger.Internal import Data.Text (Text) @@ -15,30 +15,30 @@ -- ======================================================================= makeLenses ''Swagger -makeLenses ''SwaggerHost -makeLenses ''SwaggerInfo -makeLenses ''SwaggerContact -makeLenses ''SwaggerLicense -makeLenses ''SwaggerPaths -makeLenses ''SwaggerPathItem -makeLenses ''SwaggerTag -makeLenses ''SwaggerOperation -makeLenses ''SwaggerParameter -makePrisms ''SwaggerParameterSchema -makeLenses ''SwaggerParameterOtherSchema -makeLenses ''SwaggerItems -makeLenses ''SwaggerHeader -makeLenses ''SwaggerSchema -makePrisms ''SwaggerSchemaItems -makeLenses ''SwaggerSchemaCommon -makeLenses ''SwaggerXml -makeLenses ''SwaggerResponses -makeLenses ''SwaggerResponse -makeLenses ''SwaggerSecurityScheme -makePrisms ''SwaggerSecuritySchemeType -makeLenses ''SwaggerApiKeyParams -makeLenses ''SwaggerOAuth2Params -makeLenses ''SwaggerExternalDocs +makeLenses ''Host +makeLenses ''Info +makeLenses ''Contact +makeLenses ''License +makeLenses ''Paths +makeLenses ''PathItem +makeLenses ''Tag +makeLenses ''Operation +makeLenses ''Parameter +makePrisms ''ParameterSchema +makeLenses ''ParameterOtherSchema +makeLenses ''Items +makeLenses ''Header +makeLenses ''Schema +makePrisms ''SchemaItems +makeLenses ''SchemaCommon +makeLenses ''Xml +makeLenses ''Responses +makeLenses ''Response +makeLenses ''SecurityScheme +makePrisms ''SecuritySchemeType +makeLenses ''ApiKeyParams +makeLenses ''OAuth2Params +makeLenses ''ExternalDocs -- ======================================================================= -- Helper classy lenses @@ -47,61 +47,61 @@ class HasDescription s d | s -> d where description :: Lens' s d -instance HasDescription SwaggerResponse Text where description = swaggerResponseDescription -instance HasDescription SwaggerInfo (Maybe Text) where description = swaggerInfoDescription -instance HasDescription SwaggerTag (Maybe Text) where description = swaggerTagDescription -instance HasDescription SwaggerOperation (Maybe Text) where description = swaggerOperationDescription -instance HasDescription SwaggerParameter (Maybe Text) where description = swaggerParameterDescription -instance HasDescription SwaggerHeader (Maybe Text) where description = swaggerHeaderDescription -instance HasDescription SwaggerSchema (Maybe Text) where description = swaggerSchemaDescription -instance HasDescription SwaggerSecurityScheme (Maybe Text) where description = swaggerSecuritySchemeDescription -instance HasDescription SwaggerExternalDocs (Maybe Text) where description = swaggerExternalDocsDescription +instance HasDescription Response Text where description = responseDescription +instance HasDescription Info (Maybe Text) where description = infoDescription +instance HasDescription Tag (Maybe Text) where description = tagDescription +instance HasDescription Operation (Maybe Text) where description = operationDescription +instance HasDescription Parameter (Maybe Text) where description = parameterDescription +instance HasDescription Header (Maybe Text) where description = headerDescription +instance HasDescription Schema (Maybe Text) where description = schemaDescription +instance HasDescription SecurityScheme (Maybe Text) where description = securitySchemeDescription +instance HasDescription ExternalDocs (Maybe Text) where description = externalDocsDescription -class HasSwaggerSchemaCommon s where - schemaCommon :: Lens' s SwaggerSchemaCommon +class HasSchemaCommon s where + schemaCommon :: Lens' s SchemaCommon -instance HasSwaggerSchemaCommon SwaggerSchema where schemaCommon = swaggerSchemaCommon -instance HasSwaggerSchemaCommon SwaggerParameterOtherSchema where schemaCommon = swaggerParameterOtherSchemaCommon -instance HasSwaggerSchemaCommon SwaggerItems where schemaCommon = swaggerItemsCommon -instance HasSwaggerSchemaCommon SwaggerHeader where schemaCommon = swaggerHeaderCommon -instance HasSwaggerSchemaCommon SwaggerSchemaCommon where schemaCommon = id +instance HasSchemaCommon Schema where schemaCommon = schemaSchemaCommon +instance HasSchemaCommon ParameterOtherSchema where schemaCommon = parameterOtherSchemaCommon +instance HasSchemaCommon Items where schemaCommon = itemsCommon +instance HasSchemaCommon Header where schemaCommon = headerCommon +instance HasSchemaCommon SchemaCommon where schemaCommon = id -schemaDefault :: HasSwaggerSchemaCommon s => Lens' s (Maybe Value) -schemaDefault = schemaCommon.swaggerSchemaDefault +schemaDefault :: HasSchemaCommon s => Lens' s (Maybe Value) +schemaDefault = schemaCommon.schemaCommonDefault -schemaMaximum :: HasSwaggerSchemaCommon s => Lens' s (Maybe Integer) -schemaMaximum = schemaCommon.swaggerSchemaMaximum +schemaMaximum :: HasSchemaCommon s => Lens' s (Maybe Scientific) +schemaMaximum = schemaCommon.schemaCommonMaximum -schemaExclusiveMaximum :: HasSwaggerSchemaCommon s => Lens' s (Maybe Bool) -schemaExclusiveMaximum = schemaCommon.swaggerSchemaExclusiveMaximum +schemaExclusiveMaximum :: HasSchemaCommon s => Lens' s (Maybe Bool) +schemaExclusiveMaximum = schemaCommon.schemaCommonExclusiveMaximum -schemaMinimum :: HasSwaggerSchemaCommon s => Lens' s (Maybe Integer) -schemaMinimum = schemaCommon.swaggerSchemaMinimum +schemaMinimum :: HasSchemaCommon s => Lens' s (Maybe Scientific) +schemaMinimum = schemaCommon.schemaCommonMinimum -schemaExclusiveMinimum :: HasSwaggerSchemaCommon s => Lens' s (Maybe Bool) -schemaExclusiveMinimum = schemaCommon.swaggerSchemaExclusiveMinimum +schemaExclusiveMinimum :: HasSchemaCommon s => Lens' s (Maybe Bool) +schemaExclusiveMinimum = schemaCommon.schemaCommonExclusiveMinimum -schemaMaxLength :: HasSwaggerSchemaCommon s => Lens' s (Maybe Integer) -schemaMaxLength = schemaCommon.swaggerSchemaMaxLength +schemaMaxLength :: HasSchemaCommon s => Lens' s (Maybe Integer) +schemaMaxLength = schemaCommon.schemaCommonMaxLength -schemaMinLength :: HasSwaggerSchemaCommon s => Lens' s (Maybe Integer) -schemaMinLength = schemaCommon.swaggerSchemaMinLength +schemaMinLength :: HasSchemaCommon s => Lens' s (Maybe Integer) +schemaMinLength = schemaCommon.schemaCommonMinLength -schemaPattern :: HasSwaggerSchemaCommon s => Lens' s (Maybe Text) -schemaPattern = schemaCommon.swaggerSchemaPattern +schemaPattern :: HasSchemaCommon s => Lens' s (Maybe Text) +schemaPattern = schemaCommon.schemaCommonPattern -schemaMaxItems :: HasSwaggerSchemaCommon s => Lens' s (Maybe Integer) -schemaMaxItems = schemaCommon.swaggerSchemaMaxItems +schemaMaxItems :: HasSchemaCommon s => Lens' s (Maybe Integer) +schemaMaxItems = schemaCommon.schemaCommonMaxItems -schemaMinItems :: HasSwaggerSchemaCommon s => Lens' s (Maybe Integer) -schemaMinItems = schemaCommon.swaggerSchemaMinItems +schemaMinItems :: HasSchemaCommon s => Lens' s (Maybe Integer) +schemaMinItems = schemaCommon.schemaCommonMinItems -schemaUniqueItems :: HasSwaggerSchemaCommon s => Lens' s (Maybe Bool) -schemaUniqueItems = schemaCommon.swaggerSchemaUniqueItems +schemaUniqueItems :: HasSchemaCommon s => Lens' s (Maybe Bool) +schemaUniqueItems = schemaCommon.schemaCommonUniqueItems -schemaEnum :: HasSwaggerSchemaCommon s => Lens' s (Maybe [Value]) -schemaEnum = schemaCommon.swaggerSchemaEnum +schemaEnum :: HasSchemaCommon s => Lens' s (Maybe [Value]) +schemaEnum = schemaCommon.schemaCommonEnum -schemaMultipleOf :: HasSwaggerSchemaCommon s => Lens' s (Maybe Integer) -schemaMultipleOf = schemaCommon.swaggerSchemaMultipleOf +schemaMultipleOf :: HasSchemaCommon s => Lens' s (Maybe Scientific) +schemaMultipleOf = schemaCommon.schemaCommonMultipleOf diff --git a/src/Data/Swagger/Schema.hs b/src/Data/Swagger/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Swagger/Schema.hs @@ -0,0 +1,28 @@ +-- | +-- Module: Data.Swagger.Schema +-- Copyright: (c) 2015 GetShopTV +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Types and functions for working with Swagger schema. +module Data.Swagger.Schema ( + -- * Encoding + ToSchema(..), + NamedSchema, + toSchema, + toSchemaRef, + schemaName, + + -- * Generic schema encoding + genericToSchema, + genericToNamedSchema, + genericToNamedSchemaBoundedIntegral, + toSchemaBoundedIntegral, + + -- * Generic encoding configuration + SchemaOptions(..), + defaultSchemaOptions, +) where + +import Data.Swagger.Schema.Internal diff --git a/src/Data/Swagger/Schema/Internal.hs b/src/Data/Swagger/Schema/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Swagger/Schema/Internal.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Data.Swagger.Schema.Internal where + +import Control.Lens +import Data.Aeson +import Data.Char +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.Int +import Data.IntSet (IntSet) +import Data.IntMap (IntMap) +import Data.Map (Map) +import Data.Monoid +import Data.Proxy +import Data.Scientific (Scientific) +import Data.Set (Set) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Time +import Data.Word +import GHC.Generics + +import Data.Swagger.Internal +import Data.Swagger.Lens + +-- | A @'Schema'@ with an optional name. +-- This name can be used in references. +type NamedSchema = (Maybe String, Schema) + +unnamed :: Schema -> NamedSchema +unnamed schema = (Nothing, schema) + +named :: String -> Schema -> NamedSchema +named name schema = (Just name, schema) + +-- | Convert a type into @'Schema'@. +-- +-- An example type and instance: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals +-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' as list +-- +-- import Control.Lens +-- +-- data Coord = Coord { x :: Double, y :: Double } +-- +-- instance ToSchema Coord where +-- toNamedSchema = (Just \"Coord\", mempty +-- & schemaType .~ SchemaObject +-- & schemaProperties .~ +-- [ ("x", toSchemaRef (Proxy :: Proxy Double)) +-- , ("y", toSchemaRef (Proxy :: Proxy Double)) +-- ] +-- & schemaRequired .~ [ "x", "y" ] +-- @ +-- +-- Instead of manually writing your @'ToSchema'@ instance you can +-- use a default generic implementation of @'toNamedSchema'@. +-- +-- To do that, simply add @deriving 'Generic'@ clause to your datatype +-- and declare a @'ToSchema'@ instance for your datatype without +-- giving definition for @'toNamedSchema'@. +-- +-- For instance, the previous example can be simplified into this: +-- +-- @ +-- {-\# LANGUAGE DeriveGeneric \#-} +-- +-- import GHC.Generics (Generic) +-- +-- data Coord = Coord { x :: Double, y :: Double } deriving Generic +-- +-- instance ToSchema Coord +-- @ +class ToSchema a where + -- | Convert a type into an optionally named schema. + toNamedSchema :: proxy a -> NamedSchema + default toNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> NamedSchema + toNamedSchema = genericToNamedSchema defaultSchemaOptions + +-- | Get type's schema name according to its @'ToSchema'@ instance. +schemaName :: ToSchema a => proxy a -> Maybe String +schemaName = fst . toNamedSchema + +-- | Convert a type into a schema. +toSchema :: ToSchema a => proxy a -> Schema +toSchema = snd . toNamedSchema + +-- | Convert a type into a referenced schema if possible. +-- Only named schemas can be references, nameless schemas are inlined. +toSchemaRef :: ToSchema a => proxy a -> Referenced Schema +toSchemaRef proxy = case toNamedSchema proxy of + (Just name, _) -> Ref (Reference ("#/definitions/" <> T.pack name)) + (_, schema) -> Inline schema + +class GToSchema (f :: * -> *) where + gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema + +gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema +gtoSchema opts proxy = snd . gtoNamedSchema opts proxy + +instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where + toNamedSchema _ = unnamed $ mempty + & schemaType .~ SchemaArray + & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a)) + +instance {-# OVERLAPPING #-} ToSchema String where + toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaString + +instance ToSchema Bool where + toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaBoolean + +instance ToSchema Integer where + toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaInteger + +instance ToSchema Int where toNamedSchema = unnamed . toSchemaBoundedIntegral +instance ToSchema Int8 where toNamedSchema = unnamed . toSchemaBoundedIntegral +instance ToSchema Int16 where toNamedSchema = unnamed . toSchemaBoundedIntegral +instance ToSchema Int32 where toNamedSchema = unnamed . toSchemaBoundedIntegral +instance ToSchema Int64 where toNamedSchema = unnamed . toSchemaBoundedIntegral + +instance ToSchema Word where toNamedSchema = unnamed . toSchemaBoundedIntegral +instance ToSchema Word8 where toNamedSchema = unnamed . toSchemaBoundedIntegral +instance ToSchema Word16 where toNamedSchema = unnamed . toSchemaBoundedIntegral +instance ToSchema Word32 where toNamedSchema = unnamed . toSchemaBoundedIntegral +instance ToSchema Word64 where toNamedSchema = unnamed . toSchemaBoundedIntegral + +instance ToSchema Char where + toNamedSchema _ = unnamed $ mempty + & schemaType .~ SchemaString + & schemaMaxLength ?~ 1 + & schemaMinLength ?~ 1 + +instance ToSchema Scientific where + toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber + +instance ToSchema Double where + toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber + +instance ToSchema Float where + toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber + +instance ToSchema a => ToSchema (Maybe a) where + toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) + +instance (ToSchema a, ToSchema b) => ToSchema (Either a b) + +instance ToSchema () +instance (ToSchema a, ToSchema b) => ToSchema (a, b) +instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) +instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) +instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) +instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) +instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) + +timeNamedSchema :: String -> String -> NamedSchema +timeNamedSchema name format = (Just name, mempty + & schemaType .~ SchemaString + & schemaFormat ?~ T.pack format + & schemaMinLength ?~ toInteger (length format)) + +-- | +-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat +-- Just "yyyy-mm-dd" +instance ToSchema Day where + toNamedSchema _ = timeNamedSchema "Day" "yyyy-mm-dd" + +-- | +-- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat +-- Just "yyyy-mm-ddThh:MM:ss" +instance ToSchema LocalTime where + toNamedSchema _ = timeNamedSchema "LocalTime" "yyyy-mm-ddThh:MM:ss" + +-- | +-- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat +-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)" +instance ToSchema ZonedTime where + toNamedSchema _ = (Just "ZonedTime", mempty + & schemaType .~ SchemaString + & schemaFormat ?~ "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)" + & schemaMinLength ?~ toInteger (length ("yyyy-mm-ddThh:MM:ssZ" :: String))) + +instance ToSchema NominalDiffTime where + toNamedSchema _ = toNamedSchema (Proxy :: Proxy Integer) + +-- | +-- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat +-- Just "yyyy-mm-ddThh:MM:ssZ" +instance ToSchema UTCTime where + toNamedSchema _ = timeNamedSchema "UTCTime" "yyyy-mm-ddThh:MM:ssZ" + +instance ToSchema T.Text where + toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String) + +instance ToSchema TL.Text where + toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String) + +instance ToSchema IntSet where toNamedSchema _ = toNamedSchema (Proxy :: Proxy (Set Int)) + +-- | NOTE: This schema does not account for the uniqueness of keys. +instance ToSchema a => ToSchema (IntMap a) where + toNamedSchema _ = toNamedSchema (Proxy :: Proxy [(Int, a)]) + +instance ToSchema a => ToSchema (Map String a) where + toNamedSchema _ = unnamed $ mempty + & schemaType .~ SchemaObject + & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a) + +instance ToSchema a => ToSchema (Map T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a)) +instance ToSchema a => ToSchema (Map TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a)) + +instance ToSchema a => ToSchema (HashMap String a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a)) +instance ToSchema a => ToSchema (HashMap T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a)) +instance ToSchema a => ToSchema (HashMap TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a)) + +instance ToSchema a => ToSchema (Set a) where + toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy [a]) + & schemaUniqueItems ?~ True + +instance ToSchema a => ToSchema (HashSet a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Set a)) + +instance ToSchema All where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool) +instance ToSchema Any where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool) +instance ToSchema a => ToSchema (Sum a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) +instance ToSchema a => ToSchema (Product a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) +instance ToSchema a => ToSchema (First a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) +instance ToSchema a => ToSchema (Last a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) +instance ToSchema a => ToSchema (Dual a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) + +-- | Options that specify how to encode your type to Swagger schema. +data SchemaOptions = SchemaOptions + { -- | Function applied to field labels. Handy for removing common record prefixes for example. + fieldLabelModifier :: String -> String + -- | Function applied to constructor tags which could be handy for lower-casing them for example. + , constructorTagModifier :: String -> String + -- | Function applied to datatype name. + , datatypeNameModifier :: String -> String + -- | If @'True'@ the constructors of a datatype, with all nullary constructors, + -- will be encoded to a string enumeration schema with the constructor tags as possible values. + , allNullaryToStringTag :: Bool + -- | If @'True'@ direct subschemas will be referenced if possible (rather than inlined). + -- Note that this option does not influence nested schemas, e.g. for these types + -- + -- @ + -- data Object = Object String deriving Generic + -- instance ToSchema Object + -- + -- newtype Objects = Objects [Object] deriving Generic + -- instance ToSchema Objects where + -- toNamedSchema = genericToNamedSchema defaultSchemaOptions + -- { useReferences = False } + -- @ + -- + -- Schema for @Objects@ __will not__ inline @Object@ schema because + -- it is nested in a @[]@ schema. + , useReferences :: Bool + -- | Hide the field name when a record constructor has only one field, like a newtype. + , unwrapUnaryRecords :: Bool + } + +-- | Default encoding @'SchemaOptions'@. +-- +-- @ +-- 'SchemaOptions' +-- { 'fieldLabelModifier' = id +-- , 'constructorTagModifier' = id +-- , 'datatypeNameModifier' = id +-- , 'allNullaryToStringTag' = True +-- , 'useReferences' = True +-- , 'unwrapUnaryRecords' = False +-- } +-- @ +defaultSchemaOptions :: SchemaOptions +defaultSchemaOptions = SchemaOptions + { fieldLabelModifier = id + , constructorTagModifier = id + , datatypeNameModifier = id + , allNullaryToStringTag = True + , useReferences = True + , unwrapUnaryRecords = False + } + +-- | Default schema for @'Bounded'@, @'Integral'@ types. +toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema +toSchemaBoundedIntegral _ = mempty + & schemaType .~ SchemaInteger + & schemaMinimum ?~ fromInteger (toInteger (minBound :: a)) + & schemaMaximum ?~ fromInteger (toInteger (maxBound :: a)) + +-- | Default generic named schema for @'Bounded'@, @'Integral'@ types. +genericToNamedSchemaBoundedIntegral :: forall a d f proxy. + ( Bounded a, Integral a + , Generic a, Rep a ~ D1 d f, Datatype d) + => SchemaOptions -> proxy a -> NamedSchema +genericToNamedSchemaBoundedIntegral opts proxy + = (gdatatypeSchemaName opts (Proxy :: Proxy d), toSchemaBoundedIntegral proxy) + +-- | A configurable generic @'Schema'@ creator. +genericToSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Schema +genericToSchema opts = snd . genericToNamedSchema opts + +-- | A configurable generic @'NamedSchema'@ creator. +-- This function applied to @'defaultSchemaOptions'@ +-- is used as the default for @'toNamedSchema'@ +-- when the type is an instance of @'Generic'@. +genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema +genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty + +gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String +gdatatypeSchemaName opts _ = case name of + (c:_) | isAlpha c && isUpper c -> Just name + _ -> Nothing + where + name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a)) + +nullarySchema :: Schema +nullarySchema = mempty + & schemaType .~ SchemaArray + & schemaEnum ?~ [ toJSON () ] + +instance GToSchema U1 where + gtoNamedSchema _ _ _ = unnamed nullarySchema + +instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where + gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g) + +instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where + gtoNamedSchema opts _ s = (name, gtoSchema opts (Proxy :: Proxy f) s) + where + name = gdatatypeSchemaName opts (Proxy :: Proxy d) + +instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where + gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) + +-- | Single field constructor. +instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where + gtoNamedSchema opts _ s + | unwrapUnaryRecords opts = fieldSchema + | otherwise = + case schema ^. schemaItems of + Just (SchemaItemsArray [_]) -> fieldSchema + _ -> unnamed schema + where + schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s + fieldSchema = gtoNamedSchema opts (Proxy :: Proxy f) s + +gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> Referenced Schema +gtoSchemaRef opts proxy = case gtoNamedSchema opts proxy mempty of + (Just name, _) + | useReferences opts -> Ref (Reference ("#/definitions/" <> T.pack name)) + (_, schema) -> Inline schema + +appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems +appendItem x Nothing = Just (SchemaItemsArray [x]) +appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs)) +appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject" + +withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Schema +withFieldSchema opts _ isRequiredField schema + | T.null fieldName = schema + & schemaType .~ SchemaArray + & schemaItems %~ appendItem fieldSchemaRef + | otherwise = schema + & schemaType .~ SchemaObject + & schemaProperties . at fieldName ?~ fieldSchemaRef + & if isRequiredField + then schemaRequired %~ (fieldName :) + else id + where + fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p))) + fieldSchemaRef = gtoSchemaRef opts (Proxy :: Proxy f) + +-- | Optional record fields. +instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where + gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False + +-- | Record fields. +instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where + gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True + +instance ToSchema c => GToSchema (K1 i c) where + gtoNamedSchema _ _ _ = toNamedSchema (Proxy :: Proxy c) + +instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where + gtoNamedSchema opts _ s + | allNullaryToStringTag opts && allNullary = unnamed (toStringTag sumSchema) + | otherwise = unnamed sumSchema + where + (All allNullary, sumSchema) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s + + toStringTag schema = mempty + & schemaType .~ SchemaString + & schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex) + +type AllNullary = All + +class GSumToSchema f where + gsumToSchema :: SchemaOptions -> proxy f -> Schema -> (AllNullary, Schema) + +instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where + gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) `after` gsumToSchema opts (Proxy :: Proxy g) + where + (f `after` g) s = (a <> b, s'') + where + (a, s') = f s + (b, s'') = g s' + +gsumConToSchema :: forall c f proxy. Constructor c => + Bool -> Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> (AllNullary, Schema) +gsumConToSchema isNullary tagSchemaRef opts _ schema = (All isNullary, schema + & schemaType .~ SchemaObject + & schemaProperties . at tag ?~ tagSchemaRef + & schemaMaxProperties ?~ 1 + & schemaMinProperties ?~ 1) + where + tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) + +instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where + gsumToSchema opts = gsumConToSchema False tagSchemaRef opts + where + tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c f)) + +instance Constructor c => GSumToSchema (C1 c U1) where + gsumToSchema opts = gsumConToSchema True tagSchemaRef opts + where + tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c U1)) + +instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where + gsumToSchema opts = gsumConToSchema False tagSchemaRef opts + where + tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c (S1 s f))) + +data Proxy2 a b = Proxy2 + +data Proxy3 a b c = Proxy3 + diff --git a/swagger2.cabal b/swagger2.cabal --- a/swagger2.cabal +++ b/swagger2.cabal @@ -1,5 +1,5 @@ name: swagger2 -version: 0.3 +version: 0.4 synopsis: Swagger 2.0 data model description: Please see README.md homepage: https://github.com/GetShopTV/swagger2 @@ -21,10 +21,12 @@ exposed-modules: Data.Swagger Data.Swagger.Lens + Data.Swagger.Schema -- internal modules Data.Swagger.Internal Data.Swagger.Internal.Utils + Data.Swagger.Schema.Internal build-depends: base == 4.* , aeson , containers @@ -33,8 +35,10 @@ , network , template-haskell , text + , time , unordered-containers , lens + , scientific default-language: Haskell2010 test-suite spec @@ -49,11 +53,21 @@ , text , aeson , aeson-qq + , containers , unordered-containers , vector other-modules: + SpecCommon Data.SwaggerSpec + Data.Swagger.SchemaSpec default-language: Haskell2010 + +test-suite doctest + build-depends: base, doctest, Glob + default-language: Haskell2010 + hs-source-dirs: test + main-is: DocTest.hs + type: exitcode-stdio-1.0 source-repository head type: git diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Swagger/SchemaSpec.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module Data.Swagger.SchemaSpec where + +import Data.Aeson +import Data.Aeson.QQ +import Data.Char +import Data.Proxy +import Data.Set (Set) +import GHC.Generics + +import Data.Swagger + +import SpecCommon +import Test.Hspec + +checkToSchema :: ToSchema a => Proxy a -> Value -> Spec +checkToSchema proxy js = toSchema proxy <~> js + +checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec +checkSchemaName sname proxy = + it ("schema name is " ++ show sname) $ + schemaName proxy `shouldBe` sname + +spec :: Spec +spec = do + describe "Generic ToSchema" $ do + context "Unit" $ checkToSchema (Proxy :: Proxy Unit) unitSchemaJSON + context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON + context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON + context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON + context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON + context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON + context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON + context "Unary records" $ do + context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON + context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON + context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON + context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON + context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON + context "Sum types" $ do + context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON + context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON + context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON + context "Schema name" $ do + context "String" $ checkSchemaName Nothing (Proxy :: Proxy String) + context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float)) + context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person) + +main :: IO () +main = hspec spec + +-- ======================================================================== +-- Person (simple record with optional fields) +-- ======================================================================== +data Person = Person + { name :: String + , phone :: Integer + , email :: Maybe String + } deriving (Generic, ToSchema) + +personSchemaJSON :: Value +personSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "name": { "type": "string" }, + "phone": { "type": "integer" }, + "email": { "type": "string" } + }, + "required": ["name", "phone"] +} +|] + +-- ======================================================================== +-- ISPair (non-record product data type) +-- ======================================================================== +data ISPair = ISPair Integer String + deriving (Generic, ToSchema) + +ispairSchemaJSON :: Value +ispairSchemaJSON = [aesonQQ| +{ + "type": "array", + "items": + [ + { "type": "integer" }, + { "type": "string" } + ] +} +|] + +-- ======================================================================== +-- Point (record data type with custom fieldLabelModifier) +-- ======================================================================== +data Point = Point + { pointX :: Double + , pointY :: Double + } deriving (Generic) + +instance ToSchema Point where + toNamedSchema = genericToNamedSchema defaultSchemaOptions + { fieldLabelModifier = map toLower . drop (length "point") } + +pointSchemaJSON :: Value +pointSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "x": { "type": "number" }, + "y": { "type": "number" } + }, + "required": ["x", "y"] +} +|] + + +-- ======================================================================== +-- Color (enum) +-- ======================================================================== +data Color + = Red + | Green + | Blue + deriving (Generic, ToSchema) + +colorSchemaJSON :: Value +colorSchemaJSON = [aesonQQ| +{ + "type": "string", + "enum": ["Red", "Green", "Blue"] +} +|] + +-- ======================================================================== +-- Paint (record with bounded enum property) +-- ======================================================================== + +newtype Paint = Paint { color :: Color } + deriving (Generic, ToSchema) + +paintSchemaJSON :: Value +paintSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "color": + { + "$ref": "#/definitions/Color" + } + }, + "required": ["color"] +} +|] + +-- ======================================================================== +-- Email (newtype with unwrapUnaryRecords set to True) +-- ======================================================================== + +newtype Email = Email { getEmail :: String } + deriving (Generic) + +instance ToSchema Email where + toNamedSchema = genericToNamedSchema defaultSchemaOptions + { unwrapUnaryRecords = True } + +emailSchemaJSON :: Value +emailSchemaJSON = [aesonQQ| +{ + "type": "string" +} +|] + +-- ======================================================================== +-- UserId (non-record newtype) +-- ======================================================================== + +newtype UserId = UserId Integer + deriving (Eq, Ord, Generic, ToSchema) + +userIdSchemaJSON :: Value +userIdSchemaJSON = [aesonQQ| +{ + "type": "integer" +} +|] + +-- ======================================================================== +-- UserGroup (set newtype) +-- ======================================================================== + +newtype UserGroup = UserGroup (Set UserId) + deriving (Generic, ToSchema) + +userGroupSchemaJSON :: Value +userGroupSchemaJSON = [aesonQQ| +{ + "type": "array", + "items": { "$ref": "#/definitions/UserId" }, + "uniqueItems": true +} +|] + +-- ======================================================================== +-- Player (record newtype) +-- ======================================================================== + +newtype Player = Player + { position :: Point + } deriving (Generic, ToSchema) + +playerSchemaJSON :: Value +playerSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] +} +|] + +-- ======================================================================== +-- MyRoseTree (custom datatypeNameModifier) +-- ======================================================================== + +data MyRoseTree = MyRoseTree + { root :: String + , trees :: [MyRoseTree] + } deriving (Generic) + +instance ToSchema MyRoseTree where + toNamedSchema = genericToNamedSchema defaultSchemaOptions + { datatypeNameModifier = drop (length "My") } + +myRoseTreeSchemaJSON :: Value +myRoseTreeSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "root": { "type": "string" }, + "trees": + { + "type": "array", + "items": + { + "$ref": "#/definitions/RoseTree" + } + } + }, + "required": ["root", "trees"] +} +|] + +-- ======================================================================== +-- Inlined (newtype for inlining schemas) +-- ======================================================================== + +newtype Inlined a = Inlined { getInlined :: a } + +instance ToSchema a => ToSchema (Inlined a) where + toNamedSchema _ = (Nothing, toSchema (Proxy :: Proxy a)) + +newtype Players = Players [Inlined Player] + deriving (Generic, ToSchema) + +playersSchemaJSON :: Value +playersSchemaJSON = [aesonQQ| +{ + "type": "array", + "items": + { + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] + } +} +|] + +-- ======================================================================== +-- Status (sum type with unary constructors) +-- ======================================================================== + +data Status + = StatusOk String + | StatusError String + deriving (Generic) + +instance ToSchema Status where + toNamedSchema = genericToNamedSchema defaultSchemaOptions + { constructorTagModifier = map toLower . drop (length "Status") } + +statusSchemaJSON :: Value +statusSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "ok": { "type": "string" }, + "error": { "type": "string" } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +-- ======================================================================== +-- Unit type +-- ======================================================================== + +data Unit = Unit deriving (Generic, ToSchema) + +unitSchemaJSON :: Value +unitSchemaJSON = [aesonQQ| +{ + "type": "array", + "enum": [[]] +} +|] + + +-- ======================================================================== +-- Character (sum type with ref and record in alternative) +-- ======================================================================== + +data Character + = PC Player + | NPC { npcName :: String, npcPosition :: Point } + deriving (Generic, ToSchema) + +characterSchemaJSON :: Value +characterSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "PC": { "$ref": "#/definitions/Player" }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": { "$ref": "#/definitions/Point" } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +-- ======================================================================== +-- Light (sum type with unwrapUnaryRecords) +-- ======================================================================== + +data Light + = LightFreq Double + | LightColor Color + | LightWaveLength { waveLength :: Double } + deriving (Generic) + +instance ToSchema Light where + toNamedSchema = genericToNamedSchema defaultSchemaOptions + { unwrapUnaryRecords = True } + +lightSchemaJSON :: Value +lightSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "LightFreq": { "type": "number" }, + "LightColor": { "$ref": "#/definitions/Color" }, + "LightWaveLength": { "type": "number" } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + diff --git a/test/Data/SwaggerSpec.hs b/test/Data/SwaggerSpec.hs --- a/test/Data/SwaggerSpec.hs +++ b/test/Data/SwaggerSpec.hs @@ -6,40 +6,13 @@ import Data.Aeson import Data.Aeson.QQ -import qualified Data.Foldable as F import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe -import Data.Monoid -import qualified Data.Vector as Vector import Data.Text (Text) import Data.Swagger - +import SpecCommon import Test.Hspec -isSubJSON :: Value -> Value -> Bool -isSubJSON Null _ = True -isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i - where - i = HashMap.intersectionWith isSubJSON x y -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 -x <~> json = do - it "encodes correctly (probably with extra properties)" $ do - toJSON x `shouldSatisfy` (json `isSubJSON`) - it "decodes correctly" $ do - fromJSON json `shouldBe` Success x - -(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec -x <=> json = do - it "encodes correctly" $ do - toJSON x `shouldBe` json - it "decodes correctly" $ do - fromJSON json `shouldBe` Success x - spec :: Spec spec = do describe "License Object" $ licenseExample <=> licenseExampleJSON @@ -68,18 +41,14 @@ -- Info object -- ======================================================================= -infoExample :: SwaggerInfo -infoExample = SwaggerInfo - { _swaggerInfoTitle = "Swagger Sample App" - , _swaggerInfoDescription = Just "This is a sample server Petstore server." - , _swaggerInfoTermsOfService = Just "http://swagger.io/terms/" - , _swaggerInfoContact = Just contactExample - , _swaggerInfoLicense = Just licenseExample - , _swaggerInfoVersion = "1.0.1" } - where - license = SwaggerLicense - { _swaggerLicenseName = "Apache 2.0" - , _swaggerLicenseUrl = Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html") } +infoExample :: Info +infoExample = Info + { _infoTitle = "Swagger Sample App" + , _infoDescription = Just "This is a sample server Petstore server." + , _infoTermsOfService = Just "http://swagger.io/terms/" + , _infoContact = Just contactExample + , _infoLicense = Just licenseExample + , _infoVersion = "1.0.1" } infoExampleJSON :: Value infoExampleJSON = [aesonQQ| @@ -104,11 +73,11 @@ -- Contact object -- ======================================================================= -contactExample :: SwaggerContact -contactExample = SwaggerContact - { _swaggerContactName = Just "API Support" - , _swaggerContactUrl = Just (URL "http://www.swagger.io/support") - , _swaggerContactEmail = Just "support@swagger.io" } +contactExample :: Contact +contactExample = Contact + { _contactName = Just "API Support" + , _contactUrl = Just (URL "http://www.swagger.io/support") + , _contactEmail = Just "support@swagger.io" } contactExampleJSON :: Value contactExampleJSON = [aesonQQ| @@ -123,10 +92,10 @@ -- License object -- ======================================================================= -licenseExample :: SwaggerLicense -licenseExample = SwaggerLicense - { _swaggerLicenseName = "Apache 2.0" - , _swaggerLicenseUrl = Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html") } +licenseExample :: License +licenseExample = License + { _licenseName = "Apache 2.0" + , _licenseUrl = Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html") } licenseExampleJSON :: Value licenseExampleJSON = [aesonQQ| @@ -141,47 +110,47 @@ -- Operation object -- ======================================================================= -operationExample :: SwaggerOperation +operationExample :: Operation operationExample = mempty - { _swaggerOperationTags = ["pet"] - , _swaggerOperationSummary = Just "Updates a pet in the store with form data" - , _swaggerOperationDescription = Just "" - , _swaggerOperationOperationId = Just "updatePetWithForm" - , _swaggerOperationConsumes = Just (SwaggerMimeList ["application/x-www-form-urlencoded"]) - , _swaggerOperationProduces = Just (SwaggerMimeList ["application/json", "application/xml"]) - , _swaggerOperationParameters = params - , _swaggerOperationResponses = responses - , _swaggerOperationSecurity = security + { _operationTags = ["pet"] + , _operationSummary = Just "Updates a pet in the store with form data" + , _operationDescription = Just "" + , _operationOperationId = Just "updatePetWithForm" + , _operationConsumes = Just (MimeList ["application/x-www-form-urlencoded"]) + , _operationProduces = Just (MimeList ["application/json", "application/xml"]) + , _operationParameters = params + , _operationResponses = responses + , _operationSecurity = security } where - security = [SwaggerSecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]] + security = [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]] responses = mempty - { _swaggerResponsesResponses = - [ (200, SwaggerInline mempty { _swaggerResponseDescription = "Pet updated." }) - , (405, SwaggerInline mempty { _swaggerResponseDescription = "Invalid input" }) ] } + { _responsesResponses = + [ (200, Inline mempty { _responseDescription = "Pet updated." }) + , (405, Inline mempty { _responseDescription = "Invalid input" }) ] } - params = map SwaggerInline - [ SwaggerParameter - { _swaggerParameterName = "petId" - , _swaggerParameterDescription = Just "ID of pet that needs to be updated" - , _swaggerParameterRequired = Just True - , _swaggerParameterSchema = SwaggerParameterOther (stringSchema SwaggerParameterPath) } - , SwaggerParameter - { _swaggerParameterName = "name" - , _swaggerParameterDescription = Just "Updated name of the pet" - , _swaggerParameterRequired = Just False - , _swaggerParameterSchema = SwaggerParameterOther (stringSchema SwaggerParameterFormData) } - , SwaggerParameter - { _swaggerParameterName = "status" - , _swaggerParameterDescription = Just "Updated status of the pet" - , _swaggerParameterRequired = Just False - , _swaggerParameterSchema = SwaggerParameterOther (stringSchema SwaggerParameterFormData) } + params = map Inline + [ Parameter + { _parameterName = "petId" + , _parameterDescription = Just "ID of pet that needs to be updated" + , _parameterRequired = Just True + , _parameterSchema = ParameterOther (stringSchema ParameterPath) } + , Parameter + { _parameterName = "name" + , _parameterDescription = Just "Updated name of the pet" + , _parameterRequired = Just False + , _parameterSchema = ParameterOther (stringSchema ParameterFormData) } + , Parameter + { _parameterName = "status" + , _parameterDescription = Just "Updated status of the pet" + , _parameterRequired = Just False + , _parameterSchema = ParameterOther (stringSchema ParameterFormData) } ] stringSchema i = mempty - { _swaggerParameterOtherSchemaIn = i - , _swaggerParameterOtherSchemaType = SwaggerParamString + { _parameterOtherSchemaIn = i + , _parameterOtherSchemaType = ParamString } operationExampleJSON :: Value @@ -246,10 +215,10 @@ -- Schema object -- ======================================================================= -schemaPrimitiveExample :: SwaggerSchema +schemaPrimitiveExample :: Schema schemaPrimitiveExample = mempty - { _swaggerSchemaType = SwaggerSchemaString - , _swaggerSchemaFormat = Just "email" + { _schemaType = SchemaString + , _schemaFormat = Just "email" } schemaPrimitiveExampleJSON :: Value @@ -260,19 +229,19 @@ } |] -schemaSimpleModelExample :: SwaggerSchema +schemaSimpleModelExample :: Schema schemaSimpleModelExample = mempty - { _swaggerSchemaType = SwaggerSchemaObject - , _swaggerSchemaRequired = [ "name" ] - , _swaggerSchemaProperties = - [ ("name", SwaggerInline mempty - { _swaggerSchemaType = SwaggerSchemaString } ) - , ("address", SwaggerRef (SwaggerReference "#/definitions/Address")) - , ("age", SwaggerInline mempty - { _swaggerSchemaType = SwaggerSchemaInteger - , _swaggerSchemaFormat = Just "int32" - , _swaggerSchemaCommon = mempty - { _swaggerSchemaMinimum = Just 0 } } ) ] } + { _schemaType = SchemaObject + , _schemaRequired = [ "name" ] + , _schemaProperties = + [ ("name", Inline mempty + { _schemaType = SchemaString } ) + , ("address", Ref (Reference "#/definitions/Address")) + , ("age", Inline mempty + { _schemaType = SchemaInteger + , _schemaFormat = Just "int32" + , _schemaSchemaCommon = mempty + { _schemaCommonMinimum = Just 0 } } ) ] } schemaSimpleModelExampleJSON :: Value schemaSimpleModelExampleJSON = [aesonQQ| @@ -297,11 +266,11 @@ } |] -schemaModelDictExample :: SwaggerSchema +schemaModelDictExample :: Schema schemaModelDictExample = mempty - { _swaggerSchemaType = SwaggerSchemaObject - , _swaggerSchemaAdditionalProperties = Just mempty - { _swaggerSchemaType = SwaggerSchemaString } } + { _schemaType = SchemaObject + , _schemaAdditionalProperties = Just mempty + { _schemaType = SchemaString } } schemaModelDictExampleJSON :: Value schemaModelDictExampleJSON = [aesonQQ| @@ -313,17 +282,17 @@ } |] -schemaWithExampleExample :: SwaggerSchema +schemaWithExampleExample :: Schema schemaWithExampleExample = mempty - { _swaggerSchemaType = SwaggerSchemaObject - , _swaggerSchemaProperties = - [ ("id", SwaggerInline mempty - { _swaggerSchemaType = SwaggerSchemaInteger - , _swaggerSchemaFormat = Just "int64" }) - , ("name", SwaggerInline mempty - { _swaggerSchemaType = SwaggerSchemaString }) ] - , _swaggerSchemaRequired = [ "name" ] - , _swaggerSchemaExample = Just [aesonQQ| + { _schemaType = SchemaObject + , _schemaProperties = + [ ("id", Inline mempty + { _schemaType = SchemaInteger + , _schemaFormat = Just "int64" }) + , ("name", Inline mempty + { _schemaType = SchemaString }) ] + , _schemaRequired = [ "name" ] + , _schemaExample = Just [aesonQQ| { "name": "Puma", "id": 1 @@ -357,24 +326,24 @@ -- Definitions object -- ======================================================================= -definitionsExample :: HashMap Text SwaggerSchema +definitionsExample :: HashMap Text Schema definitionsExample = [ ("Category", mempty - { _swaggerSchemaType = SwaggerSchemaObject - , _swaggerSchemaProperties = - [ ("id", SwaggerInline mempty - { _swaggerSchemaType = SwaggerSchemaInteger - , _swaggerSchemaFormat = Just "int64" }) - , ("name", SwaggerInline mempty - { _swaggerSchemaType = SwaggerSchemaString }) ] }) + { _schemaType = SchemaObject + , _schemaProperties = + [ ("id", Inline mempty + { _schemaType = SchemaInteger + , _schemaFormat = Just "int64" }) + , ("name", Inline mempty + { _schemaType = SchemaString }) ] }) , ("Tag", mempty - { _swaggerSchemaType = SwaggerSchemaObject - , _swaggerSchemaProperties = - [ ("id", SwaggerInline mempty - { _swaggerSchemaType = SwaggerSchemaInteger - , _swaggerSchemaFormat = Just "int64" }) - , ("name", SwaggerInline mempty - { _swaggerSchemaType = SwaggerSchemaString }) ] }) ] + { _schemaType = SchemaObject + , _schemaProperties = + [ ("id", Inline mempty + { _schemaType = SchemaInteger + , _schemaFormat = Just "int64" }) + , ("name", Inline mempty + { _schemaType = SchemaString }) ] }) ] definitionsExampleJSON :: Value definitionsExampleJSON = [aesonQQ| @@ -410,24 +379,24 @@ -- Parameters Definition object -- ======================================================================= -parametersDefinitionExample :: HashMap Text SwaggerParameter +parametersDefinitionExample :: HashMap Text Parameter parametersDefinitionExample = [ ("skipParam", mempty - { _swaggerParameterName = "skip" - , _swaggerParameterDescription = Just "number of items to skip" - , _swaggerParameterRequired = Just True - , _swaggerParameterSchema = SwaggerParameterOther mempty - { _swaggerParameterOtherSchemaIn = SwaggerParameterQuery - , _swaggerParameterOtherSchemaType = SwaggerParamInteger - , _swaggerParameterOtherSchemaFormat = Just "int32" } }) + { _parameterName = "skip" + , _parameterDescription = Just "number of items to skip" + , _parameterRequired = Just True + , _parameterSchema = ParameterOther mempty + { _parameterOtherSchemaIn = ParameterQuery + , _parameterOtherSchemaType = ParamInteger + , _parameterOtherSchemaFormat = Just "int32" } }) , ("limitParam", mempty - { _swaggerParameterName = "limit" - , _swaggerParameterDescription = Just "max records to return" - , _swaggerParameterRequired = Just True - , _swaggerParameterSchema = SwaggerParameterOther mempty - { _swaggerParameterOtherSchemaIn = SwaggerParameterQuery - , _swaggerParameterOtherSchemaType = SwaggerParamInteger - , _swaggerParameterOtherSchemaFormat = Just "int32" } }) ] + { _parameterName = "limit" + , _parameterDescription = Just "max records to return" + , _parameterRequired = Just True + , _parameterSchema = ParameterOther mempty + { _parameterOtherSchemaIn = ParameterQuery + , _parameterOtherSchemaType = ParamInteger + , _parameterOtherSchemaFormat = Just "int32" } }) ] parametersDefinitionExampleJSON :: Value parametersDefinitionExampleJSON = [aesonQQ| @@ -455,10 +424,10 @@ -- Responses Definition object -- ======================================================================= -responsesDefinitionExample :: HashMap Text SwaggerResponse +responsesDefinitionExample :: HashMap Text Response responsesDefinitionExample = - [ ("NotFound", mempty { _swaggerResponseDescription = "Entity not found." }) - , ("IllegalInput", mempty { _swaggerResponseDescription = "Illegal input for operation." }) ] + [ ("NotFound", mempty { _responseDescription = "Entity not found." }) + , ("IllegalInput", mempty { _responseDescription = "Illegal input for operation." }) ] responsesDefinitionExampleJSON :: Value responsesDefinitionExampleJSON = [aesonQQ| @@ -476,18 +445,18 @@ -- Responses Definition object -- ======================================================================= -securityDefinitionsExample :: HashMap Text SwaggerSecurityScheme +securityDefinitionsExample :: HashMap Text SecurityScheme securityDefinitionsExample = - [ ("api_key", SwaggerSecurityScheme - { _swaggerSecuritySchemeType = SwaggerSecuritySchemeApiKey (SwaggerApiKeyParams "api_key" SwaggerApiKeyHeader) - , _swaggerSecuritySchemeDescription = Nothing }) - , ("petstore_auth", SwaggerSecurityScheme - { _swaggerSecuritySchemeType = SwaggerSecuritySchemeOAuth2 (SwaggerOAuth2Params - { _swaggerOAuth2Flow = SwaggerOAuth2Implicit "http://swagger.io/api/oauth/dialog" - , _swaggerOAuth2Scopes = + [ ("api_key", SecurityScheme + { _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") ] } ) - , _swaggerSecuritySchemeDescription = Nothing }) ] + , _securitySchemeDescription = Nothing }) ] securityDefinitionsExampleJSON :: Value securityDefinitionsExampleJSON = [aesonQQ| @@ -515,47 +484,47 @@ swaggerExample :: Swagger swaggerExample = mempty - { _swaggerBasePath = Just "/" - , _swaggerSchemes = Just [Http] - , _swaggerInfo = mempty - { _swaggerInfoVersion = "1.0" - , _swaggerInfoTitle = "Todo API" - , _swaggerInfoLicense = Just SwaggerLicense - { _swaggerLicenseName = "MIT" - , _swaggerLicenseUrl = Just (URL "http://mit.com") } - , _swaggerInfoDescription = Just "This is a an API that tests servant-swagger support for a Todo API" } - , _swaggerPaths = mempty - { _swaggerPathsMap = + { _basePath = Just "/" + , _schemes = Just [Http] + , _info = mempty + { _infoVersion = "1.0" + , _infoTitle = "Todo API" + , _infoLicense = Just License + { _licenseName = "MIT" + , _licenseUrl = Just (URL "http://mit.com") } + , _infoDescription = Just "This is a an API that tests servant-swagger support for a Todo API" } + , _paths = mempty + { _pathsMap = [ ("/todo/{id}", mempty - { _swaggerPathItemGet = Just mempty - { _swaggerOperationResponses = mempty - { _swaggerResponsesResponses = - [ (200, SwaggerInline mempty - { _swaggerResponseSchema = Just $ SwaggerInline mempty - { _swaggerSchemaExample = Just [aesonQQ| + { _pathItemGet = Just mempty + { _operationResponses = mempty + { _responsesResponses = + [ (200, Inline mempty + { _responseSchema = Just $ Inline mempty + { _schemaExample = Just [aesonQQ| { "created": 100, "description": "get milk" } |] - , _swaggerSchemaType = SwaggerSchemaObject - , _swaggerSchemaDescription = Just "This is some real Todo right here" - , _swaggerSchemaProperties = - [ ("created", SwaggerInline mempty - { _swaggerSchemaType = SwaggerSchemaInteger - , _swaggerSchemaFormat = Just "int32" }) - , ("description", SwaggerInline mempty - { _swaggerSchemaType = SwaggerSchemaString }) ] } - , _swaggerResponseDescription = "OK" }) ] } - , _swaggerOperationProduces = Just (SwaggerMimeList [ "application/json" ]) - , _swaggerOperationParameters = - [ SwaggerInline mempty - { _swaggerParameterRequired = Just True - , _swaggerParameterName = "id" - , _swaggerParameterDescription = Just "TodoId param" - , _swaggerParameterSchema = SwaggerParameterOther mempty - { _swaggerParameterOtherSchemaIn = SwaggerParameterPath - , _swaggerParameterOtherSchemaType = SwaggerParamString } } ] - , _swaggerOperationTags = [ "todo" ] } }) ] } } + , _schemaType = SchemaObject + , _schemaDescription = Just "This is some real Todo right here" + , _schemaProperties = + [ ("created", Inline mempty + { _schemaType = SchemaInteger + , _schemaFormat = Just "int32" }) + , ("description", Inline mempty + { _schemaType = SchemaString }) ] } + , _responseDescription = "OK" }) ] } + , _operationProduces = Just (MimeList [ "application/json" ]) + , _operationParameters = + [ Inline mempty + { _parameterRequired = Just True + , _parameterName = "id" + , _parameterDescription = Just "TodoId param" + , _parameterSchema = ParameterOther mempty + { _parameterOtherSchemaIn = ParameterPath + , _parameterOtherSchemaType = ParamString } } ] + , _operationTags = [ "todo" ] } }) ] } } swaggerExampleJSON :: Value swaggerExampleJSON = [aesonQQ| diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = glob "src/**/*.hs" >>= doctest diff --git a/test/SpecCommon.hs b/test/SpecCommon.hs new file mode 100644 --- /dev/null +++ b/test/SpecCommon.hs @@ -0,0 +1,32 @@ +module SpecCommon where + +import Data.Aeson +import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Vector as Vector + +import Test.Hspec + +isSubJSON :: Value -> Value -> Bool +isSubJSON Null _ = True +isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i + where + i = HashMap.intersectionWith isSubJSON x y +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 +x <~> js = do + it "encodes correctly (probably with extra properties)" $ do + toJSON x `shouldSatisfy` (js `isSubJSON`) + it "decodes correctly" $ do + fromJSON js `shouldBe` Success x + +(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec +x <=> js = do + it "encodes correctly" $ do + toJSON x `shouldBe` js + it "decodes correctly" $ do + fromJSON js `shouldBe` Success x + +