diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,47 @@ +1.0 +--- +* Major changes: + * Add `Data` and `Typeable` instances for `Data.Swagger` types; + * Merge `ParamType`/`ItemsType`/`SchemaType` into `SwaggerType` GADT; + * Merge collection format types into `CollectionFormat` GADT; + * Introduce `SwaggerItems` GADT, replacing `Items` and `SchemaItems` in `ParamSchema` (see [#24](https://github.com/GetShopTV/swagger2/pull/24)); + * Move type, format and items fields to `ParamSchema` (former `SchemaComon`); + * Prepend reference path automatically (see [commit 49d1fad](https://github.com/GetShopTV/swagger2/commit/49d1fadd2100644e70c442667180d0d73e107a5f)) + and thus remove `"#/definitions/"` from user code, leaving much clearer `Reference "Name"`; + * Change `Data.Swagger.Schema` (see [#19](https://github.com/GetShopTV/swagger2/pull/19)): + * Change the only method of `ToSchema` to `declareNamedSchema` which should produce a `NamedSchema` + along with a list of schema definitions used to produce it; + * Add `declareSchema`, `declareSchemaRef`; + * Replace `genericTo*` helpers with `genericDeclare*` helpers; + * Add `paramSchemaTo[Named]Schema` helpers to facilitate code reuse for primitive schemas; + * Add helpers for inlining `Schema` references dynamically (see [#23](https://github.com/GetShopTV/swagger2/pull/23)); + * Add `ToParamSchema` class (see [#17](https://github.com/GetShopTV/swagger2/pull/17)) with + * generic default implementation and + * instances for some base types compliant with `http-api-data` instances; + * Add `Data.Swagger.Declare` module with + * `DeclareT` monad transformer; + * `MonadDeclare` type class; + * various helpers; + * Rename parameter-related types: + * `Parameter` -> `Param`; + * `ParameterSchema` -> `ParamAnySchema`; + * `ParameterOtherSchema` -> `ParamOtherSchema`; + * `ParameterLocation` -> `ParamLocation`; + * `SchemaCommon` -> `ParamSchema`; + * `parameter*` fields renamed to `param*` fields; + * `schemaCommon*` fields renamed to `paramSchema*` fields; + * `HasSchemaCommon` -> `HasParamSchema`. + +* Minor changes: + * Replace TH-generated JSON instances with `Generic`-based (see [#25](https://github.com/GetShopTV/swagger2/pull/25)); + * Drop `template-haskell` dependency; + * Omit empty array/object properties from `toJSON` output ([#22](https://github.com/GetShopTV/swagger2/pull/22)); + * Remove `minLength` property from schemas for `time` types; + * Move `SchemaOptions` to `Data.Swagger.SchemaOptions`; + * Remove `useReferences` from `SchemaOptions` (see [#23](https://github.com/GetShopTV/swagger2/pull/23)); + * Place all internal submodules under `Data.Swagger.Internal`; + * Better documentation (see [#26](https://github.com/GetShopTV/swagger2/pull/26)). + 0.4.1 --- * Fixes: @@ -15,7 +59,7 @@ * Fix `HasSchemaCommon` instance for `Schema`; * Change `minimum`, `maximum` and `multipleOf` properties to be any number, not necessarily an integer; - * Fix all warnings + * Fix all warnings. 0.3 --- @@ -27,9 +71,9 @@ 0.2 --- -* Add `Data.Swagger.Lens` -* Support references +* Add `Data.Swagger.Lens`; +* Support references; * Fixes: - * Fix `FromJSON SwaggerHost` instance - * Add missing `Maybe`s for field types - * Decode petstore swagger.json successfully + * Fix `FromJSON SwaggerHost` instance; + * Add missing `Maybe`s for field types; + * Decode petstore `swagger.json` successfully. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,3 +4,32 @@ [![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2) Swagger 2.0 data model. + +The original Swagger 2.0 specification is available at http://swagger.io/specification/. + +## Usage + +This library is inteded to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them. + +Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2). + +Some examples can be found in [`examples/` directory](/examples). + +## Trying out + +All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/). + +Ready-to-use specification can be served as JSON and interactive API documentation +can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui). + +Many Swagger tools, including server and client code generation for many languages, can be found on +[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/). + +## Contributing + +We are happy to receive bug reports, fixes, documentation enhancements, and other improvements. + +Please report bugs via the [github issue tracker](https://github.com/GetShopTV/swagger2/issues). + +*GetShopTV Team* + diff --git a/examples/hackage.hs b/examples/hackage.hs new file mode 100644 --- /dev/null +++ b/examples/hackage.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Lens +import Data.Aeson +import Data.Proxy +import Data.Text (Text) +import GHC.Generics + +import Data.Swagger +import Data.Swagger.Declare +import Data.Swagger.Lens + +type Username = Text + +data UserSummary = UserSummary + { summaryUsername :: Username + , summaryUserid :: Int + } deriving (Generic, ToSchema) + +type Group = Text + +data UserDetailed = UserDetailed + { username :: Username + , userid :: Int + , groups :: [Group] + } deriving (Generic, ToSchema) + +newtype Package = Package { packageName :: Text } + deriving (Generic, ToSchema) + +hackageSwagger :: Swagger +hackageSwagger = spec & definitions .~ defs + where + (defs, spec) = runDeclare declareHackageSwagger mempty + +declareHackageSwagger :: Declare Definitions Swagger +declareHackageSwagger = do + let usernameParamSchema = toParamSchema (Proxy :: Proxy Username) + userSummarySchemaRef <- declareSchemaRef (Proxy :: Proxy UserSummary) + userDetailedSchemaRef <- declareSchemaRef (Proxy :: Proxy UserDetailed) + packagesSchemaRef <- declareSchemaRef (Proxy :: Proxy [Package]) + return $ mempty + & paths.pathsMap .~ + [ ("/users", mempty & pathItemGet ?~ (mempty + & operationProduces ?~ MimeList ["application/json"] + & operationResponses .~ (mempty + & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ userSummarySchemaRef)))) + , ("/user/{username}", mempty & pathItemGet ?~ (mempty + & operationProduces ?~ MimeList ["application/json"] + & operationParameters .~ [ Inline $ mempty + & paramName .~ "username" + & paramRequired ?~ True + & paramSchema .~ ParamOther (mempty + & paramOtherSchemaIn .~ ParamPath + & paramOtherSchemaParamSchema .~ usernameParamSchema) ] + & operationResponses .~ (mempty + & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ userDetailedSchemaRef)))) + , ("/packages", mempty & pathItemGet ?~ (mempty + & operationProduces ?~ MimeList ["application/json"] + & operationResponses .~ (mempty + & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ packagesSchemaRef)))) + ] + +main :: IO () +main = putStrLn . read . show . encode $ hackageSwagger + diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -6,6 +6,21 @@ -- 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 ( + -- * How to use this library + -- $howto + + -- ** @'Monoid'@ instances + -- $monoids + + -- ** Lenses and prisms + -- $lens + + -- ** Schema specification + -- $schema + + -- * Re-exports + module Data.Swagger.Lens, + module Data.Swagger.ParamSchema, module Data.Swagger.Schema, -- * Swagger specification @@ -13,75 +28,201 @@ Host(..), Scheme(..), - -- * Info types + -- ** Info types Info(..), Contact(..), License(..), - -- * Paths + -- ** Paths Paths(..), PathItem(..), - -- * Operations + -- ** Operations Tag(..), Operation(..), - -- * Types and formats - ParameterType(..), - ItemsType(..), - SchemaType(..), + -- ** Types and formats + SwaggerType(..), Format, CollectionFormat(..), - ItemsCollectionFormat(..), - -- * Parameters - Parameter(..), - ParameterSchema(..), - ParameterOtherSchema(..), - ParameterLocation(..), + -- ** Parameters + Param(..), + ParamAnySchema(..), + ParamOtherSchema(..), + ParamLocation(..), ParamName, Items(..), Header(..), Example(..), - -- * Schema + -- ** Schemas + ParamSchema(..), Schema(..), - SchemaItems(..), - SchemaCommon(..), + SwaggerItems(..), Xml(..), - -- * Responses + -- ** Responses Responses(..), Response(..), - -- * Security + -- ** Security SecurityScheme(..), SecuritySchemeType(..), SecurityRequirement(..), - -- ** API key + -- *** API key ApiKeyParams(..), ApiKeyLocation(..), - -- ** OAuth2 + -- *** OAuth2 OAuth2Params(..), OAuth2Flow(..), AuthorizationURL, TokenURL, - -- * External documentation + -- ** External documentation ExternalDocs(..), - -- * References + -- ** References Reference(..), Referenced(..), - -- * Miscellaneous + -- ** Miscellaneous MimeList(..), URL(..), ) where +import Data.Swagger.Lens +import Data.Swagger.ParamSchema import Data.Swagger.Schema import Data.Swagger.Internal + +-- $setup +-- >>> import Control.Lens +-- >>> import Data.Aeson +-- >>> import Data.Monoid +-- >>> import Data.Proxy +-- >>> import GHC.Generics +-- >>> :set -XDeriveGeneric +-- >>> :set -XOverloadedStrings +-- >>> :set -XOverloadedLists +-- >>> :set -fno-warn-missing-methods + +-- $howto +-- +-- This section explains how to use this library to work with Swagger specification. + +-- $monoids +-- +-- Virtually all types representing Swagger specification have @'Monoid'@ instances. +-- The @'Monoid'@ type class provides two methods — @'mempty'@ and @'mappend'@. +-- +-- In this library you can use @'mempty'@ for a default/empty value. For instance: +-- +-- >>> encode (mempty :: Swagger) +-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"}}" +-- +-- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty. +-- That is because these properties are actually required ones. +-- +-- You /should/ always override the default (empty) value for these properties, +-- although it is not strictly necessary: +-- +-- >>> encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" } +-- "{\"version\":\"1.0\",\"title\":\"Todo API\"}" +-- +-- You can merge two values using @'mappend'@ or its infix version @('<>')@: +-- +-- >>> encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" } +-- "{\"version\":\"1.0\",\"title\":\"Todo API\"}" +-- +-- This can be useful for combining specifications of endpoints into a whole API specification: +-- +-- @ +-- \-\- /account subAPI specification +-- accountAPI :: Swagger +-- +-- \-\- /task subAPI specification +-- taskAPI :: Swagger +-- +-- \-\- while API specification is just a combination +-- \-\- of subAPIs' specifications +-- api :: Swagger +-- api = accountAPI <> taskAPI +-- @ + +-- $lens +-- +-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used +-- to modify this structure. In combination with @'Monoid'@ instances, lenses +-- also make it fairly simple to construct/modify any part of the specification: +-- +-- >>> :{ +-- encode $ mempty & pathsMap .~ +-- [ ("/user", mempty & pathItemGet ?~ (mempty +-- & operationProduces ?~ MimeList ["application/json"] +-- & operationResponses .~ (mempty +-- & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ Ref (Reference "#/definitions/User")))))] +-- :} +-- "{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"]}}}" +-- +-- In the snippet above we declare API paths with a single path @/user@ providing method @GET@ +-- which produces @application/json@ output and should respond with code @200@ and body specified +-- by schema @User@ (which should be defined in @definitions@ property of swagger specification). +-- +-- Since @'ParamSchema'@ is basically the /base schema specification/, a special +-- @'HasParamSchema'@ class has been introduced to generalize @'ParamSchema'@ lenses +-- and allow them to be used by any type that has a @'ParamSchema'@: +-- +-- >>> :{ +-- encode $ mempty +-- & schemaTitle ?~ "Email" +-- & schemaType .~ SwaggerString +-- & schemaFormat ?~ "email" +-- :} +-- "{\"format\":\"email\",\"title\":\"Email\",\"type\":\"string\"}" + +-- $schema +-- +-- @'ParamSchema'@ and @'Schema'@ are the two core types for data model specification. +-- +-- @'ParamSchema' t@ specifies all the common properties, available for every data schema. +-- The @t@ parameter imposes some restrictions on @type@ and @items@ properties (see @'SwaggerType'@ and @'SwaggerItems'@). +-- +-- @'Schema'@ is used for request and response bodies and allows specifying objects +-- with properties in addition to what @'ParamSchema'@ provides. +-- +-- In most cases you will have a Haskell data type for which you would like to +-- define a corresponding schema. To facilitate thise use case +-- this library provides two classes for schema encoding. +-- Both these classes provide means to encode /types/ as Swagger /schemas/. +-- +-- @'ToParamSchema'@ is intended to be used for primitive API endpoint parameters, +-- such as query parameters, headers and URL path pieces. +-- Its corresponding value-encoding class is @'ToHttpApiData'@ (from @http-api-data@ package). +-- +-- @'ToSchema'@ is used for request and response bodies and mostly differ from +-- primitive parameters by allowing objects/mappings in addition to primitive types and arrays. +-- Its corresponding value-encoding class is @'ToJSON'@ (from @aeson@ package). +-- +-- While lenses and prisms make it easy to define schemas, it might be that you don't need to: +-- @'ToSchema'@ and @'ToParamSchema'@ classes both have default @'Generic'@-based implementations! +-- +-- @'ToSchema'@ default implementation is also aligned with @'ToJSON'@ default implementation with +-- the only difference being for sum encoding. @'ToJSON'@ defaults sum encoding to @'defaultTaggedObject'@, +-- while @'ToSchema'@ defaults to something which corresponds to @'ObjectWithSingleField'@. This is due to +-- @'defaultTaggedObject'@ behavior being hard to specify in Swagger. +-- +-- Here's an example showing @'ToJSON'@–@'ToSchema'@ correspondance: +-- +-- >>> data Person = Person { name :: String, age :: Integer } deriving Generic +-- >>> instance ToJSON Person +-- >>> instance ToSchema Person +-- >>> encode (Person "David" 28) +-- "{\"age\":28,\"name\":\"David\"}" +-- >>> encode $ toSchema (Proxy :: Proxy Person) +-- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}" +-- diff --git a/src/Data/Swagger/Declare.hs b/src/Data/Swagger/Declare.hs new file mode 100644 --- /dev/null +++ b/src/Data/Swagger/Declare.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Data.Swagger.Declare where + +import Control.Monad +import Control.Monad.Trans +import Data.Functor.Identity +import Data.Monoid + +-- | A declare monad transformer parametrized by: +-- +-- * @d@ — the output to accumulate (declarations); +-- +-- * @m@ — the inner monad. +-- +-- This monad transformer is similar to both state and writer monad transformers. +-- Thus it can be seen as +-- +-- * a restricted append-only version of a state monad transformer or +-- +-- * a writer monad transformer with the extra ability to read all previous output. +newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) } + deriving (Functor) + +instance (Monad m, Monoid d) => Applicative (DeclareT d m) where + pure x = DeclareT (\_ -> pure (mempty, x)) + DeclareT df <*> DeclareT dx = DeclareT $ \d -> do + ~(d', f) <- df d + ~(d'', x) <- dx (d <> d') + return (d' <> d'', f x) + +instance (Monad m, Monoid d) => Monad (DeclareT d m) where + return x = DeclareT (\_ -> pure (mempty, x)) + DeclareT dx >>= f = DeclareT $ \d -> do + ~(d', x) <- dx d + ~(d'', y) <- runDeclareT (f x) (d <> d') + return (d' <> d'', y) + +instance Monoid d => MonadTrans (DeclareT d) where + lift m = DeclareT (\_ -> (,) mempty <$> m) + +-- | +-- Definitions of @declare@ and @look@ must satisfy the following laws: +-- +-- [/monoid homomorphism (mempty)/] +-- @'declare' mempty == return ()@ +-- +-- [/monoid homomorphism (mappend)/] +-- @'declare' x >> 'declare' y == 'declare' (x <> y)@ +-- for every @x@, @y@ +-- +-- [/@declare@-@look@/] +-- @'declare' x >> 'look' == 'fmap' (<> x) 'look' <* 'declare' x@ +-- for every @x@ +-- +-- [/@look@ as left identity/] +-- @'look' >> m == m@ +-- for every @m@ +class Monad m => MonadDeclare d m | m -> d where + -- | @'declare' x@ is an action that produces the output @x@. + declare :: d -> m () + -- | @'look'@ is an action that returns all the output so far. + look :: m d + +instance (Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where + declare d = DeclareT (\_ -> return (d, ())) + look = DeclareT (\d -> return (mempty, d)) + +-- | Retrieve a function of all the output so far. +looks :: MonadDeclare d m => (d -> a) -> m a +looks f = f <$> look + +-- | Evaluate @'DeclareT' d m a@ computation, +-- ignoring new output @d@. +evalDeclareT :: Monad m => DeclareT d m a -> d -> m a +evalDeclareT (DeclareT f) d = snd `liftM` f d + +-- | Execute @'DeclateT' d m a@ computation, +-- ignoring result and only producing new output @d@. +execDeclareT :: Monad m => DeclareT d m a -> d -> m d +execDeclareT (DeclareT f) d = fst `liftM` f d + +-- | Evaluate @'DeclareT' d m a@ computation, +-- starting with empty output history. +undeclareT :: (Monad m, Monoid d) => DeclareT d m a -> m a +undeclareT = flip evalDeclareT mempty + +-- | A declare monad parametrized by @d@ — the output to accumulate (declarations). +-- +-- This monad is similar to both state and writer monads. +-- Thus it can be seen as +-- +-- * a restricted append-only version of a state monad or +-- +-- * a writer monad with the extra ability to read all previous output. +type Declare d = DeclareT d Identity + +-- | Run @'Declare' d a@ computation with output history @d@, +-- producing result @a@ and new output @d@. +runDeclare :: Declare d a -> d -> (d, a) +runDeclare m = runIdentity . runDeclareT m + +-- | Evaluate @'Declare' d a@ computation, ignoring output @d@. +evalDeclare :: Declare d a -> d -> a +evalDeclare m = runIdentity . evalDeclareT m + +-- | Execute @'Declate' d a@ computation, ignoring result and only +-- producing output @d@. +execDeclare :: Declare d a -> d -> d +execDeclare m = runIdentity . execDeclareT m + +-- | Evaluate @'DeclareT' d m a@ computation, +-- starting with empty output history. +undeclare :: Monoid d => Declare d a -> a +undeclare = runIdentity . undeclareT + diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -1,18 +1,22 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} module Data.Swagger.Internal where import Control.Applicative import Control.Monad import Data.Aeson -import Data.Aeson.TH (deriveJSON) +import qualified Data.Aeson.Types as JSON +import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) @@ -64,7 +68,7 @@ -- | An object to hold parameters that can be used across operations. -- This property does not define global parameters for all operations. - , _parameters :: HashMap Text Parameter + , _parameters :: HashMap Text Param -- | An object to hold responses that can be used across operations. -- This property does not define global responses for all operations. @@ -88,7 +92,7 @@ -- | Additional external documentation. , _externalDocs :: Maybe ExternalDocs - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, Data, Typeable) -- | The object provides metadata about the API. -- The metadata can be used by the clients if needed, @@ -113,7 +117,7 @@ -- | Provides the version of the application API -- (not to be confused with the specification version). , _infoVersion :: Text - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, Data, Typeable) -- | Contact information for the exposed API. data Contact = Contact @@ -125,7 +129,7 @@ -- | The email address of the contact person/organization. , _contactEmail :: Maybe Text - } deriving (Eq, Show) + } deriving (Eq, Show, Generic, Data, Typeable) -- | License information for the exposed API. data License = License @@ -134,28 +138,41 @@ -- | A URL to the license used for the API. , _licenseUrl :: Maybe URL - } deriving (Eq, Show) + } deriving (Eq, Show, Generic, Data, Typeable) -- | The host (name or ip) serving the API. It MAY include a port. data Host = Host { _hostName :: HostName -- ^ Host name. , _hostPort :: Maybe PortNumber -- ^ Optional port. - } deriving (Eq, Show) + } deriving (Eq, Show, Generic, Typeable) +hostConstr :: Constr +hostConstr = mkConstr hostDataType "Host" [] Prefix + +hostDataType :: DataType +hostDataType = mkDataType "Data.Swagger.Host" [hostConstr] + +instance Data Host where + gunfold k z c = case constrIndex c of + 1 -> k (k (z (\name mport -> Host name (fromInteger <$> mport)))) + _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Host." + toConstr (Host _ _) = hostConstr + dataTypeOf _ = hostDataType + -- | The transfer protocol of the API. data Scheme = Http | Https | Ws | Wss - deriving (Eq, Show) + deriving (Eq, Show, Generic, Data, Typeable) -- | The available paths and operations for the API. data Paths = Paths { -- | Holds the relative paths to the individual endpoints. -- The path is appended to the @'basePath'@ in order to construct the full URL. _pathsMap :: HashMap FilePath PathItem - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, Data, Typeable) -- | Describes the operations available on a single path. -- A @'PathItem'@ may be empty, due to ACL constraints. @@ -187,8 +204,8 @@ -- 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. - , _pathItemParameters :: [Referenced Parameter] - } deriving (Eq, Show, Generic) + , _pathItemParameters :: [Referenced Param] + } deriving (Eq, Show, Generic, Data, Typeable) -- | Describes a single API operation on a path. data Operation = Operation @@ -228,7 +245,7 @@ -- 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. - , _operationParameters :: [Referenced Parameter] + , _operationParameters :: [Referenced Param] -- | The list of possible responses as they are returned from executing this operation. , _operationResponses :: Responses @@ -248,88 +265,149 @@ -- This definition overrides any declared top-level security. -- To remove a top-level security declaration, @Just []@ can be used. , _operationSecurity :: [SecurityRequirement] - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, Data, Typeable) newtype MimeList = MimeList { getMimeList :: [MediaType] } - deriving (Eq, Show, Monoid) + deriving (Eq, Show, Monoid, Typeable) +mimeListConstr :: Constr +mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix + +mimeListDataType :: DataType +mimeListDataType = mkDataType "Data.Swagger.MimeList" [mimeListConstr] + +instance Data MimeList where + gunfold k z c = case constrIndex c of + 1 -> k (z (\xs -> MimeList (map fromString xs))) + _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MimeList." + toConstr (MimeList _) = mimeListConstr + dataTypeOf _ = mimeListDataType + -- | Describes a single operation parameter. -- A unique parameter is defined by a combination of a name and location. -data Parameter = Parameter +data Param = Param { -- | The name of the parameter. -- Parameter names are case sensitive. - _parameterName :: Text + _paramName :: Text -- | A brief description of the parameter. -- This could contain examples of use. -- GFM syntax can be used for rich text representation. - , _parameterDescription :: Maybe Text + , _paramDescription :: 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@. - , _parameterRequired :: Maybe Bool + , _paramRequired :: Maybe Bool -- | Parameter schema. - , _parameterSchema :: ParameterSchema - } deriving (Eq, Show, Generic) + , _paramSchema :: ParamAnySchema + } deriving (Eq, Show, Generic, Data, Typeable) -data ParameterSchema - = ParameterBody (Referenced Schema) - | ParameterOther ParameterOtherSchema - deriving (Eq, Show) +data ParamAnySchema + = ParamBody (Referenced Schema) + | ParamOther ParamOtherSchema + deriving (Eq, Show, Generic, Data, Typeable) -data ParameterOtherSchema = ParameterOtherSchema +data ParamOtherSchema = ParamOtherSchema { -- | The location of the parameter. - _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 @'ParamFile'@, the @consumes@ MUST be either - -- "multipart/form-data" or " application/x-www-form-urlencoded" - -- and the parameter MUST be in @'ParameterFormData'@. - , _parameterOtherSchemaType :: ParameterType - - -- | The extending format for the previously mentioned type. - , _parameterOtherSchemaFormat :: Maybe Format + _paramOtherSchemaIn :: ParamLocation -- | Sets the ability to pass empty-valued parameters. - -- This is valid only for either @'ParameterQuery'@ or @'ParameterFormData'@ + -- This is valid only for either @'ParamQuery'@ or @'ParamFormData'@ -- and allows you to send a parameter with a name only or an empty value. -- Default value is @False@. - , _parameterOtherSchemaAllowEmptyValue :: Maybe Bool - - -- | __Required if type is @'ParamArray'@__. - -- Describes the type of items in the array. - , _parameterOtherSchemaItems :: Maybe Items + , _paramOtherSchemaAllowEmptyValue :: Maybe Bool -- | Determines the format of the array if @'ParamArray'@ is used. -- Default value is csv. - , _parameterOtherSchemaCollectionFormat :: Maybe CollectionFormat + , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param) - , _parameterOtherSchemaCommon :: SchemaCommon - } deriving (Eq, Show, Generic) + , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema + } deriving (Eq, Show, Generic, Data, Typeable) -data ParameterType - = ParamString - | ParamNumber - | ParamInteger - | ParamBoolean - | ParamArray - | ParamFile - deriving (Eq, Show) +data SwaggerItems t where + SwaggerItemsPrimitive :: Items -> SwaggerItems t + SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema + SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema -data ParameterLocation +deriving instance Eq (SwaggerItems t) +deriving instance Show (SwaggerItems t) +deriving instance Typeable (SwaggerItems t) + +swaggerItemsPrimitiveConstr :: Constr +swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix + +swaggerItemsDataType :: DataType +swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr] + +instance {-# OVERLAPPABLE #-} Typeable t => Data (SwaggerItems t) where + gunfold k z c = case constrIndex c of + 1 -> k (z SwaggerItemsPrimitive) + _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)." + toConstr _ = swaggerItemsPrimitiveConstr + dataTypeOf _ = swaggerItemsDataType + +deriving instance Data (SwaggerItems Schema) + +data SwaggerType t where + SwaggerString :: SwaggerType t + SwaggerNumber :: SwaggerType t + SwaggerInteger :: SwaggerType t + SwaggerBoolean :: SwaggerType t + SwaggerArray :: SwaggerType t + SwaggerFile :: SwaggerType ParamOtherSchema + SwaggerNull :: SwaggerType Schema + SwaggerObject :: SwaggerType Schema + +deriving instance Eq (SwaggerType t) +deriving instance Show (SwaggerType t) +deriving instance Typeable (SwaggerType t) + +swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr +swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix + +swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType +swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs + +swaggerCommonTypes :: [SwaggerType t] +swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray] + +swaggerParamTypes :: [SwaggerType ParamOtherSchema] +swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile] + +swaggerSchemaTypes :: [SwaggerType Schema] +swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject] + +swaggerTypeConstrs :: [Constr] +swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema]) + ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject] + +instance {-# OVERLAPPABLE #-} Typeable t => Data (SwaggerType t) where + gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes + toConstr = swaggerTypeConstr + dataTypeOf = swaggerTypeDataType + +instance {-# OVERLAPPING #-} Data (SwaggerType ParamOtherSchema) where + gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes + toConstr = swaggerTypeConstr + dataTypeOf = swaggerTypeDataType + +instance {-# OVERLAPPING #-} Data (SwaggerType Schema) where + gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes + toConstr = swaggerTypeConstr + dataTypeOf = swaggerTypeDataType + +data ParamLocation = -- | Parameters that are appended to the URL. -- For example, in @/items?id=###@, the query parameter is @id@. - ParameterQuery + ParamQuery -- | Custom headers that are expected as part of the request. - | ParameterHeader + | ParamHeader -- | 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@. - | ParameterPath + | ParamPath -- | Used to describe the payload of an HTTP request when either @application/x-www-form-urlencoded@ -- or @multipart/form-data@ are used as the content type of the request -- (in Swagger's definition, the @consumes@ property of an operation). @@ -337,58 +415,54 @@ -- 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 ). - | ParameterFormData - deriving (Eq, Show) + | ParamFormData + deriving (Eq, Show, Generic, Data, Typeable) type Format = Text -- | Determines the format of the array. -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 @'ParameterQuery'@ or @'ParameterFormData'@. - deriving (Eq, Show) +data CollectionFormat t where + -- Comma separated values: @foo,bar@. + CollectionCSV :: CollectionFormat t + -- Space separated values: @foo bar@. + CollectionSSV :: CollectionFormat t + -- Tab separated values: @foo\\tbar@. + CollectionTSV :: CollectionFormat t + -- Pipe separated values: @foo|bar@. + CollectionPipes :: CollectionFormat t + -- Corresponds to multiple parameter instances + -- instead of multiple values for a single instance @foo=bar&foo=baz@. + -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@. + CollectionMulti :: CollectionFormat Param -data ItemsType - = ItemsString - | ItemsNumber - | ItemsInteger - | ItemsBoolean - | ItemsArray - deriving (Eq, Show) +deriving instance Eq (CollectionFormat t) +deriving instance Show (CollectionFormat t) +deriving instance Typeable (CollectionFormat t) -data SchemaType - = SchemaArray - | SchemaBoolean - | SchemaInteger - | SchemaNumber - | SchemaNull - | SchemaObject - | SchemaString - deriving (Eq, Show) +collectionFormatConstr :: CollectionFormat t -> Constr +collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix --- | Determines the format of the nested array. -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) +collectionFormatDataType :: DataType +collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $ + map collectionFormatConstr collectionCommonFormats +collectionCommonFormats :: [CollectionFormat t] +collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ] + +instance {-# OVERLAPPABLE #-} Data t => Data (CollectionFormat t) where + gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats + toConstr = collectionFormatConstr + dataTypeOf _ = collectionFormatDataType + +deriving instance {-# OVERLAPPING #-} Data (CollectionFormat Param) + type ParamName = Text data Schema = Schema - { _schemaType :: SchemaType - , _schemaFormat :: Maybe Format - , _schemaTitle :: Maybe Text + { _schemaTitle :: Maybe Text , _schemaDescription :: Maybe Text , _schemaRequired :: [ParamName] - , _schemaItems :: Maybe SchemaItems , _schemaAllOf :: Maybe [Schema] , _schemaProperties :: HashMap Text (Referenced Schema) , _schemaAdditionalProperties :: Maybe Schema @@ -402,36 +476,36 @@ , _schemaMaxProperties :: Maybe Integer , _schemaMinProperties :: Maybe Integer - , _schemaSchemaCommon :: SchemaCommon - } deriving (Eq, Show, Generic) - -data SchemaItems - = SchemaItemsObject (Referenced Schema) - | SchemaItemsArray [Referenced Schema] - deriving (Eq, Show) + , _schemaParamSchema :: ParamSchema Schema + } deriving (Eq, Show, Generic, Data, Typeable) -data SchemaCommon = SchemaCommon +data ParamSchema t = ParamSchema { -- | Declares the value of the parameter that the server will use if none is provided, -- for example a @"count"@ to control the number of results per page might default to @100@ -- if not supplied by the client in the request. -- (Note: "default" has no meaning for required parameters.) -- Unlike JSON Schema this value MUST conform to the defined type for this parameter. - _schemaCommonDefault :: Maybe Value + _paramSchemaDefault :: Maybe Value - , _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) + , _paramSchemaType :: SwaggerType t + , _paramSchemaFormat :: Maybe Format + , _paramSchemaItems :: Maybe (SwaggerItems t) + , _paramSchemaMaximum :: Maybe Scientific + , _paramSchemaExclusiveMaximum :: Maybe Bool + , _paramSchemaMinimum :: Maybe Scientific + , _paramSchemaExclusiveMinimum :: Maybe Bool + , _paramSchemaMaxLength :: Maybe Integer + , _paramSchemaMinLength :: Maybe Integer + , _paramSchemaPattern :: Maybe Text + , _paramSchemaMaxItems :: Maybe Integer + , _paramSchemaMinItems :: Maybe Integer + , _paramSchemaUniqueItems :: Maybe Bool + , _paramSchemaEnum :: Maybe [Value] + , _paramSchemaMultipleOf :: Maybe Scientific + } deriving (Eq, Show, Generic, Typeable) +deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t) + data Xml = Xml { -- | Replaces the name of the element/attribute used for the described schema property. -- When defined within the @'Items'@ (items), it will affect the name of the individual XML elements within the list. @@ -458,25 +532,15 @@ -- Default value is @False@. -- The definition takes effect only when defined alongside type being array (outside the items). , _xmlWrapped :: Maybe Bool - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, Data, Typeable) data Items = Items - { -- | The internal type of the array. - _itemsType :: ItemsType - - -- | The extending format for the previously mentioned type. - , _itemsFormat :: Maybe Format - - -- | __Required if type is @'ItemsArray'@.__ - -- Describes the type of items in the array. - , _itemsItems :: Maybe Items - - -- | Determines the format of the array if type array is used. + { -- | Determines the format of the array if type array is used. -- Default value is @'ItemsCollectionCSV'@. - , _itemsCollectionFormat :: Maybe ItemsCollectionFormat + _itemsCollectionFormat :: Maybe (CollectionFormat Items) - , _itemsCommon :: SchemaCommon - } deriving (Eq, Show, Generic) + , _itemsParamSchema :: ParamSchema Items + } deriving (Eq, Show, Generic, Data, Typeable) -- | A container for the expected responses of an operation. -- The container maps a HTTP response code to the expected response. @@ -491,7 +555,7 @@ -- | Any HTTP status code can be used as the property name (one property per HTTP status code). -- Describes the expected response for those HTTP status codes. , _responsesResponses :: HashMap HttpStatusCode (Referenced Response) - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, Data, Typeable) type HttpStatusCode = Int @@ -513,7 +577,7 @@ -- | An example of the response message. , _responseExamples :: Maybe Example - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, Data, Typeable) type HeaderName = Text @@ -521,31 +585,34 @@ { -- | A short description of the header. _headerDescription :: Maybe Text - -- | The type of the object. - , _headerType :: ItemsType - - -- | The extending format for the previously mentioned type. See Data Type Formats for further details. - , _headerFormat :: Maybe Format - - -- | __Required if type is @'ItemsArray'@__. - -- Describes the type of items in the array. - , _headerItems :: Maybe Items - -- | Determines the format of the array if type array is used. -- Default value is @'ItemsCollectionCSV'@. - , _headerCollectionFormat :: Maybe ItemsCollectionFormat + , _headerCollectionFormat :: Maybe (CollectionFormat Items) - , _headerCommon :: SchemaCommon - } deriving (Eq, Show, Generic) + , _headerParamSchema :: ParamSchema Header + } deriving (Eq, Show, Generic, Data, Typeable) data Example = Example { getExample :: Map MediaType Value } - deriving (Eq, Show) + deriving (Eq, Show, Generic, Typeable) +exampleConstr :: Constr +exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix + +exampleDataType :: DataType +exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr] + +instance Data Example where + gunfold k z c = case constrIndex c of + 1 -> k (z (\m -> Example (Map.mapKeys fromString m))) + _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Example." + toConstr (Example _) = exampleConstr + dataTypeOf _ = exampleDataType + -- | The location of the API key. data ApiKeyLocation = ApiKeyQuery | ApiKeyHeader - deriving (Eq, Show) + deriving (Eq, Show, Generic, Data, Typeable) data ApiKeyParams = ApiKeyParams { -- | The name of the header or query parameter to be used. @@ -553,7 +620,7 @@ -- | The location of the API key. , _apiKeyIn :: ApiKeyLocation - } deriving (Eq, Show) + } deriving (Eq, Show, Generic, Data, Typeable) -- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL. type AuthorizationURL = Text @@ -566,7 +633,7 @@ | OAuth2Password TokenURL | OAuth2Application TokenURL | OAuth2AccessCode AuthorizationURL TokenURL - deriving (Eq, Show) + deriving (Eq, Show, Generic, Data, Typeable) data OAuth2Params = OAuth2Params { -- | The flow used by the OAuth2 security scheme. @@ -574,13 +641,13 @@ -- | The available scopes for the OAuth2 security scheme. , _oauth2Scopes :: HashMap Text Text - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, Data, Typeable) data SecuritySchemeType = SecuritySchemeBasic | SecuritySchemeApiKey ApiKeyParams | SecuritySchemeOAuth2 OAuth2Params - deriving (Eq, Show) + deriving (Eq, Show, Generic, Data, Typeable) data SecurityScheme = SecurityScheme { -- | The type of the security scheme. @@ -588,14 +655,14 @@ -- | A short description for security scheme. , _securitySchemeDescription :: Maybe Text - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, Data, Typeable) -- | Lists the required security schemes to execute this operation. -- The object can have multiple security schemes declared in it which are all required -- (that is, there is a logical AND between the schemes). newtype SecurityRequirement = SecurityRequirement { getSecurityRequirement :: HashMap Text [Text] - } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON) + } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable) -- | 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. @@ -609,7 +676,7 @@ -- | Additional external documentation for this tag. , _tagExternalDocs :: Maybe ExternalDocs - } deriving (Eq, Show) + } deriving (Eq, Show, Generic, Data, Typeable) -- | Allows referencing an external resource for extended documentation. data ExternalDocs = ExternalDocs @@ -619,19 +686,19 @@ -- | The URL for the target documentation. , _externalDocsUrl :: URL - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, Data, Typeable) -- | 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 Reference = Reference { getReference :: Text } - deriving (Eq, Show) + deriving (Eq, Show, Data, Typeable) data Referenced a = Ref Reference | Inline a - deriving (Eq, Show) + deriving (Eq, Show, Data, Typeable) -newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON) +newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON, Data, Typeable) -- ======================================================================= -- Monoid instances @@ -657,15 +724,15 @@ mempty = genericMempty mappend = genericMappend -instance Monoid SchemaCommon where +instance Monoid (ParamSchema t) where mempty = genericMempty mappend = genericMappend -instance Monoid Parameter where +instance Monoid Param where mempty = genericMempty mappend = genericMappend -instance Monoid ParameterOtherSchema where +instance Monoid ParamOtherSchema where mempty = genericMempty mappend = genericMappend @@ -693,9 +760,9 @@ instance SwaggerMonoid Paths instance SwaggerMonoid PathItem instance SwaggerMonoid Schema -instance SwaggerMonoid SchemaCommon -instance SwaggerMonoid Parameter -instance SwaggerMonoid ParameterOtherSchema +instance SwaggerMonoid (ParamSchema t) +instance SwaggerMonoid Param +instance SwaggerMonoid ParamOtherSchema instance SwaggerMonoid Responses instance SwaggerMonoid Response instance SwaggerMonoid ExternalDocs @@ -704,16 +771,12 @@ instance SwaggerMonoid MimeList deriving instance SwaggerMonoid URL -instance SwaggerMonoid SchemaType where - swaggerMempty = SchemaNull - swaggerMappend _ y = y - -instance SwaggerMonoid ParameterType where - swaggerMempty = ParamString +instance SwaggerMonoid (SwaggerType t) where + swaggerMempty = SwaggerString swaggerMappend _ y = y -instance SwaggerMonoid ParameterLocation where - swaggerMempty = ParameterQuery +instance SwaggerMonoid ParamLocation where + swaggerMempty = ParamQuery swaggerMappend _ y = y instance SwaggerMonoid (HashMap Text Schema) where @@ -729,7 +792,7 @@ swaggerMappend (Inline x) (Inline y) = Inline (x <> y) swaggerMappend _ y = y -instance SwaggerMonoid (HashMap Text Parameter) where +instance SwaggerMonoid (HashMap Text Param) where swaggerMempty = HashMap.empty swaggerMappend = HashMap.unionWith mappend @@ -753,38 +816,78 @@ swaggerMempty = HashMap.empty swaggerMappend = flip HashMap.union -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) +instance SwaggerMonoid ParamAnySchema where + swaggerMempty = ParamOther swaggerMempty + swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y) + swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y) swaggerMappend _ y = y -- ======================================================================= --- TH derived ToJSON and FromJSON instances +-- Simple Generic-based ToJSON instances -- ======================================================================= -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 +instance ToJSON ParamLocation where + toJSON = genericToJSON (jsonPrefix "Param") -deriveToJSON' ''Operation -deriveToJSON' ''Response -deriveToJSON' ''PathItem -deriveToJSON' ''Xml +instance ToJSON Info where + toJSON = genericToJSON (jsonPrefix "Info") +instance ToJSON Contact where + toJSON = genericToJSON (jsonPrefix "Contact") + +instance ToJSON License where + toJSON = genericToJSON (jsonPrefix "License") + +instance ToJSON ApiKeyLocation where + toJSON = genericToJSON (jsonPrefix "ApiKey") + +instance ToJSON ApiKeyParams where + toJSON = genericToJSON (jsonPrefix "apiKey") + +instance ToJSON Scheme where + toJSON = genericToJSON (jsonPrefix "") + +instance ToJSON Tag where + toJSON = genericToJSON (jsonPrefix "Tag") + +instance ToJSON ExternalDocs where + toJSON = genericToJSON (jsonPrefix "ExternalDocs") + +instance ToJSON Xml where + toJSON = genericToJSON (jsonPrefix "Xml") + -- ======================================================================= +-- Simple Generic-based FromJSON instances +-- ======================================================================= + +instance FromJSON ParamLocation where + parseJSON = genericParseJSON (jsonPrefix "Param") + +instance FromJSON Info where + parseJSON = genericParseJSON (jsonPrefix "Info") + +instance FromJSON Contact where + parseJSON = genericParseJSON (jsonPrefix "Contact") + +instance FromJSON License where + parseJSON = genericParseJSON (jsonPrefix "License") + +instance FromJSON ApiKeyLocation where + parseJSON = genericParseJSON (jsonPrefix "ApiKey") + +instance FromJSON ApiKeyParams where + parseJSON = genericParseJSON (jsonPrefix "apiKey") + +instance FromJSON Scheme where + parseJSON = genericParseJSON (jsonPrefix "") + +instance FromJSON Tag where + parseJSON = genericParseJSON (jsonPrefix "Tag") + +instance FromJSON ExternalDocs where + parseJSON = genericParseJSON (jsonPrefix "ExternalDocs") + +-- ======================================================================= -- Manual ToJSON instances -- ======================================================================= @@ -804,7 +907,7 @@ , "tokenUrl" .= tokenUrl ] instance ToJSON OAuth2Params where - toJSON = genericToJSONWithSub "flow" (jsonPrefix "oauth2") + toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2") instance ToJSON SecuritySchemeType where toJSON SecuritySchemeBasic @@ -817,7 +920,7 @@ <+> object [ "type" .= ("oauth2" :: Text) ] instance ToJSON Swagger where - toJSON = addVersion . genericToJSON (jsonPrefix "") + toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "") where addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o) addVersion _ = error "impossible" @@ -826,14 +929,19 @@ toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme") instance ToJSON Schema where - toJSON = genericToJSONWithSub "schemaCommon" (jsonPrefix "schema") + toJSON = omitEmpties . genericToJSONWithSub "paramSchema" (jsonPrefix "schema") instance ToJSON Header where - toJSON = genericToJSONWithSub "common" (jsonPrefix "header") + toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header") instance ToJSON Items where - toJSON = genericToJSONWithSub "common" (jsonPrefix "items") + toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "items") +instance ToJSON (SwaggerItems t) where + toJSON (SwaggerItemsPrimitive x) = toJSON x + toJSON (SwaggerItemsObject x) = toJSON x + toJSON (SwaggerItemsArray x) = toJSON x + instance ToJSON Host where toJSON (Host host mport) = toJSON $ case mport of @@ -846,33 +954,63 @@ instance ToJSON MimeList where toJSON (MimeList xs) = toJSON (map show xs) -instance ToJSON Parameter where - toJSON = genericToJSONWithSub "schema" (jsonPrefix "parameter") - -instance ToJSON ParameterSchema where - toJSON (ParameterBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ] - toJSON (ParameterOther s) = toJSON s +instance ToJSON Param where + toJSON = genericToJSONWithSub "schema" (jsonPrefix "param") -instance ToJSON ParameterOtherSchema where - toJSON = genericToJSONWithSub "common" (jsonPrefix "parameterOtherSchema") +instance ToJSON ParamAnySchema where + toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ] + toJSON (ParamOther s) = toJSON s -instance ToJSON SchemaItems where - toJSON (SchemaItemsObject x) = toJSON x - toJSON (SchemaItemsArray xs) = toJSON xs +instance ToJSON ParamOtherSchema where + toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema") instance ToJSON Responses where - toJSON (Responses def rs) = toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ] + toJSON (Responses def rs) = omitEmpties $ + toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ] +instance ToJSON Response where + toJSON = omitEmpties . genericToJSON (jsonPrefix "response") + +instance ToJSON Operation where + toJSON = omitEmpties . genericToJSON (jsonPrefix "operation") + +instance ToJSON PathItem where + toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem") + instance ToJSON Example where toJSON = toJSON . Map.mapKeys show . getExample instance ToJSON Reference where toJSON (Reference ref) = object [ "$ref" .= ref ] -instance ToJSON a => ToJSON (Referenced a) where - toJSON (Ref ref) = toJSON ref - toJSON (Inline x) = toJSON x +referencedToJSON :: ToJSON a => Text -> Referenced a -> Value +referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ] +referencedToJSON _ (Inline x) = toJSON x +instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/definitions/" +instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/parameters/" +instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/responses/" + +instance ToJSON (SwaggerType t) where + toJSON SwaggerArray = "array" + toJSON SwaggerString = "string" + toJSON SwaggerInteger = "integer" + toJSON SwaggerNumber = "number" + toJSON SwaggerBoolean = "boolean" + toJSON SwaggerFile = "file" + toJSON SwaggerNull = "null" + toJSON SwaggerObject = "object" + +instance ToJSON (CollectionFormat t) where + toJSON CollectionCSV = "csv" + toJSON CollectionSSV = "ssv" + toJSON CollectionTSV = "tsv" + toJSON CollectionPipes = "pipes" + toJSON CollectionMulti = "multi" + +instance ToJSON (ParamSchema t) where + toJSON = genericToJSON (jsonPrefix "paramSchema") + -- ======================================================================= -- Manual FromJSON instances -- ======================================================================= @@ -913,7 +1051,7 @@ , "security" .= ([] :: [SecurityRequirement]) , "tags" .= ([] :: [Tag]) , "definitions" .= (mempty :: HashMap Text Schema) - , "parameters" .= (mempty :: HashMap Text Parameter) + , "parameters" .= (mempty :: HashMap Text Param) , "responses" .= (mempty :: HashMap Text Response) , "securityDefinitions" .= (mempty :: HashMap Text SecurityScheme) ] ) js @@ -923,16 +1061,24 @@ parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme") instance FromJSON Schema where - parseJSON = genericParseJSONWithSub "schemaCommon" (jsonPrefix "schema") + parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema") `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema) , "required" .= ([] :: [ParamName]) ] instance FromJSON Header where - parseJSON = genericParseJSONWithSub "common" (jsonPrefix "header") + parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header") instance FromJSON Items where - parseJSON = genericParseJSONWithSub "common" (jsonPrefix "items") + parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "items") +instance {-# OVERLAPPABLE #-} FromJSON (SwaggerItems t) where + parseJSON js = SwaggerItemsPrimitive <$> parseJSON js + +instance {-# OVERLAPPING #-} FromJSON (SwaggerItems Schema) where + parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js + parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js + parseJSON _ = empty + instance FromJSON Host where parseJSON (String s) = case fromInteger <$> readMaybe portStr of @@ -949,26 +1095,21 @@ instance FromJSON MimeList where parseJSON js = (MimeList . map fromString) <$> parseJSON js -instance FromJSON Parameter where - parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "parameter") +instance FromJSON Param where + parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param") -instance FromJSON ParameterSchema where +instance FromJSON ParamAnySchema where parseJSON js@(Object o) = do (i :: Text) <- o .: "in" case i of "body" -> do schema <- o .: "schema" - ParameterBody <$> parseJSON schema - _ -> ParameterOther <$> parseJSON js + ParamBody <$> parseJSON schema + _ -> ParamOther <$> parseJSON js parseJSON _ = empty -instance FromJSON ParameterOtherSchema where - parseJSON = genericParseJSONWithSub "common" (jsonPrefix "parameterOtherSchema") - -instance FromJSON SchemaItems where - parseJSON js@(Object _) = SchemaItemsObject <$> parseJSON js - parseJSON js@(Array _) = SchemaItemsArray <$> parseJSON js - parseJSON _ = empty +instance FromJSON ParamOtherSchema where + parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema") instance FromJSON Responses where parseJSON (Object o) = Responses @@ -991,17 +1132,50 @@ instance FromJSON PathItem where parseJSON = genericParseJSON (jsonPrefix "pathItem") - `withDefaults` [ "parameters" .= ([] :: [Parameter]) ] + `withDefaults` [ "parameters" .= ([] :: [Param]) ] instance FromJSON Reference where parseJSON (Object o) = Reference <$> o .: "$ref" parseJSON _ = empty -instance FromJSON a => FromJSON (Referenced a) where - parseJSON js - = Ref <$> parseJSON js - <|> Inline <$> parseJSON js +referencedParseJSON :: FromJSON a => Text -> Value -> JSON.Parser (Referenced a) +referencedParseJSON prefix js@(Object o) = do + ms <- o .:? "$ref" + case ms of + Nothing -> Inline <$> parseJSON js + Just s -> Ref <$> parseRef s + where + parseRef s = do + case Text.stripPrefix prefix s of + Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s + Just suffix -> pure (Reference suffix) +instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/definitions/" +instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/parameters/" +instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/responses/" + instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") +instance FromJSON (SwaggerType Schema) where + parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject] + +instance FromJSON (SwaggerType ParamOtherSchema) where + parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile] + +instance {-# OVERLAPPABLE #-} FromJSON (SwaggerType t) where + parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray] + +instance FromJSON (CollectionFormat Param) where + parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti] + +instance FromJSON (CollectionFormat Items) where + parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] + +-- NOTE: The constraints @FromJSON (SwaggerType t)@ and +-- @FromJSON (SwaggerItems t)@ are necessary here! +-- Without the constraint the general instance will be used +-- that only accepts common types (i.e. NOT object, null or file) +-- and primitive array items. +instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where + parseJSON = genericParseJSON (jsonPrefix "ParamSchema") diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Data.Swagger.Internal.ParamSchema where + +import Control.Lens +import Data.Aeson +import Data.Proxy +import GHC.Generics + +import Data.Int +import Data.Monoid +import Data.Scientific +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Time +import Data.Word + +import Data.Swagger.Internal +import Data.Swagger.Lens +import Data.Swagger.SchemaOptions + +-- | Convert a type into a plain @'ParamSchema'@. +-- +-- An example type and instance: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals +-- +-- import Control.Lens +-- +-- data Direction = Up | Down +-- +-- instance ToParamSchema Direction where +-- toParamSchema = mempty +-- & schemaType .~ SwaggerString +-- & schemaEnum .~ [ \"Up\", \"Down\" ] +-- @ +-- +-- Instead of manually writing your @'ToParamSchema'@ instance you can +-- use a default generic implementation of @'toParamSchema'@. +-- +-- To do that, simply add @deriving 'Generic'@ clause to your datatype +-- and declare a @'ToParamSchema'@ instance for your datatype without +-- giving definition for @'toParamSchema'@. +-- +-- For instance, the previous example can be simplified into this: +-- +-- @ +-- {-\# LANGUAGE DeriveGeneric \#-} +-- +-- import GHC.Generics (Generic) +-- +-- data Direction = Up | Down deriving Generic +-- +-- instance ToParamSchema Direction +-- @ +class ToParamSchema a where + -- | Convert a type into a plain parameter schema. + -- + -- >>> encode $ toParamSchema (Proxy :: Proxy Integer) + -- "{\"type\":\"integer\"}" + toParamSchema :: proxy a -> ParamSchema t + default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t + toParamSchema = genericToParamSchema defaultSchemaOptions + +instance {-# OVERLAPPING #-} ToParamSchema String where + toParamSchema _ = mempty & schemaType .~ SwaggerString + +instance ToParamSchema Bool where + toParamSchema _ = mempty & schemaType .~ SwaggerBoolean + +instance ToParamSchema Integer where + toParamSchema _ = mempty & schemaType .~ SwaggerInteger + +instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Int16 where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Int32 where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Int64 where toParamSchema = toParamSchemaBoundedIntegral + +instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral +instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral + +-- | Default plain schema for @'Bounded'@, @'Integral'@ types. +-- +-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8) +-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}" +toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t +toParamSchemaBoundedIntegral _ = mempty + & schemaType .~ SwaggerInteger + & schemaMinimum ?~ fromInteger (toInteger (minBound :: a)) + & schemaMaximum ?~ fromInteger (toInteger (maxBound :: a)) + +instance ToParamSchema Char where + toParamSchema _ = mempty + & schemaType .~ SwaggerString + & schemaMaxLength ?~ 1 + & schemaMinLength ?~ 1 + +instance ToParamSchema Scientific where + toParamSchema _ = mempty & schemaType .~ SwaggerNumber + +instance ToParamSchema Double where + toParamSchema _ = mempty & schemaType .~ SwaggerNumber + +instance ToParamSchema Float where + toParamSchema _ = mempty & schemaType .~ SwaggerNumber + +timeParamSchema :: String -> ParamSchema t +timeParamSchema format = mempty + & schemaType .~ SwaggerString + & schemaFormat ?~ T.pack format + +-- | +-- >>> toParamSchema (Proxy :: Proxy Day) ^. schemaFormat +-- Just "yyyy-mm-dd" +instance ToParamSchema Day where + toParamSchema _ = timeParamSchema "yyyy-mm-dd" + +-- | +-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. schemaFormat +-- Just "yyyy-mm-ddThh:MM:ss" +instance ToParamSchema LocalTime where + toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss" + +-- | +-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat +-- Just "yyyy-mm-ddThh:MM:ss+hhMM" +instance ToParamSchema ZonedTime where + toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM" + +-- | +-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. schemaFormat +-- Just "yyyy-mm-ddThh:MM:ssZ" +instance ToParamSchema UTCTime where + toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ" + +instance ToParamSchema NominalDiffTime where + toParamSchema _ = toParamSchema (Proxy :: Proxy Integer) + +instance ToParamSchema T.Text where + toParamSchema _ = toParamSchema (Proxy :: Proxy String) + +instance ToParamSchema TL.Text where + toParamSchema _ = toParamSchema (Proxy :: Proxy String) + +instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool) +instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool) +instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a) +instance ToParamSchema a => ToParamSchema (Product a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a) +instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a) +instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a) +instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a) + +-- | +-- >>> encode $ toParamSchema (Proxy :: Proxy ()) +-- "{\"type\":\"string\",\"enum\":[\"_\"]}" +instance ToParamSchema () where + toParamSchema _ = mempty + & schemaType .~ SwaggerString + & schemaEnum ?~ ["_"] + +-- | A configurable generic @'ParamSchema'@ creator. +-- +-- >>> :set -XDeriveGeneric +-- >>> data Color = Red | Blue deriving Generic +-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color) +-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}" +genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t +genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty + +class GToParamSchema (f :: * -> *) where + gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t + +instance GToParamSchema f => GToParamSchema (D1 d f) where + gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f) + +instance GToParamSchema f => GToParamSchema (C1 c (S1 s f)) where + gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f) + +instance ToParamSchema c => GToParamSchema (K1 i c) where + gtoParamSchema _ _ _ = toParamSchema (Proxy :: Proxy c) + +instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) where + gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g)) + +class GEnumParamSchema (f :: * -> *) where + genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t + +instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where + genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g) + +instance Constructor c => GEnumParamSchema (C1 c U1) where + genumParamSchema opts _ s = s + & schemaType .~ SwaggerString + & schemaEnum %~ addEnumValue tag + where + tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) + + addEnumValue x Nothing = Just [x] + addEnumValue x (Just xs) = Just (x:xs) + +data Proxy3 a b c = Proxy3 + diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Swagger/Internal/Schema.hs @@ -0,0 +1,565 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Data.Swagger.Internal.Schema where + +import Control.Lens +import Data.Data.Lens (template) + +import Control.Monad +import Control.Monad.Writer +import Data.Aeson +import Data.Char +import Data.Data (Data) +import Data.Foldable (traverse_) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import "unordered-containers" 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.Declare +import Data.Swagger.Internal +import Data.Swagger.Internal.ParamSchema (ToParamSchema(..)) +import Data.Swagger.Lens +import Data.Swagger.SchemaOptions + +-- | A @'Schema'@ with an optional name. +-- This name can be used in references. +type NamedSchema = (Maybe T.Text, Schema) + +-- | Schema definitions, a mapping from schema name to @'Schema'@. +type Definitions = HashMap T.Text Schema + +unnamed :: Schema -> NamedSchema +unnamed schema = (Nothing, schema) + +named :: T.Text -> Schema -> NamedSchema +named name schema = (Just name, schema) + +plain :: Schema -> Declare Definitions NamedSchema +plain = pure . unnamed + +unname :: NamedSchema -> NamedSchema +unname (_, schema) = (Nothing, schema) + +rename :: Maybe T.Text -> NamedSchema -> NamedSchema +rename name (_, schema) = (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' and 'HashMap' as lists +-- +-- import Control.Lens +-- +-- data Coord = Coord { x :: Double, y :: Double } +-- +-- instance ToSchema Coord where +-- declareNamedSchema = pure (Just \"Coord\", schema) +-- where +-- schema = mempty +-- & schemaType .~ SwaggerObject +-- & 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 @'declareNamedSchema'@. +-- +-- To do that, simply add @deriving 'Generic'@ clause to your datatype +-- and declare a @'ToSchema'@ instance for your datatype without +-- giving definition for @'declareNamedSchema'@. +-- +-- 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 + -- together with all used definitions. + -- Note that the schema itself is included in definitions + -- only if it is recursive (and thus needs its definition in scope). + declareNamedSchema :: proxy a -> Declare Definitions NamedSchema + default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare Definitions NamedSchema + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + +-- | Convert a type into a schema and declare all used schema definitions. +declareSchema :: ToSchema a => proxy a -> Declare Definitions Schema +declareSchema = fmap snd . declareNamedSchema + +-- | Convert a type into an optionally named schema. +-- +-- >>> encode <$> toNamedSchema (Proxy :: Proxy String) +-- (Nothing,"{\"type\":\"string\"}") +-- +-- >>> encode <$> toNamedSchema (Proxy :: Proxy Day) +-- (Just "Day","{\"format\":\"yyyy-mm-dd\",\"type\":\"string\"}") +toNamedSchema :: ToSchema a => proxy a -> NamedSchema +toNamedSchema = undeclare . declareNamedSchema + +-- | Get type's schema name according to its @'ToSchema'@ instance. +-- +-- >>> schemaName (Proxy :: Proxy Int) +-- Nothing +-- +-- >>> schemaName (Proxy :: Proxy UTCTime) +-- Just "UTCTime" +schemaName :: ToSchema a => proxy a -> Maybe T.Text +schemaName = fst . toNamedSchema + +-- | Convert a type into a schema. +-- +-- >>> encode $ toSchema (Proxy :: Proxy Int8) +-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}" +-- +-- >>> encode $ toSchema (Proxy :: Proxy [Day]) +-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}" +toSchema :: ToSchema a => proxy a -> Schema +toSchema = snd . toNamedSchema + +-- | Convert a type into a referenced schema if possible. +-- Only named schemas can be referenced, nameless schemas are inlined. +-- +-- >>> encode $ toSchemaRef (Proxy :: Proxy Integer) +-- "{\"type\":\"integer\"}" +-- +-- >>> encode $ toSchemaRef (Proxy :: Proxy Day) +-- "{\"$ref\":\"#/definitions/Day\"}" +toSchemaRef :: ToSchema a => proxy a -> Referenced Schema +toSchemaRef = undeclare . declareSchemaRef + +-- | Convert a type into a referenced schema if possible +-- and declare all used schema definitions. +-- Only named schemas can be referenced, nameless schemas are inlined. +-- +-- Schema definitions are typically declared for every referenced schema. +-- If @'declareSchemaRef'@ returns a reference, a corresponding schema +-- will be declared (regardless of whether it is recusive or not). +declareSchemaRef :: ToSchema a => proxy a -> Declare Definitions (Referenced Schema) +declareSchemaRef proxy = do + case toNamedSchema proxy of + (Just name, schema) -> do + -- This check is very important as it allows generically + -- derive used definitions for recursive schemas. + -- Lazy Declare monad allows toNamedSchema to ignore + -- any declarations (which would otherwise loop) and + -- retrieve the schema and its name to check if we + -- have already declared it. + -- If we have, we don't need to declare anything for + -- this schema this time and thus simply return the reference. + known <- looks (HashMap.member name) + when (not known) $ do + declare [(name, schema)] + void $ declareNamedSchema proxy + return $ Ref (Reference name) + _ -> Inline <$> declareSchema proxy + +-- | Inline any referenced schema if its name satisfies given predicate. +-- +-- /NOTE:/ if a referenced schema is not found in definitions the predicate is ignored +-- and schema stays referenced. +-- +-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas +-- when inlining recursive schemas. +inlineSchemasWhen :: Data s => (T.Text -> Bool) -> Definitions -> s -> s +inlineSchemasWhen p defs = template %~ deref + where + deref r@(Ref (Reference name)) + | p name = + case HashMap.lookup name defs of + Just schema -> Inline (inlineSchemasWhen p defs schema) + Nothing -> r + | otherwise = r + deref (Inline schema) = Inline (inlineSchemasWhen p defs schema) + +-- | Inline any referenced schema if its name is in the given list. +-- +-- /NOTE:/ if a referenced schema is not found in definitions +-- it stays referenced even if it appears in the list of names. +-- +-- __WARNING:__ @'inlineSchemas'@ will produce infinite schemas +-- when inlining recursive schemas. +inlineSchemas :: Data s => [T.Text] -> Definitions -> s -> s +inlineSchemas names = inlineSchemasWhen (`elem` names) + +-- | Inline all schema references for which the definition +-- can be found in @'Definitions'@. +-- +-- __WARNING:__ @'inlineAllSchemas'@ will produce infinite schemas +-- when inlining recursive schemas. +inlineAllSchemas :: Data s => Definitions -> s -> s +inlineAllSchemas = inlineSchemasWhen (const True) + +-- | Convert a type into a schema without references. +-- +-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day]) +-- "{\"items\":{\"format\":\"yyyy-mm-dd\",\"type\":\"string\"},\"type\":\"array\"}" +-- +-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema +-- when inlining recursive schemas. +toInlinedSchema :: ToSchema a => proxy a -> Schema +toInlinedSchema proxy = inlineAllSchemas defs schema + where + (defs, schema) = runDeclare (declareSchema proxy) mempty + +-- | Inline all /non-recursive/ schemas for which the definition +-- can be found in @'Definitions'@. +inlineNonRecursiveSchemas :: Data s => Definitions -> s -> s +inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs + where + nonRecursive name = + case HashMap.lookup name defs of + Just schema -> name `notElem` execDeclare (usedNames schema) mempty + Nothing -> False + + usedNames schema = traverse_ schemaRefNames (schema ^.. template) + + schemaRefNames :: Referenced Schema -> Declare [T.Text] () + schemaRefNames ref = case ref of + Ref (Reference name) -> do + seen <- looks (name `elem`) + when (not seen) $ do + declare [name] + traverse_ usedNames (HashMap.lookup name defs) + Inline subschema -> usedNames subschema + +class GToSchema (f :: * -> *) where + gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare Definitions NamedSchema + +instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where + declareNamedSchema _ = do + ref <- declareSchemaRef (Proxy :: Proxy a) + return $ unnamed $ mempty + & schemaType .~ SwaggerArray + & schemaItems ?~ SwaggerItemsObject ref + +instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Int32 where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Int64 where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Word where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Word8 where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema + +instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema + +instance ToSchema a => ToSchema (Maybe a) where + declareNamedSchema _ = declareNamedSchema (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) + +timeSchema :: T.Text -> Schema +timeSchema format = mempty + & schemaType .~ SwaggerString + & schemaFormat ?~ format + +-- | +-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat +-- Just "yyyy-mm-dd" +instance ToSchema Day where + declareNamedSchema _ = pure $ named "Day" (timeSchema "yyyy-mm-dd") + +-- | +-- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat +-- Just "yyyy-mm-ddThh:MM:ss" +instance ToSchema LocalTime where + declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss") + +-- | +-- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat +-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)" +instance ToSchema ZonedTime where + declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)" + +instance ToSchema NominalDiffTime where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer) + +-- | +-- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat +-- Just "yyyy-mm-ddThh:MM:ssZ" +instance ToSchema UTCTime where + declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ") + +instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema + +instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int)) + +-- | NOTE: This schema does not account for the uniqueness of keys. +instance ToSchema a => ToSchema (IntMap a) where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)]) + +instance ToSchema a => ToSchema (Map String a) where + declareNamedSchema _ = do + schema <- declareSchema (Proxy :: Proxy a) + return $ unnamed $ mempty + & schemaType .~ SwaggerObject + & schemaAdditionalProperties ?~ schema + +instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a)) +instance ToSchema a => ToSchema (Map TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a)) + +instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a)) +instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a)) +instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a)) + +instance ToSchema a => ToSchema (Set a) where + declareNamedSchema _ = do + schema <- declareSchema (Proxy :: Proxy [a]) + return $ unnamed $ schema + & schemaUniqueItems ?~ True + +instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a)) + +instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema +instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema + +instance ToSchema a => ToSchema (Sum a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) +instance ToSchema a => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) +instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) +instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) +instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) + +-- | Default schema for @'Bounded'@, @'Integral'@ types. +-- +-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16) +-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}" +toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema +toSchemaBoundedIntegral _ = mempty + & schemaType .~ SwaggerInteger + & 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. +genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare Definitions Schema +genericDeclareSchema opts proxy = snd <$> genericDeclareNamedSchema opts proxy + +-- | A configurable generic @'NamedSchema'@ creator. +-- This function applied to @'defaultSchemaOptions'@ +-- is used as the default for @'declareNamedSchema'@ +-- when the type is an instance of @'Generic'@. +genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare Definitions NamedSchema +genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty + +gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text +gdatatypeSchemaName opts _ = case name of + (c:_) | isAlpha c && isUpper c -> Just (T.pack name) + _ -> Nothing + where + name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a)) + +-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@. +paramSchemaToNamedSchema :: forall a d f proxy. + (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) + => SchemaOptions -> proxy a -> NamedSchema +paramSchemaToNamedSchema opts proxy = (gdatatypeSchemaName opts (Proxy :: Proxy d), paramSchemaToSchema proxy) + +-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@. +paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema +paramSchemaToSchema _ = mempty & schemaParamSchema .~ toParamSchema (Proxy :: Proxy a) + +nullarySchema :: Schema +nullarySchema = mempty + & schemaType .~ SwaggerArray + & schemaEnum ?~ [ toJSON () ] + +gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema +gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty + +gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare Definitions Schema +gdeclareSchema opts proxy = snd <$> gdeclareNamedSchema opts proxy mempty + +instance GToSchema U1 where + gdeclareNamedSchema _ _ _ = plain nullarySchema + +instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where + gdeclareNamedSchema opts _ schema = do + (_, gschema) <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema + gdeclareNamedSchema opts (Proxy :: Proxy f) gschema + +instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where + gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s + where + name = gdatatypeSchemaName opts (Proxy :: Proxy d) + +instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where + gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f) + +-- | Single field constructor. +instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where + gdeclareNamedSchema opts _ s + | unwrapUnaryRecords opts = fieldSchema + | otherwise = do + (_, schema) <- recordSchema + case schema ^. schemaItems of + Just (SwaggerItemsArray [_]) -> fieldSchema + _ -> pure (unnamed schema) + where + recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s + fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s + +gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare Definitions (Referenced Schema) +gdeclareSchemaRef opts proxy = do + case gtoNamedSchema opts proxy of + (Just name, schema) -> do + -- This check is very important as it allows generically + -- derive used definitions for recursive schemas. + -- Lazy Declare monad allows toNamedSchema to ignore + -- any declarations (which would otherwise loop) and + -- retrieve the schema and its name to check if we + -- have already declared it. + -- If we have, we don't need to declare anything for + -- this schema this time and thus simply return the reference. + known <- looks (HashMap.member name) + when (not known) $ do + declare [(name, schema)] + void $ gdeclareNamedSchema opts proxy mempty + return $ Ref (Reference name) + _ -> Inline <$> gdeclareSchema opts proxy + +appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema) +appendItem x Nothing = Just (SwaggerItemsArray [x]) +appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs)) +appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject" + +withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => + SchemaOptions -> proxy s f -> Bool -> Schema -> Declare Definitions Schema +withFieldSchema opts _ isRequiredField schema = do + ref <- gdeclareSchemaRef opts (Proxy :: Proxy f) + return $ + if T.null fname + then schema + & schemaType .~ SwaggerArray + & schemaItems %~ appendItem ref + else schema + & schemaType .~ SwaggerObject + & schemaProperties . at fname ?~ ref + & if isRequiredField + then schemaRequired %~ (fname :) + else id + where + fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p))) + +-- | Optional record fields. +instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where + gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False + +-- | Record fields. +instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where + gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True + +instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where + gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c) + +instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where + gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c) + +instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where + gdeclareNamedSchema opts _ s + | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema) + | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema + where + declareSumSchema = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s + (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema) + + toStringTag schema = mempty + & schemaType .~ SwaggerString + & schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex) + +type AllNullary = All + +class GSumToSchema f where + gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare Definitions) Schema + +instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where + gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g) + +gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) => + SchemaOptions -> proxy (C1 c f) -> Schema -> Declare Definitions Schema +gsumConToSchema opts _ schema = do + ref <- gdeclareSchemaRef opts (Proxy :: Proxy (C1 c f)) + return $ schema + & schemaType .~ SwaggerObject + & schemaProperties . at tag ?~ ref + & 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 proxy schema = do + tell (All False) + lift $ gsumConToSchema opts proxy schema + +instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where + gsumToSchema opts proxy schema = do + tell (All False) + lift $ gsumConToSchema opts proxy schema + +instance Constructor c => GSumToSchema (C1 c U1) where + gsumToSchema opts proxy = lift . gsumConToSchema opts proxy + +data Proxy2 a b = Proxy2 + +data Proxy3 a b c = Proxy3 + diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -1,24 +1,29 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} module Data.Swagger.Internal.Utils where import Control.Arrow (first) import Control.Applicative import Data.Aeson -import Data.Aeson.TH -import Data.Aeson.Types (Parser, Pair) +import Data.Aeson.Types import Data.Char +import Data.Data import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Monoid import Data.Text (Text) import GHC.Generics -import Language.Haskell.TH import Text.Read (readMaybe) +gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a +gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of + Just x -> z x + Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "." + hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList @@ -43,14 +48,19 @@ lowerFirstUppers s = map toLower x ++ y where (x, y) = span isUpper s -deriveToJSON' :: Name -> Q [Dec] -deriveToJSON' name = deriveToJSON (jsonPrefix (nameBase name)) name - -deriveJSONDefault :: Name -> Q [Dec] -deriveJSONDefault = deriveJSON (jsonPrefix "") +parseOneOf :: ToJSON a => [a] -> Value -> Parser a +parseOneOf xs js = + case lookup js ys of + Nothing -> fail $ "invalid json: " ++ show js ++ " (expected one of " ++ show (map fst ys) ++ ")" + Just x -> pure x + where + ys = zip (map toJSON xs) xs -deriveJSON' :: Name -> Q [Dec] -deriveJSON' name = deriveJSON (jsonPrefix (nameBase name)) name +omitEmpties :: Value -> Value +omitEmpties (Object o) = Object (HashMap.filter nonEmpty o) + where + nonEmpty js = (js /= Object mempty) && (js /= Array mempty) && (js /= Null) +omitEmpties js = js genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value genericToJSONWithSub sub opts x = diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} module Data.Swagger.Lens where @@ -11,38 +12,61 @@ import Data.Text (Text) -- ======================================================================= --- TH derived lenses --- ======================================================================= +-- * TH derived lenses +-- ** 'Swagger' lenses makeLenses ''Swagger +-- ** 'Host' lenses makeLenses ''Host +-- ** 'Info' lenses makeLenses ''Info +-- ** 'Contact' lenses makeLenses ''Contact +-- ** 'License' lenses makeLenses ''License +-- ** 'Paths' lenses makeLenses ''Paths +-- ** 'PathItem' lenses makeLenses ''PathItem +-- ** 'Tag' lenses makeLenses ''Tag +-- ** 'Operation' lenses makeLenses ''Operation -makeLenses ''Parameter -makePrisms ''ParameterSchema -makeLenses ''ParameterOtherSchema +-- ** 'Param' lenses +makeLenses ''Param +-- ** 'ParamAnySchema' prisms +makePrisms ''ParamAnySchema +-- ** 'ParamOtherSchema' lenses +makeLenses ''ParamOtherSchema +-- ** 'Items' lenses makeLenses ''Items +-- ** 'Header' lenses makeLenses ''Header +-- ** 'Schema' lenses makeLenses ''Schema -makePrisms ''SchemaItems -makeLenses ''SchemaCommon +-- ** 'SwaggerItems' prisms +makePrisms ''SwaggerItems +-- ** 'ParamSchema' lenses +makeLenses ''ParamSchema +-- ** 'Xml' lenses makeLenses ''Xml +-- ** 'Responses' lenses makeLenses ''Responses +-- ** 'Response' lenses makeLenses ''Response +-- ** 'SecurityScheme' lenses makeLenses ''SecurityScheme +-- ** 'SecuritySchemeType' prisms makePrisms ''SecuritySchemeType +-- ** 'ApiKeyParams' lenses makeLenses ''ApiKeyParams +-- ** 'OAuth2Params' lenses makeLenses ''OAuth2Params +-- ** 'ExternalDocs' lenses makeLenses ''ExternalDocs -- ======================================================================= --- Helper classy lenses --- ======================================================================= +-- * Helper classy lenses class HasDescription s d | s -> d where description :: Lens' s d @@ -51,57 +75,66 @@ 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 Param (Maybe Text) where description = paramDescription 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 HasSchemaCommon s where - schemaCommon :: Lens' s SchemaCommon +class HasParamSchema s t | s -> t where + parameterSchema :: Lens' s (ParamSchema t) -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 +instance HasParamSchema Schema Schema where parameterSchema = schemaParamSchema +instance HasParamSchema ParamOtherSchema ParamOtherSchema where parameterSchema = paramOtherSchemaParamSchema +instance HasParamSchema Items Items where parameterSchema = itemsParamSchema +instance HasParamSchema Header Header where parameterSchema = headerParamSchema +instance HasParamSchema (ParamSchema t) t where parameterSchema = id -schemaDefault :: HasSchemaCommon s => Lens' s (Maybe Value) -schemaDefault = schemaCommon.schemaCommonDefault +schemaType :: HasParamSchema s t => Lens' s (SwaggerType t) +schemaType = parameterSchema.paramSchemaType -schemaMaximum :: HasSchemaCommon s => Lens' s (Maybe Scientific) -schemaMaximum = schemaCommon.schemaCommonMaximum +schemaFormat :: HasParamSchema s t => Lens' s (Maybe Format) +schemaFormat = parameterSchema.paramSchemaFormat -schemaExclusiveMaximum :: HasSchemaCommon s => Lens' s (Maybe Bool) -schemaExclusiveMaximum = schemaCommon.schemaCommonExclusiveMaximum +schemaItems :: HasParamSchema s t => Lens' s (Maybe (SwaggerItems t)) +schemaItems = parameterSchema.paramSchemaItems -schemaMinimum :: HasSchemaCommon s => Lens' s (Maybe Scientific) -schemaMinimum = schemaCommon.schemaCommonMinimum +schemaDefault :: HasParamSchema s t => Lens' s (Maybe Value) +schemaDefault = parameterSchema.paramSchemaDefault -schemaExclusiveMinimum :: HasSchemaCommon s => Lens' s (Maybe Bool) -schemaExclusiveMinimum = schemaCommon.schemaCommonExclusiveMinimum +schemaMaximum :: HasParamSchema s t => Lens' s (Maybe Scientific) +schemaMaximum = parameterSchema.paramSchemaMaximum -schemaMaxLength :: HasSchemaCommon s => Lens' s (Maybe Integer) -schemaMaxLength = schemaCommon.schemaCommonMaxLength +schemaExclusiveMaximum :: HasParamSchema s t => Lens' s (Maybe Bool) +schemaExclusiveMaximum = parameterSchema.paramSchemaExclusiveMaximum -schemaMinLength :: HasSchemaCommon s => Lens' s (Maybe Integer) -schemaMinLength = schemaCommon.schemaCommonMinLength +schemaMinimum :: HasParamSchema s t => Lens' s (Maybe Scientific) +schemaMinimum = parameterSchema.paramSchemaMinimum -schemaPattern :: HasSchemaCommon s => Lens' s (Maybe Text) -schemaPattern = schemaCommon.schemaCommonPattern +schemaExclusiveMinimum :: HasParamSchema s t => Lens' s (Maybe Bool) +schemaExclusiveMinimum = parameterSchema.paramSchemaExclusiveMinimum -schemaMaxItems :: HasSchemaCommon s => Lens' s (Maybe Integer) -schemaMaxItems = schemaCommon.schemaCommonMaxItems +schemaMaxLength :: HasParamSchema s t => Lens' s (Maybe Integer) +schemaMaxLength = parameterSchema.paramSchemaMaxLength -schemaMinItems :: HasSchemaCommon s => Lens' s (Maybe Integer) -schemaMinItems = schemaCommon.schemaCommonMinItems +schemaMinLength :: HasParamSchema s t => Lens' s (Maybe Integer) +schemaMinLength = parameterSchema.paramSchemaMinLength -schemaUniqueItems :: HasSchemaCommon s => Lens' s (Maybe Bool) -schemaUniqueItems = schemaCommon.schemaCommonUniqueItems +schemaPattern :: HasParamSchema s t => Lens' s (Maybe Text) +schemaPattern = parameterSchema.paramSchemaPattern -schemaEnum :: HasSchemaCommon s => Lens' s (Maybe [Value]) -schemaEnum = schemaCommon.schemaCommonEnum +schemaMaxItems :: HasParamSchema s t => Lens' s (Maybe Integer) +schemaMaxItems = parameterSchema.paramSchemaMaxItems -schemaMultipleOf :: HasSchemaCommon s => Lens' s (Maybe Scientific) -schemaMultipleOf = schemaCommon.schemaCommonMultipleOf +schemaMinItems :: HasParamSchema s t => Lens' s (Maybe Integer) +schemaMinItems = parameterSchema.paramSchemaMinItems + +schemaUniqueItems :: HasParamSchema s t => Lens' s (Maybe Bool) +schemaUniqueItems = parameterSchema.paramSchemaUniqueItems + +schemaEnum :: HasParamSchema s t => Lens' s (Maybe [Value]) +schemaEnum = parameterSchema.paramSchemaEnum + +schemaMultipleOf :: HasParamSchema s t => Lens' s (Maybe Scientific) +schemaMultipleOf = parameterSchema.paramSchemaMultipleOf diff --git a/src/Data/Swagger/ParamSchema.hs b/src/Data/Swagger/ParamSchema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Swagger/ParamSchema.hs @@ -0,0 +1,23 @@ +-- | +-- Module: Data.Swagger.ParamSchema +-- Copyright: (c) 2015 GetShopTV +-- License: BSD3 +-- Maintainer: Nickolay Kudasov +-- Stability: experimental +-- +-- Types and functions for working with Swagger parameter schema. +module Data.Swagger.ParamSchema ( + -- * Encoding + ToParamSchema(..), + + -- * Generic schema encoding + genericToParamSchema, + toParamSchemaBoundedIntegral, + + -- * Generic encoding configuration + SchemaOptions(..), + defaultSchemaOptions, +) where + +import Data.Swagger.Internal.ParamSchema +import Data.Swagger.SchemaOptions diff --git a/src/Data/Swagger/Schema.hs b/src/Data/Swagger/Schema.hs --- a/src/Data/Swagger/Schema.hs +++ b/src/Data/Swagger/Schema.hs @@ -9,20 +9,33 @@ module Data.Swagger.Schema ( -- * Encoding ToSchema(..), + Definitions, NamedSchema, + declareSchema, + declareSchemaRef, toSchema, toSchemaRef, schemaName, + toInlinedSchema, -- * Generic schema encoding - genericToSchema, - genericToNamedSchema, + genericDeclareNamedSchema, + genericDeclareSchema, genericToNamedSchemaBoundedIntegral, toSchemaBoundedIntegral, + paramSchemaToNamedSchema, + paramSchemaToSchema, + -- * Inlining @'Schema'@s + inlineNonRecursiveSchemas, + inlineAllSchemas, + inlineSchemas, + inlineSchemasWhen, + -- * Generic encoding configuration SchemaOptions(..), defaultSchemaOptions, ) where -import Data.Swagger.Schema.Internal +import Data.Swagger.Internal.Schema +import Data.Swagger.SchemaOptions diff --git a/src/Data/Swagger/Schema/Internal.hs b/src/Data/Swagger/Schema/Internal.hs deleted file mode 100644 --- a/src/Data/Swagger/Schema/Internal.hs +++ /dev/null @@ -1,448 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# 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 "unordered-containers" Data.HashSet (HashSet) -import Data.Int -import Data.IntSet (IntSet) -import Data.IntMap (IntMap) -import Data.Map (Map) -import Data.Monoid -import Data.Proxy -import Data.Scientific (Scientific) -import Data.Set (Set) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Time -import Data.Word -import GHC.Generics - -import Data.Swagger.Internal -import Data.Swagger.Lens - --- | A @'Schema'@ with an optional name. --- This name can be used in references. -type NamedSchema = (Maybe String, Schema) - -unnamed :: Schema -> NamedSchema -unnamed schema = (Nothing, schema) - -named :: String -> Schema -> NamedSchema -named name schema = (Just name, schema) - --- | Convert a type into @'Schema'@. --- --- An example type and instance: --- --- @ --- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals --- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' as list --- --- import Control.Lens --- --- data Coord = Coord { x :: Double, y :: Double } --- --- instance ToSchema Coord where --- toNamedSchema = (Just \"Coord\", mempty --- & schemaType .~ SchemaObject --- & schemaProperties .~ --- [ ("x", toSchemaRef (Proxy :: Proxy Double)) --- , ("y", toSchemaRef (Proxy :: Proxy Double)) --- ] --- & schemaRequired .~ [ "x", "y" ] --- @ --- --- Instead of manually writing your @'ToSchema'@ instance you can --- use a default generic implementation of @'toNamedSchema'@. --- --- To do that, simply add @deriving 'Generic'@ clause to your datatype --- and declare a @'ToSchema'@ instance for your datatype without --- giving definition for @'toNamedSchema'@. --- --- For instance, the previous example can be simplified into this: --- --- @ --- {-\# LANGUAGE DeriveGeneric \#-} --- --- import GHC.Generics (Generic) --- --- data Coord = Coord { x :: Double, y :: Double } deriving Generic --- --- instance ToSchema Coord --- @ -class ToSchema a where - -- | Convert a type into an optionally named schema. - toNamedSchema :: proxy a -> NamedSchema - default toNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> NamedSchema - toNamedSchema = genericToNamedSchema defaultSchemaOptions - --- | Get type's schema name according to its @'ToSchema'@ instance. -schemaName :: ToSchema a => proxy a -> Maybe String -schemaName = fst . toNamedSchema - --- | Convert a type into a schema. -toSchema :: ToSchema a => proxy a -> Schema -toSchema = snd . toNamedSchema - --- | Convert a type into a referenced schema if possible. --- Only named schemas can be references, nameless schemas are inlined. -toSchemaRef :: ToSchema a => proxy a -> Referenced Schema -toSchemaRef proxy = case toNamedSchema proxy of - (Just name, _) -> Ref (Reference ("#/definitions/" <> T.pack name)) - (_, schema) -> Inline schema - -class GToSchema (f :: * -> *) where - gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema - -gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema -gtoSchema opts proxy = snd . gtoNamedSchema opts proxy - -instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where - toNamedSchema _ = unnamed $ mempty - & schemaType .~ SchemaArray - & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a)) - -instance {-# OVERLAPPING #-} ToSchema String where - toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaString - -instance ToSchema Bool where - toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaBoolean - -instance ToSchema Integer where - toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaInteger - -instance ToSchema Int where toNamedSchema = unnamed . toSchemaBoundedIntegral -instance ToSchema Int8 where toNamedSchema = unnamed . toSchemaBoundedIntegral -instance ToSchema Int16 where toNamedSchema = unnamed . toSchemaBoundedIntegral -instance ToSchema Int32 where toNamedSchema = unnamed . toSchemaBoundedIntegral -instance ToSchema Int64 where toNamedSchema = unnamed . toSchemaBoundedIntegral - -instance ToSchema Word where toNamedSchema = unnamed . toSchemaBoundedIntegral -instance ToSchema Word8 where toNamedSchema = unnamed . toSchemaBoundedIntegral -instance ToSchema Word16 where toNamedSchema = unnamed . toSchemaBoundedIntegral -instance ToSchema Word32 where toNamedSchema = unnamed . toSchemaBoundedIntegral -instance ToSchema Word64 where toNamedSchema = unnamed . toSchemaBoundedIntegral - -instance ToSchema Char where - toNamedSchema _ = unnamed $ mempty - & schemaType .~ SchemaString - & schemaMaxLength ?~ 1 - & schemaMinLength ?~ 1 - -instance ToSchema Scientific where - toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber - -instance ToSchema Double where - toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber - -instance ToSchema Float where - toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber - -instance ToSchema a => ToSchema (Maybe a) where - toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) - -instance (ToSchema a, ToSchema b) => ToSchema (Either a b) - -instance ToSchema () -instance (ToSchema a, ToSchema b) => ToSchema (a, b) -instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) - -timeNamedSchema :: String -> String -> NamedSchema -timeNamedSchema name format = (Just name, mempty - & schemaType .~ SchemaString - & schemaFormat ?~ T.pack format - & schemaMinLength ?~ toInteger (length format)) - --- | --- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat --- Just "yyyy-mm-dd" -instance ToSchema Day where - toNamedSchema _ = timeNamedSchema "Day" "yyyy-mm-dd" - --- | --- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat --- Just "yyyy-mm-ddThh:MM:ss" -instance ToSchema LocalTime where - toNamedSchema _ = timeNamedSchema "LocalTime" "yyyy-mm-ddThh:MM:ss" - --- | --- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat --- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)" -instance ToSchema ZonedTime where - toNamedSchema _ = (Just "ZonedTime", mempty - & schemaType .~ SchemaString - & schemaFormat ?~ "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)" - & schemaMinLength ?~ toInteger (length ("yyyy-mm-ddThh:MM:ssZ" :: String))) - -instance ToSchema NominalDiffTime where - toNamedSchema _ = toNamedSchema (Proxy :: Proxy Integer) - --- | --- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat --- Just "yyyy-mm-ddThh:MM:ssZ" -instance ToSchema UTCTime where - toNamedSchema _ = timeNamedSchema "UTCTime" "yyyy-mm-ddThh:MM:ssZ" - -instance ToSchema T.Text where - toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String) - -instance ToSchema TL.Text where - toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String) - -instance ToSchema IntSet where toNamedSchema _ = toNamedSchema (Proxy :: Proxy (Set Int)) - --- | NOTE: This schema does not account for the uniqueness of keys. -instance ToSchema a => ToSchema (IntMap a) where - toNamedSchema _ = toNamedSchema (Proxy :: Proxy [(Int, a)]) - -instance ToSchema a => ToSchema (Map String a) where - toNamedSchema _ = unnamed $ mempty - & schemaType .~ SchemaObject - & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a) - -instance ToSchema a => ToSchema (Map T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a)) -instance ToSchema a => ToSchema (Map TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a)) - -instance ToSchema a => ToSchema (HashMap String a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a)) -instance ToSchema a => ToSchema (HashMap T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a)) -instance ToSchema a => ToSchema (HashMap TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a)) - -instance ToSchema a => ToSchema (Set a) where - toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy [a]) - & schemaUniqueItems ?~ True - -instance ToSchema a => ToSchema (HashSet a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Set a)) - -instance ToSchema All where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool) -instance ToSchema Any where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool) -instance ToSchema a => ToSchema (Sum a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) -instance ToSchema a => ToSchema (Product a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) -instance ToSchema a => ToSchema (First a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) -instance ToSchema a => ToSchema (Last a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) -instance ToSchema a => ToSchema (Dual a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a) - --- | Options that specify how to encode your type to Swagger schema. -data SchemaOptions = SchemaOptions - { -- | Function applied to field labels. Handy for removing common record prefixes for example. - fieldLabelModifier :: String -> String - -- | Function applied to constructor tags which could be handy for lower-casing them for example. - , constructorTagModifier :: String -> String - -- | Function applied to datatype name. - , datatypeNameModifier :: String -> String - -- | If @'True'@ the constructors of a datatype, with all nullary constructors, - -- will be encoded to a string enumeration schema with the constructor tags as possible values. - , allNullaryToStringTag :: Bool - -- | If @'True'@ direct subschemas will be referenced if possible (rather than inlined). - -- Note that this option does not influence nested schemas, e.g. for these types - -- - -- @ - -- data Object = Object String deriving Generic - -- instance ToSchema Object - -- - -- newtype Objects = Objects [Object] deriving Generic - -- instance ToSchema Objects where - -- toNamedSchema = genericToNamedSchema defaultSchemaOptions - -- { useReferences = False } - -- @ - -- - -- Schema for @Objects@ __will not__ inline @Object@ schema because - -- it is nested in a @[]@ schema. - , useReferences :: Bool - -- | Hide the field name when a record constructor has only one field, like a newtype. - , unwrapUnaryRecords :: Bool - } - --- | Default encoding @'SchemaOptions'@. --- --- @ --- 'SchemaOptions' --- { 'fieldLabelModifier' = id --- , 'constructorTagModifier' = id --- , 'datatypeNameModifier' = id --- , 'allNullaryToStringTag' = True --- , 'useReferences' = True --- , 'unwrapUnaryRecords' = False --- } --- @ -defaultSchemaOptions :: SchemaOptions -defaultSchemaOptions = SchemaOptions - { fieldLabelModifier = id - , constructorTagModifier = id - , datatypeNameModifier = id - , allNullaryToStringTag = True - , useReferences = True - , unwrapUnaryRecords = False - } - --- | Default schema for @'Bounded'@, @'Integral'@ types. -toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema -toSchemaBoundedIntegral _ = mempty - & schemaType .~ SchemaInteger - & schemaMinimum ?~ fromInteger (toInteger (minBound :: a)) - & schemaMaximum ?~ fromInteger (toInteger (maxBound :: a)) - --- | Default generic named schema for @'Bounded'@, @'Integral'@ types. -genericToNamedSchemaBoundedIntegral :: forall a d f proxy. - ( Bounded a, Integral a - , Generic a, Rep a ~ D1 d f, Datatype d) - => SchemaOptions -> proxy a -> NamedSchema -genericToNamedSchemaBoundedIntegral opts proxy - = (gdatatypeSchemaName opts (Proxy :: Proxy d), toSchemaBoundedIntegral proxy) - --- | A configurable generic @'Schema'@ creator. -genericToSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Schema -genericToSchema opts = snd . genericToNamedSchema opts - --- | A configurable generic @'NamedSchema'@ creator. --- This function applied to @'defaultSchemaOptions'@ --- is used as the default for @'toNamedSchema'@ --- when the type is an instance of @'Generic'@. -genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema -genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty - -gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String -gdatatypeSchemaName opts _ = case name of - (c:_) | isAlpha c && isUpper c -> Just name - _ -> Nothing - where - name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a)) - -nullarySchema :: Schema -nullarySchema = mempty - & schemaType .~ SchemaArray - & schemaEnum ?~ [ toJSON () ] - -instance GToSchema U1 where - gtoNamedSchema _ _ _ = unnamed nullarySchema - -instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where - gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g) - -instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where - gtoNamedSchema opts _ s = (name, gtoSchema opts (Proxy :: Proxy f) s) - where - name = gdatatypeSchemaName opts (Proxy :: Proxy d) - -instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where - gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) - --- | Single field constructor. -instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where - gtoNamedSchema opts _ s - | unwrapUnaryRecords opts = fieldSchema - | otherwise = - case schema ^. schemaItems of - Just (SchemaItemsArray [_]) -> fieldSchema - _ -> unnamed schema - where - schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s - fieldSchema = gtoNamedSchema opts (Proxy :: Proxy f) s - -gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> Referenced Schema -gtoSchemaRef opts proxy = case gtoNamedSchema opts proxy mempty of - (Just name, _) - | useReferences opts -> Ref (Reference ("#/definitions/" <> T.pack name)) - (_, schema) -> Inline schema - -appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems -appendItem x Nothing = Just (SchemaItemsArray [x]) -appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs)) -appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject" - -withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Schema -withFieldSchema opts _ isRequiredField schema - | T.null fieldName = schema - & schemaType .~ SchemaArray - & schemaItems %~ appendItem fieldSchemaRef - | otherwise = schema - & schemaType .~ SchemaObject - & schemaProperties . at fieldName ?~ fieldSchemaRef - & if isRequiredField - then schemaRequired %~ (fieldName :) - else id - where - fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p))) - fieldSchemaRef = gtoSchemaRef opts (Proxy :: Proxy f) - --- | Optional record fields. -instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where - gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False - --- | Record fields. -instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where - gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True - -instance ToSchema c => GToSchema (K1 i c) where - gtoNamedSchema _ _ _ = toNamedSchema (Proxy :: Proxy c) - -instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where - gtoNamedSchema opts _ s - | allNullaryToStringTag opts && allNullary = unnamed (toStringTag sumSchema) - | otherwise = unnamed sumSchema - where - (All allNullary, sumSchema) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s - - toStringTag schema = mempty - & schemaType .~ SchemaString - & schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex) - -type AllNullary = All - -class GSumToSchema f where - gsumToSchema :: SchemaOptions -> proxy f -> Schema -> (AllNullary, Schema) - -instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where - gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) `after` gsumToSchema opts (Proxy :: Proxy g) - where - (f `after` g) s = (a <> b, s'') - where - (a, s') = f s - (b, s'') = g s' - -gsumConToSchema :: forall c f proxy. Constructor c => - Bool -> Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> (AllNullary, Schema) -gsumConToSchema isNullary tagSchemaRef opts _ schema = (All isNullary, schema - & schemaType .~ SchemaObject - & schemaProperties . at tag ?~ tagSchemaRef - & schemaMaxProperties ?~ 1 - & schemaMinProperties ?~ 1) - where - tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) - -instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where - gsumToSchema opts = gsumConToSchema False tagSchemaRef opts - where - tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c f)) - -instance Constructor c => GSumToSchema (C1 c U1) where - gsumToSchema opts = gsumConToSchema True tagSchemaRef opts - where - tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c U1)) - -instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where - gsumToSchema opts = gsumConToSchema False tagSchemaRef opts - where - tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c (S1 s f))) - -data Proxy2 a b = Proxy2 - -data Proxy3 a b c = Proxy3 - diff --git a/src/Data/Swagger/SchemaOptions.hs b/src/Data/Swagger/SchemaOptions.hs new file mode 100644 --- /dev/null +++ b/src/Data/Swagger/SchemaOptions.hs @@ -0,0 +1,37 @@ +module Data.Swagger.SchemaOptions where + +-- | 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 + -- | 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 +-- , 'unwrapUnaryRecords' = False +-- } +-- @ +defaultSchemaOptions :: SchemaOptions +defaultSchemaOptions = SchemaOptions + { fieldLabelModifier = id + , constructorTagModifier = id + , datatypeNameModifier = id + , allNullaryToStringTag = True + , unwrapUnaryRecords = False + } + diff --git a/swagger2.cabal b/swagger2.cabal --- a/swagger2.cabal +++ b/swagger2.cabal @@ -1,5 +1,5 @@ name: swagger2 -version: 0.4.1 +version: 1.0 synopsis: Swagger 2.0 data model description: Please see README.md homepage: https://github.com/GetShopTV/swagger2 @@ -14,26 +14,31 @@ extra-source-files: README.md , CHANGELOG.md + , examples/*.hs cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Data.Swagger + Data.Swagger.Declare Data.Swagger.Lens + Data.Swagger.ParamSchema Data.Swagger.Schema + Data.Swagger.SchemaOptions -- internal modules Data.Swagger.Internal + Data.Swagger.Internal.Schema + Data.Swagger.Internal.ParamSchema Data.Swagger.Internal.Utils - Data.Swagger.Schema.Internal build-depends: base == 4.* - , aeson < 0.10 + , aeson , containers , hashable , http-media + , mtl , network - , template-haskell , text , time , unordered-containers @@ -56,6 +61,7 @@ , containers , unordered-containers , vector + , lens other-modules: SpecCommon Data.SwaggerSpec diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs --- a/test/Data/Swagger/SchemaSpec.hs +++ b/test/Data/Swagger/SchemaSpec.hs @@ -8,23 +8,48 @@ import Data.Aeson import Data.Aeson.QQ import Data.Char +import qualified Data.HashMap.Strict as HashMap import Data.Proxy import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text import GHC.Generics import Data.Swagger +import Data.Swagger.Declare import SpecCommon import Test.Hspec checkToSchema :: ToSchema a => Proxy a -> Value -> Spec -checkToSchema proxy js = toSchema proxy <~> js +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 + schemaName proxy `shouldBe` fmap Text.pack sname +checkDefs :: ToSchema a => Proxy a -> [String] -> Spec +checkDefs proxy names = + it ("uses these definitions " ++ show names) $ + Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names) + where + defs = execDeclare (declareNamedSchema proxy) mempty + +checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec +checkInlinedSchema proxy js = toInlinedSchema proxy <=> js + +checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec +checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs schema <=> js + where + (defs, schema) = runDeclare (declareSchema proxy) mempty + +checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec +checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs schema <=> js + where + (defs, schema) = runDeclare (declareSchema proxy) mempty + spec :: Spec spec = do describe "Generic ToSchema" $ do @@ -33,6 +58,7 @@ 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 "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON 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 @@ -49,6 +75,20 @@ context "String" $ checkSchemaName Nothing (Proxy :: Proxy String) context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float)) context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person) + context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade) + describe "Generic Definitions" $ do + context "Unit" $ checkDefs (Proxy :: Proxy Unit) [] + context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"] + context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"] + context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"] + context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"] + context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"] + describe "Inlining Schemas" $ do + context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON + context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON + context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON + context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON + context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON main :: IO () main = hspec spec @@ -103,7 +143,7 @@ } deriving (Generic) instance ToSchema Point where - toNamedSchema = genericToNamedSchema defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = map toLower . drop (length "point") } pointSchemaJSON :: Value @@ -138,6 +178,22 @@ |] -- ======================================================================== +-- Shade (paramSchemaToNamedSchema) +-- ======================================================================== + +data Shade = Dim | Bright deriving (Generic, ToParamSchema) + +instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions + +shadeSchemaJSON :: Value +shadeSchemaJSON = [aesonQQ| +{ + "type": "string", + "enum": ["Dim", "Bright"] +} +|] + +-- ======================================================================== -- Paint (record with bounded enum property) -- ======================================================================== @@ -159,6 +215,22 @@ } |] +paintInlinedSchemaJSON :: Value +paintInlinedSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "color": + { + "type": "string", + "enum": ["Red", "Green", "Blue"] + } + }, + "required": ["color"] +} +|] + -- ======================================================================== -- Email (newtype with unwrapUnaryRecords set to True) -- ======================================================================== @@ -167,7 +239,7 @@ deriving (Generic) instance ToSchema Email where - toNamedSchema = genericToNamedSchema defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { unwrapUnaryRecords = True } emailSchemaJSON :: Value @@ -240,7 +312,7 @@ } deriving (Generic) instance ToSchema MyRoseTree where - toNamedSchema = genericToNamedSchema defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { datatypeNameModifier = drop (length "My") } myRoseTreeSchemaJSON :: Value @@ -270,7 +342,9 @@ newtype Inlined a = Inlined { getInlined :: a } instance ToSchema a => ToSchema (Inlined a) where - toNamedSchema _ = (Nothing, toSchema (Proxy :: Proxy a)) + declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) + where + unname (_, schema) = (Nothing, schema) newtype Players = Players [Inlined Player] deriving (Generic, ToSchema) @@ -304,7 +378,7 @@ deriving (Generic) instance ToSchema Status where - toNamedSchema = genericToNamedSchema defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { constructorTagModifier = map toLower . drop (length "Status") } statusSchemaJSON :: Value @@ -368,6 +442,89 @@ } |] +characterInlinedSchemaJSON :: Value +characterInlinedSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "PC": + { + "type": "object", + "properties": + { + "position": + { + "type": "object", + "properties": + { + "x": { "type": "number" }, + "y": { "type": "number" } + }, + "required": ["x", "y"] + } + }, + "required": ["position"] + }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": + { + "type": "object", + "properties": + { + "x": { "type": "number" }, + "y": { "type": "number" } + }, + "required": ["x", "y"] + } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +characterInlinedPlayerSchemaJSON :: Value +characterInlinedPlayerSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "PC": + { + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] + }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": { "$ref": "#/definitions/Point" } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + -- ======================================================================== -- Light (sum type with unwrapUnaryRecords) -- ======================================================================== @@ -379,7 +536,7 @@ deriving (Generic) instance ToSchema Light where - toNamedSchema = genericToNamedSchema defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { unwrapUnaryRecords = True } lightSchemaJSON :: Value @@ -390,6 +547,25 @@ { "LightFreq": { "type": "number" }, "LightColor": { "$ref": "#/definitions/Color" }, + "LightWaveLength": { "type": "number" } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +lightInlinedSchemaJSON :: Value +lightInlinedSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "LightFreq": { "type": "number" }, + "LightColor": + { + "type": "string", + "enum": ["Red", "Green", "Blue"] + }, "LightWaveLength": { "type": "number" } }, "maxProperties": 1, diff --git a/test/Data/SwaggerSpec.hs b/test/Data/SwaggerSpec.hs --- a/test/Data/SwaggerSpec.hs +++ b/test/Data/SwaggerSpec.hs @@ -4,6 +4,8 @@ {-# LANGUAGE QuasiQuotes #-} module Data.SwaggerSpec where +import Control.Lens + import Data.Aeson import Data.Aeson.QQ import Data.HashMap.Strict (HashMap) @@ -18,18 +20,18 @@ describe "License Object" $ licenseExample <=> licenseExampleJSON describe "Contact Object" $ contactExample <=> contactExampleJSON describe "Info Object" $ infoExample <=> infoExampleJSON - describe "Operation Object" $ operationExample <~> operationExampleJSON + describe "Operation Object" $ operationExample <=> operationExampleJSON describe "Schema Object" $ do - context "Primitive Sample" $ schemaPrimitiveExample <~> schemaPrimitiveExampleJSON - context "Simple Model" $ schemaSimpleModelExample <~> schemaSimpleModelExampleJSON - context "Model with Map/Dictionary Properties" $ schemaModelDictExample <~> schemaModelDictExampleJSON - context "Model with Example" $ schemaWithExampleExample <~> schemaWithExampleExampleJSON - describe "Definitions Object" $ definitionsExample <~> definitionsExampleJSON - describe "Parameters Definition Object" $ parametersDefinitionExample <~> parametersDefinitionExampleJSON - describe "Responses Definition Object" $ responsesDefinitionExample <~> responsesDefinitionExampleJSON - describe "Security Definitions Object" $ securityDefinitionsExample <~> securityDefinitionsExampleJSON + context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON + context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON + context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON + context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON + describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON + describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON + describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON + describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON describe "Swagger Object" $ do - context "Todo Example" $ swaggerExample <~> swaggerExampleJSON + context "Todo Example" $ swaggerExample <=> swaggerExampleJSON context "PetStore Example" $ it "decodes successfully" $ do fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: Swagger) -> True; _ -> False) @@ -131,27 +133,27 @@ , (405, Inline mempty { _responseDescription = "Invalid input" }) ] } 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) } + [ Param + { _paramName = "petId" + , _paramDescription = Just "ID of pet that needs to be updated" + , _paramRequired = Just True + , _paramSchema = ParamOther (stringSchema ParamPath) } + , Param + { _paramName = "name" + , _paramDescription = Just "Updated name of the pet" + , _paramRequired = Just False + , _paramSchema = ParamOther (stringSchema ParamFormData) } + , Param + { _paramName = "status" + , _paramDescription = Just "Updated status of the pet" + , _paramRequired = Just False + , _paramSchema = ParamOther (stringSchema ParamFormData) } ] + stringSchema :: ParamLocation -> ParamOtherSchema stringSchema i = mempty - { _parameterOtherSchemaIn = i - , _parameterOtherSchemaType = ParamString - } + & paramOtherSchemaIn .~ i + & schemaType .~ SwaggerString operationExampleJSON :: Value operationExampleJSON = [aesonQQ| @@ -217,9 +219,8 @@ schemaPrimitiveExample :: Schema schemaPrimitiveExample = mempty - { _schemaType = SchemaString - , _schemaFormat = Just "email" - } + & schemaType .~ SwaggerString + & schemaFormat ?~ "email" schemaPrimitiveExampleJSON :: Value schemaPrimitiveExampleJSON = [aesonQQ| @@ -231,17 +232,15 @@ schemaSimpleModelExample :: Schema schemaSimpleModelExample = mempty - { _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 } } ) ] } + & schemaType .~ SwaggerObject + & schemaRequired .~ [ "name" ] + & schemaProperties .~ + [ ("name", Inline (mempty & schemaType .~ SwaggerString)) + , ("address", Ref (Reference "Address")) + , ("age", Inline $ mempty + & schemaMinimum ?~ 0 + & schemaType .~ SwaggerInteger + & schemaFormat ?~ "int32" ) ] schemaSimpleModelExampleJSON :: Value schemaSimpleModelExampleJSON = [aesonQQ| @@ -268,9 +267,8 @@ schemaModelDictExample :: Schema schemaModelDictExample = mempty - { _schemaType = SchemaObject - , _schemaAdditionalProperties = Just mempty - { _schemaType = SchemaString } } + & schemaType .~ SwaggerObject + & schemaAdditionalProperties ?~ (mempty & schemaType .~ SwaggerString) schemaModelDictExampleJSON :: Value schemaModelDictExampleJSON = [aesonQQ| @@ -283,14 +281,12 @@ |] schemaWithExampleExample :: Schema -schemaWithExampleExample = mempty - { _schemaType = SchemaObject - , _schemaProperties = - [ ("id", Inline mempty - { _schemaType = SchemaInteger - , _schemaFormat = Just "int64" }) - , ("name", Inline mempty - { _schemaType = SchemaString }) ] +schemaWithExampleExample = (mempty & schemaType .~ SwaggerObject) + { _schemaProperties = + [ ("id", Inline $ mempty + & schemaType .~ SwaggerInteger + & schemaFormat ?~ "int64" ) + , ("name", Inline (mempty & schemaType .~ SwaggerString)) ] , _schemaRequired = [ "name" ] , _schemaExample = Just [aesonQQ| { @@ -329,21 +325,19 @@ definitionsExample :: HashMap Text Schema definitionsExample = [ ("Category", mempty - { _schemaType = SchemaObject - , _schemaProperties = - [ ("id", Inline mempty - { _schemaType = SchemaInteger - , _schemaFormat = Just "int64" }) - , ("name", Inline mempty - { _schemaType = SchemaString }) ] }) + & schemaType .~ SwaggerObject + & schemaProperties .~ + [ ("id", Inline $ mempty + & schemaType .~ SwaggerInteger + & schemaFormat ?~ "int64") + , ("name", Inline (mempty & schemaType .~ SwaggerString)) ] ) , ("Tag", mempty - { _schemaType = SchemaObject - , _schemaProperties = - [ ("id", Inline mempty - { _schemaType = SchemaInteger - , _schemaFormat = Just "int64" }) - , ("name", Inline mempty - { _schemaType = SchemaString }) ] }) ] + & schemaType .~ SwaggerObject + & schemaProperties .~ + [ ("id", Inline $ mempty + & schemaType .~ SwaggerInteger + & schemaFormat ?~ "int64") + , ("name", Inline (mempty & schemaType .~ SwaggerString)) ] ) ] definitionsExampleJSON :: Value definitionsExampleJSON = [aesonQQ| @@ -379,27 +373,27 @@ -- Parameters Definition object -- ======================================================================= -parametersDefinitionExample :: HashMap Text Parameter -parametersDefinitionExample = +paramsDefinitionExample :: HashMap Text Param +paramsDefinitionExample = [ ("skipParam", mempty - { _parameterName = "skip" - , _parameterDescription = Just "number of items to skip" - , _parameterRequired = Just True - , _parameterSchema = ParameterOther mempty - { _parameterOtherSchemaIn = ParameterQuery - , _parameterOtherSchemaType = ParamInteger - , _parameterOtherSchemaFormat = Just "int32" } }) + { _paramName = "skip" + , _paramDescription = Just "number of items to skip" + , _paramRequired = Just True + , _paramSchema = ParamOther $ mempty + & paramOtherSchemaIn .~ ParamQuery + & schemaType .~ SwaggerInteger + & schemaFormat ?~ "int32" }) , ("limitParam", mempty - { _parameterName = "limit" - , _parameterDescription = Just "max records to return" - , _parameterRequired = Just True - , _parameterSchema = ParameterOther mempty - { _parameterOtherSchemaIn = ParameterQuery - , _parameterOtherSchemaType = ParamInteger - , _parameterOtherSchemaFormat = Just "int32" } }) ] + { _paramName = "limit" + , _paramDescription = Just "max records to return" + , _paramRequired = Just True + , _paramSchema = ParamOther $ mempty + & paramOtherSchemaIn .~ ParamQuery + & schemaType .~ SwaggerInteger + & schemaFormat ?~ "int32" }) ] -parametersDefinitionExampleJSON :: Value -parametersDefinitionExampleJSON = [aesonQQ| +paramsDefinitionExampleJSON :: Value +paramsDefinitionExampleJSON = [aesonQQ| { "skipParam": { "name": "skip", @@ -500,30 +494,28 @@ { _operationResponses = mempty { _responsesResponses = [ (200, Inline mempty - { _responseSchema = Just $ Inline mempty + { _responseSchema = Just $ Inline (mempty & schemaType .~ SwaggerObject) { _schemaExample = Just [aesonQQ| { "created": 100, "description": "get milk" } |] - , _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 }) ] } + [ ("created", Inline $ mempty + & schemaType .~ SwaggerInteger + & schemaFormat ?~ "int32") + , ("description", Inline (mempty & schemaType .~ SwaggerString)) ] } , _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 } } ] + { _paramRequired = Just True + , _paramName = "id" + , _paramDescription = Just "TodoId param" + , _paramSchema = ParamOther $ mempty + & paramOtherSchemaIn .~ ParamPath + & schemaType .~ SwaggerString } ] , _operationTags = [ "todo" ] } }) ] } } swaggerExampleJSON :: Value diff --git a/test/SpecCommon.hs b/test/SpecCommon.hs --- a/test/SpecCommon.hs +++ b/test/SpecCommon.hs @@ -15,13 +15,6 @@ 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