swagger2 0.4.1 → 1.0
raw patch · 18 files changed
+2082/−892 lines, 18 filesdep +mtldep −template-haskelldep ~aesondep ~base
Dependencies added: mtl
Dependencies removed: template-haskell
Dependency ranges changed: aeson, base
Files
- CHANGELOG.md +50/−6
- README.md +29/−0
- examples/hackage.hs +70/−0
- src/Data/Swagger.hs +164/−23
- src/Data/Swagger/Declare.hs +118/−0
- src/Data/Swagger/Internal.hs +416/−242
- src/Data/Swagger/Internal/ParamSchema.hs +214/−0
- src/Data/Swagger/Internal/Schema.hs +565/−0
- src/Data/Swagger/Internal/Utils.hs +20/−10
- src/Data/Swagger/Lens.hs +76/−43
- src/Data/Swagger/ParamSchema.hs +23/−0
- src/Data/Swagger/Schema.hs +16/−3
- src/Data/Swagger/Schema/Internal.hs +0/−448
- src/Data/Swagger/SchemaOptions.hs +37/−0
- swagger2.cabal +10/−4
- test/Data/Swagger/SchemaSpec.hs +184/−8
- test/Data/SwaggerSpec.hs +90/−98
- test/SpecCommon.hs +0/−7
CHANGELOG.md view
@@ -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.
README.md view
@@ -4,3 +4,32 @@ [](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*+
+ examples/hackage.hs view
@@ -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+
src/Data/Swagger.hs view
@@ -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\"}}}"+--
+ src/Data/Swagger/Declare.hs view
@@ -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+
src/Data/Swagger/Internal.hs view
@@ -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 <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).- | 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")
+ src/Data/Swagger/Internal/ParamSchema.hs view
@@ -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+
+ src/Data/Swagger/Internal/Schema.hs view
@@ -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+
src/Data/Swagger/Internal/Utils.hs view
@@ -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 =
src/Data/Swagger/Lens.hs view
@@ -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
+ src/Data/Swagger/ParamSchema.hs view
@@ -0,0 +1,23 @@+-- |+-- Module: Data.Swagger.ParamSchema+-- Copyright: (c) 2015 GetShopTV+-- License: BSD3+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>+-- 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
src/Data/Swagger/Schema.hs view
@@ -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
− src/Data/Swagger/Schema/Internal.hs
@@ -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-
+ src/Data/Swagger/SchemaOptions.hs view
@@ -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+ }+
swagger2.cabal view
@@ -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
test/Data/Swagger/SchemaSpec.hs view
@@ -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,
test/Data/SwaggerSpec.hs view
@@ -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
test/SpecCommon.hs view
@@ -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