swagger2 0.3 → 0.4
raw patch · 12 files changed
+1628/−718 lines, 12 filesdep +Globdep +doctestdep +scientificdep ~aesondep ~base
Dependencies added: Glob, doctest, scientific, time
Dependency ranges changed: aeson, base
Files
- CHANGELOG.md +12/−0
- src/Data/Swagger.hs +46/−42
- src/Data/Swagger/Internal.hs +411/−413
- src/Data/Swagger/Internal/Utils.hs +7/−7
- src/Data/Swagger/Lens.hs +67/−67
- src/Data/Swagger/Schema.hs +28/−0
- src/Data/Swagger/Schema/Internal.hs +447/−0
- swagger2.cabal +15/−1
- test/Data/Swagger/SchemaSpec.hs +399/−0
- test/Data/SwaggerSpec.hs +157/−188
- test/DocTest.hs +7/−0
- test/SpecCommon.hs +32/−0
CHANGELOG.md view
@@ -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:
src/Data/Swagger.hs view
@@ -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
src/Data/Swagger/Internal.hs view
@@ -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 <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).- | 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 (@\<book/\>\<book/\>@). -- 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")
src/Data/Swagger/Internal/Utils.hs view
@@ -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
src/Data/Swagger/Lens.hs view
@@ -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
+ src/Data/Swagger/Schema.hs view
@@ -0,0 +1,28 @@+-- |+-- Module: Data.Swagger.Schema+-- Copyright: (c) 2015 GetShopTV+-- License: BSD3+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- 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
+ src/Data/Swagger/Schema/Internal.hs view
@@ -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+
swagger2.cabal view
@@ -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
+ test/Data/Swagger/SchemaSpec.hs view
@@ -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+}+|]+
test/Data/SwaggerSpec.hs view
@@ -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|
+ test/DocTest.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "src/**/*.hs" >>= doctest
+ test/SpecCommon.hs view
@@ -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++