swagger2 1.2.1 → 2.0

raw patch · 22 files changed

+1807/−515 lines, 22 filesdep +base-compatdep +template-haskelldep +transformersdep ~basedep ~http-media

Dependencies added: base-compat, template-haskell, transformers

Dependency ranges changed: base, http-media

Files

• CHANGELOG.md +23/−1
• README.md +2/−0
• examples/hackage.hs +25/−23
• include/overlapping-compat.h +8/−0
• src/Data/Swagger.hs +76/−23
• src/Data/Swagger/Declare.hs +8/−5
• src/Data/Swagger/Internal.hs +86/−59
• src/Data/Swagger/Internal/ParamSchema.hs +62/−32
• src/Data/Swagger/Internal/Schema.hs +231/−93
• src/Data/Swagger/Internal/Schema/Validation.hs +324/−0
• src/Data/Swagger/Internal/Utils.hs +29/−1
• src/Data/Swagger/Lens.hs +110/−97
• src/Data/Swagger/Operation.hs +196/−0
• src/Data/Swagger/ParamSchema.hs +5/−0
• src/Data/Swagger/Schema.hs +9/−2
• src/Data/Swagger/Schema/Validation.hs +83/−0
• swagger2.cabal +25/−9
• test/Data/Swagger/ParamSchemaSpec.hs +114/−0
• test/Data/Swagger/Schema/ValidationSpec.hs +213/−0
• test/Data/Swagger/SchemaSpec.hs +40/−21
• test/Data/SwaggerSpec.hs +136/−148
• test/DocTest.hs +2/−1

@@ -1,7 +1,29 @@+2.0+---++* Major changes:+    * GHC 7.8 support (see [#49](https://github.com/GetShopTV/swagger2/pull/49));+    * Switch to classy field lenses (see [#41](https://github.com/GetShopTV/swagger2/pull/41));+    * Add `Data.Swagger.Schema.Validation` (see [#18](https://github.com/GetShopTV/swagger2/pull/18));+    * Add `Data.Swagger.Operation` with helpers (see [#50](https://github.com/GetShopTV/swagger2/pull/50));+    * Add `IsString` instances for some types (see [#47](https://github.com/GetShopTV/swagger2/pull/47));+    * Add helpers to sketch `Schema` from JSON (see [#48](https://github.com/GetShopTV/swagger2/pull/48)).++* Minor changes:+    * Make `NamedSchema` a `data` rather than `type` (see [#42](https://github.com/GetShopTV/swagger2/pull/42));+    * Change `Definitions` to `Definitions Schema`;+    * Add schema templates for `"binary"`, `"byte"` and `"password"` formats (see [63ed597](https://github.com/GetShopTV/swagger2/commit/63ed59736dc4f942f0e2a7d668d7cee513fa9eaf));+    * Add `Monoid` instance for `Contact`;+    * Change `tags` to be `Set` rather than list.++* Fixes:+    * Fix schema for `()` and nullary constructors (see [ab65c4a](https://github.com/GetShopTV/swagger2/commit/ab65c4a48253c34f8a88221a53dc97bf5e6e8d29));+    * Fix `Operation` `FromJSON` instance to allow missing `tags` and `parameters` properties.+ 1.2.1 --- -* Minor change:+* Minor changes:     * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.  * Fixes:

@@ -2,6 +2,8 @@  [![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2) [![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)+[![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2)+[![Stackage Nightly](http://stackage.org/package/swagger2/badge/nightly)](http://stackage.org/nightly/package/swagger2)  Swagger 2.0 data model. 

@@ -13,6 +13,7 @@ import Data.Swagger import Data.Swagger.Declare import Data.Swagger.Lens+import Data.Swagger.Operation  type Username = Text @@ -37,32 +38,33 @@   where     (defs, spec) = runDeclare declareHackageSwagger mempty -declareHackageSwagger :: Declare Definitions Swagger+declareHackageSwagger :: Declare (Definitions Schema) Swagger declareHackageSwagger = do+  -- param schemas   let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)-  userSummarySchemaRef  <- declareSchemaRef (Proxy :: Proxy UserSummary)-  userDetailedSchemaRef <- declareSchemaRef (Proxy :: Proxy UserDetailed)-  packagesSchemaRef     <- declareSchemaRef (Proxy :: Proxy [Package])++  -- responses+  userSummaryResponse   <- declareResponse (Proxy :: Proxy UserSummary)+  userDetailedResponse  <- declareResponse (Proxy :: Proxy UserDetailed)+  packagesResponse      <- declareResponse (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))))+    & paths .~+        [ ("/users", mempty & get ?~ (mempty+            & produces ?~ MimeList ["application/json"]+            & at 200 ?~ Inline userSummaryResponse))+        , ("/user/{username}", mempty & get ?~ (mempty+            & produces ?~ MimeList ["application/json"]+            & parameters .~ [ Inline $ mempty+                & name .~ "username"+                & required ?~ True+                & schema .~ ParamOther (mempty+                    & in_ .~ ParamPath+                    & paramSchema .~ usernameParamSchema) ]+            & at 200 ?~ Inline userDetailedResponse))+        , ("/packages", mempty & get ?~ (mempty+            & produces ?~ MimeList ["application/json"]+            & at 200 ?~ Inline packagesResponse))         ]  main :: IO ()

@@ -0,0 +1,8 @@+#if __GLASGOW_HASKELL__ >= 710+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}+#define OVERLAPPING_  {-# OVERLAPPING #-}+#else+{-# LANGUAGE OverlappingInstances #-}+#define OVERLAPPABLE_+#define OVERLAPPING_+#endif

@@ -18,10 +18,18 @@   -- ** Schema specification   -- $schema +  -- ** Manipulation+  -- $manipulation++  -- ** Validation+  -- $validation+   -- * Re-exports   module Data.Swagger.Lens,+  module Data.Swagger.Operation,   module Data.Swagger.ParamSchema,   module Data.Swagger.Schema,+  module Data.Swagger.Schema.Validation,    -- * Swagger specification   Swagger(..),@@ -33,8 +41,7 @@   Contact(..),   License(..), -  -- ** Paths-  Paths(..),+  -- ** PathItem   PathItem(..),    -- ** Operations@@ -45,6 +52,7 @@   -- ** Types and formats   SwaggerType(..),   Format,+  Definitions,   CollectionFormat(..),    -- ** Parameters@@ -60,6 +68,7 @@   -- ** Schemas   ParamSchema(..),   Schema(..),+  NamedSchema(..),   SwaggerItems(..),   Xml(..), @@ -96,8 +105,10 @@ ) where  import Data.Swagger.Lens+import Data.Swagger.Operation import Data.Swagger.ParamSchema import Data.Swagger.Schema+import Data.Swagger.Schema.Validation  import Data.Swagger.Internal @@ -158,33 +169,63 @@ -- $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:+-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses+-- 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")))))]+-- encode $ (mempty :: Swagger)+--   & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]+--   & paths .~+--     [ ("/user", mempty & get ?~ (mempty+--         & produces ?~ MimeList ["application/json"]+--         & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))+--         & at 404 ?~ "User info not found")) ] -- :}--- "{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"]}}}"+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}},\"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).+-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@+-- which produces @application/json@ output. It should respond with code @200@ and body specified+-- by schema @User@ which is defined in @'definitions'@ property of swagger specification.+-- Alternatively it may respond with code @404@ meaning that user info is not found. ----- 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'@:+-- For convenience, @swagger2@ uses /classy field lenses/. It means that+-- field accessor names can be overloaded for different types. One such+-- common field is @'description'@. Many components of a Swagger specification+-- can have descriptions, and you can use the same name for them: --+-- >>> encode $ (mempty :: Response) & description .~ "No content"+-- "{\"description\":\"No content\"}" -- >>> :{--- encode $ mempty---   & schemaTitle   ?~ "Email"---   & schemaType    .~ SwaggerString---   & schemaFormat  ?~ "email"+-- encode $ (mempty :: Schema)+--   & type_       .~ SwaggerBoolean+--   & description ?~ "To be or not to be" -- :}--- "{\"format\":\"email\",\"title\":\"Email\",\"type\":\"string\"}"+-- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}"+--+-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).+-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.+-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:+--+-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber+-- "{\"type\":\"number\"}"+--+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@+-- have direct access to it via @'at' code@. Example:+--+-- >>> :{+-- encode $ (mempty :: Operation)+--   & at 404 ?~ "Not found"+-- :}+-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"+--+-- You might've noticed that @'type_'@ has an extra underscore in its name+-- compared to, say, @'description'@ field accessor.+-- This is because @type@ is a keyword in Haskell.+-- A few other field accessors are modified in this way:+--+--    - @'in_'@, @'type_'@, @'default_'@ (as keywords);+--    - @'maximum_'@, @'minimum_'@, @'head_'@ (as conflicting with @Prelude@);+--    - @'enum_'@ (as conflicting with @Control.Lens@).  -- $schema --@@ -197,8 +238,8 @@ -- 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.+-- define a corresponding schema. To facilitate this use case+-- @swagger2@ 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,@@ -226,5 +267,17 @@ -- "{\"age\":28,\"name\":\"David\"}" -- >>> encode $ toSchema (Proxy :: Proxy Person) -- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}"++-- $manipulation+-- Sometimes you have to work with an imported or generated @'Swagger'@.+-- For instance, <servant-swagger http://hackage.haskell.org/package/servant-swagger> generates basic @'Swagger'@+-- for a type-level servant API. --+-- Lenses and prisms can be used to manipulate such specification to add additional information, tags, extra responses, etc.+-- To facilitate common needs, @'Data.Swagger.Operation'@ module provides useful helpers. +-- $validation+-- While @'ToParamSchema'@ and @'ToSchema'@ provide means to easily obtain schemas for Haskell types,+-- there is no static mechanism to ensure those instances correspond to the @'ToHttpApiData'@ or @'ToJSON'@ instances.+--+-- @'Data.Swagger.Schema.Validation'@ addresses @'ToJSON'@/@'ToSchema'@ validation.

@@ -4,6 +4,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Data.Swagger.Declare where +import Prelude ()+import Prelude.Compat+ import Control.Monad import Control.Monad.Trans import Data.Functor.Identity@@ -24,14 +27,14 @@ newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }   deriving (Functor) -instance (Monad m, Monoid d) => Applicative (DeclareT d m) where+instance (Applicative m, 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+instance (Applicative m, 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@@ -39,7 +42,7 @@     return (d' <> d'', y)  instance Monoid d => MonadTrans (DeclareT d) where-  lift m = DeclareT (\_ -> (,) mempty <$> m)+  lift m = DeclareT (\_ -> (,) mempty `liftM` m)  -- | -- Definitions of @declare@ and @look@ must satisfy the following laws:@@ -58,13 +61,13 @@ -- [/@look@ as left identity/] --   @'look' >> m == m@ --   for every @m@-class Monad m => MonadDeclare d m | m -> d where+class (Applicative m, 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+instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where   declare d = DeclareT (\_ -> return (d, ()))   look = DeclareT (\d -> return (mempty, d)) 

@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}@@ -10,8 +12,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-}+#include "overlapping-compat.h" module Data.Swagger.Internal where +import Prelude ()+import Prelude.Compat+ import           Control.Applicative import           Control.Monad import           Data.Aeson@@ -23,7 +29,8 @@ import qualified Data.Map                 as Map import           Data.Monoid import           Data.Scientific          (Scientific)-import           Data.String              (fromString)+import           Data.Set                 (Set)+import           Data.String              (IsString(..)) import           Data.Text                (Text) import qualified Data.Text                as Text import           GHC.Generics             (Generic)@@ -33,65 +40,70 @@  import Data.Swagger.Internal.Utils +-- | A list of definitions that can be used in references.+type Definitions = HashMap Text+ -- | This is the root document object for the API specification. data Swagger = Swagger   { -- | Provides metadata about the API.     -- The metadata can be used by the clients if needed.-    _info :: Info+    _swaggerInfo :: Info      -- | The host (name or ip) serving the API. It MAY include a port.     -- If the host is not included, the host serving the documentation is to be used (including the port).-  , _host :: Maybe Host+  , _swaggerHost :: Maybe Host      -- | The base path on which the API is served, which is relative to the host.     -- If it is not included, the API is served directly under the host.     -- The value MUST start with a leading slash (/).-  , _basePath :: Maybe FilePath+  , _swaggerBasePath :: Maybe FilePath      -- | The transfer protocol of the API.     -- If the schemes is not included, the default scheme to be used is the one used to access the Swagger definition itself.-  , _schemes :: Maybe [Scheme]+  , _swaggerSchemes :: Maybe [Scheme]      -- | A list of MIME types the APIs can consume.     -- This is global to all APIs but can be overridden on specific API calls.-  , _consumes :: MimeList+  , _swaggerConsumes :: MimeList      -- | A list of MIME types the APIs can produce.-    -- This is global to all APIs but can be overridden on specific API calls. -  , _produces :: MimeList+    -- This is global to all APIs but can be overridden on specific API calls.+  , _swaggerProduces :: MimeList      -- | The available paths and operations for the API.-  , _paths :: Paths+    -- Holds the relative paths to the individual endpoints.+    -- The path is appended to the @'basePath'@ in order to construct the full URL.+  , _swaggerPaths :: HashMap FilePath PathItem      -- | An object to hold data types produced and consumed by operations.-  , _definitions :: HashMap Text Schema+  , _swaggerDefinitions :: Definitions Schema      -- | An object to hold parameters that can be used across operations.     -- This property does not define global parameters for all operations.-  , _parameters :: HashMap Text Param+  , _swaggerParameters :: Definitions Param      -- | An object to hold responses that can be used across operations.     -- This property does not define global responses for all operations.-  , _responses :: HashMap Text Response+  , _swaggerResponses :: Definitions Response      -- | Security scheme definitions that can be used across the specification.-  , _securityDefinitions :: HashMap Text SecurityScheme+  , _swaggerSecurityDefinitions :: Definitions SecurityScheme      -- | A declaration of which security schemes are applied for the API as a whole.     -- The list of values describes alternative security schemes that can be used     -- (that is, there is a logical OR between the security requirements).     -- Individual operations can override this definition.-  , _security :: [SecurityRequirement]+  , _swaggerSecurity :: [SecurityRequirement]      -- | A list of tags used by the specification with additional metadata.     -- The order of the tags can be used to reflect on their order by the parsing tools.     -- Not all tags that are used by the Operation Object must be declared.     -- The tags that are not declared may be organized randomly or based on the tools' logic.     -- Each tag name in the list MUST be unique.-  , _tags :: [Tag]+  , _swaggerTags :: Set Tag      -- | Additional external documentation.-  , _externalDocs :: Maybe ExternalDocs+  , _swaggerExternalDocs :: Maybe ExternalDocs   } deriving (Eq, Show, Generic, Data, Typeable)  -- | The object provides metadata about the API.@@ -140,12 +152,18 @@   , _licenseUrl :: Maybe URL   } deriving (Eq, Show, Generic, Data, Typeable) +instance IsString License where+  fromString s = License (fromString s) Nothing+ -- | The host (name or ip) serving the API. It MAY include a port. data Host = Host   { _hostName :: HostName         -- ^ Host name.   , _hostPort :: Maybe PortNumber -- ^ Optional port.   } deriving (Eq, Show, Generic, Typeable) +instance IsString Host where+  fromString s = Host s Nothing+ hostConstr :: Constr hostConstr = mkConstr hostDataType "Host" [] Prefix @@ -167,13 +185,6 @@   | Wss   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, Data, Typeable)- -- | Describes the operations available on a single path. -- A @'PathItem'@ may be empty, due to ACL constraints. -- The path itself is still exposed to the documentation viewer@@ -211,7 +222,7 @@ data Operation = Operation   { -- | A list of tags for API documentation control.     -- Tags can be used for logical grouping of operations by resources or any other qualifier.-    _operationTags :: [TagName]+    _operationTags :: Set TagName      -- | A short summary of what the operation does.     -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.@@ -336,10 +347,11 @@   SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t   SwaggerItemsObject    :: Referenced Schema   -> SwaggerItems Schema   SwaggerItemsArray     :: [Referenced Schema] -> SwaggerItems Schema+  deriving (Typeable)  deriving instance Eq (SwaggerItems t) deriving instance Show (SwaggerItems t)-deriving instance Typeable (SwaggerItems t)+--deriving instance Typeable (SwaggerItems t)  swaggerItemsPrimitiveConstr :: Constr swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix@@ -347,7 +359,7 @@ swaggerItemsDataType :: DataType swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr] -instance {-# OVERLAPPABLE #-} Data t => Data (SwaggerItems t) where+instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where   gunfold k z c = case constrIndex c of     1 -> k (k (z SwaggerItemsPrimitive))     _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."@@ -365,10 +377,10 @@   SwaggerFile     :: SwaggerType ParamOtherSchema   SwaggerNull     :: SwaggerType Schema   SwaggerObject   :: SwaggerType Schema+  deriving (Typeable)  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@@ -389,17 +401,17 @@ swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])   ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject] -instance {-# OVERLAPPABLE #-} Typeable t => Data (SwaggerType t) where+instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where   gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes   toConstr = swaggerTypeConstr   dataTypeOf = swaggerTypeDataType -instance {-# OVERLAPPING #-} Data (SwaggerType ParamOtherSchema) where+instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where   gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes   toConstr = swaggerTypeConstr   dataTypeOf = swaggerTypeDataType -instance {-# OVERLAPPING #-} Data (SwaggerType Schema) where+instance OVERLAPPABLE_ Data (SwaggerType Schema) where   gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes   toConstr = swaggerTypeConstr   dataTypeOf = swaggerTypeDataType@@ -440,10 +452,10 @@   -- instead of multiple values for a single instance @foo=bar&foo=baz@.   -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.   CollectionMulti :: CollectionFormat ParamOtherSchema+  deriving (Typeable)  deriving instance Eq (CollectionFormat t) deriving instance Show (CollectionFormat t)-deriving instance Typeable (CollectionFormat t)  collectionFormatConstr :: CollectionFormat t -> Constr collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix@@ -455,12 +467,12 @@ collectionCommonFormats :: [CollectionFormat t] collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ] -instance {-# OVERLAPPABLE #-} Data t => Data (CollectionFormat t) where+instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where   gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats   toConstr = collectionFormatConstr   dataTypeOf _ = collectionFormatDataType -deriving instance {-# OVERLAPPING #-} Data (CollectionFormat ParamOtherSchema)+deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)  type ParamName = Text @@ -485,6 +497,16 @@   , _schemaParamSchema :: ParamSchema Schema   } deriving (Eq, Show, Generic, Data, Typeable) +-- | A @'Schema'@ with an optional name.+-- This name can be used in references.+data NamedSchema = NamedSchema+  { _namedSchemaName :: Maybe Text+  , _namedSchemaSchema :: Schema+  } deriving (Eq, Show, Generic, Data, Typeable)++-- | Regex pattern for @string@ type.+type Pattern = Text+ 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@@@ -502,7 +524,7 @@   , _paramSchemaExclusiveMinimum :: Maybe Bool   , _paramSchemaMaxLength :: Maybe Integer   , _paramSchemaMinLength :: Maybe Integer-  , _paramSchemaPattern :: Maybe Text+  , _paramSchemaPattern :: Maybe Pattern   , _paramSchemaMaxItems :: Maybe Integer   , _paramSchemaMinItems :: Maybe Integer   , _paramSchemaUniqueItems :: Maybe Bool@@ -577,6 +599,9 @@   , _responseExamples :: Maybe Example   } deriving (Eq, Show, Generic, Data, Typeable) +instance IsString Response where+  fromString s = Response (fromString s) Nothing mempty Nothing+ type HeaderName = Text  data Header = Header@@ -673,8 +698,11 @@      -- | Additional external documentation for this tag.   , _tagExternalDocs :: Maybe ExternalDocs-  } deriving (Eq, Show, Generic, Data, Typeable)+  } deriving (Eq, Ord, Show, Generic, Data, Typeable) +instance IsString Tag where+  fromString s = Tag (fromString s) Nothing Nothing+ -- | Allows referencing an external resource for extended documentation. data ExternalDocs = ExternalDocs   { -- | A short description of the target documentation.@@ -683,7 +711,7 @@      -- | The URL for the target documentation.   , _externalDocsUrl :: URL-  } deriving (Eq, Show, Generic, Data, Typeable)+  } deriving (Eq, Ord, 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.@@ -693,10 +721,13 @@ data Referenced a   = Ref Reference   | Inline a-  deriving (Eq, Show, Data, Typeable)+  deriving (Eq, Show, Functor, Data, Typeable) -newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON, Data, Typeable)+instance IsString a => IsString (Referenced a) where+  fromString = Inline . fromString +newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)+ -- ======================================================================= -- Monoid instances -- =======================================================================@@ -709,7 +740,7 @@   mempty = genericMempty   mappend = genericMappend -instance Monoid Paths where+instance Monoid Contact where   mempty = genericMempty   mappend = genericMappend @@ -762,7 +793,6 @@ -- =======================================================================  instance SwaggerMonoid Info-instance SwaggerMonoid Paths instance SwaggerMonoid PathItem instance SwaggerMonoid Schema instance SwaggerMonoid (ParamSchema t)@@ -784,7 +814,7 @@   swaggerMempty = ParamQuery   swaggerMappend _ y = y -instance SwaggerMonoid (HashMap FilePath PathItem) where+instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where   swaggerMempty = HashMap.empty   swaggerMappend = HashMap.unionWith mappend @@ -897,7 +927,7 @@     <+> object [ "type" .= ("oauth2" :: Text) ]  instance ToJSON Swagger where-  toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "")+  toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")     where       addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)       addVersion _ = error "impossible"@@ -927,9 +957,6 @@       Nothing -> host       Just port -> host ++ ":" ++ show port -instance ToJSON Paths where-  toJSON (Paths m) = toJSON m- instance ToJSON MimeList where   toJSON (MimeList xs) = toJSON (map show xs) @@ -1027,15 +1054,15 @@   parseJSON js@(Object o) = do     (version :: Text) <- o .: "swagger"     when (version /= "2.0") empty-    (genericParseJSON (jsonPrefix "")+    (genericParseJSON (jsonPrefix "swagger")       `withDefaults` [ "consumes" .= (mempty :: MimeList)                      , "produces" .= (mempty :: MimeList)                      , "security" .= ([] :: [SecurityRequirement])                      , "tags" .= ([] :: [Tag])-                     , "definitions" .= (mempty :: HashMap Text Schema)-                     , "parameters" .= (mempty :: HashMap Text Param)-                     , "responses" .= (mempty :: HashMap Text Response)-                     , "securityDefinitions" .= (mempty :: HashMap Text SecurityScheme)+                     , "definitions" .= (mempty :: Definitions Schema)+                     , "parameters" .= (mempty :: Definitions Param)+                     , "responses" .= (mempty :: Definitions Response)+                     , "securityDefinitions" .= (mempty :: Definitions SecurityScheme)                      ] ) js   parseJSON _ = empty @@ -1050,12 +1077,12 @@ instance FromJSON Header where   parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header") -instance {-# OVERLAPPABLE #-} (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where-  parseJSON (Object o) = SwaggerItemsPrimitive+instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where+  parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive     <$> o .:? "collectionFormat"     <*> (o .: "items" >>= parseJSON) -instance {-# OVERLAPPING #-} FromJSON (SwaggerItems Schema) where+instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where   parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js   parseJSON js@(Array _)  = SwaggerItemsArray  <$> parseJSON js   parseJSON _ = empty@@ -1070,9 +1097,6 @@       [host, portStr] = map Text.unpack [hostText, portText]   parseJSON _ = empty -instance FromJSON Paths where-  parseJSON js = Paths <$> parseJSON js- instance FromJSON MimeList where   parseJSON js = (MimeList . map fromString) <$> parseJSON js @@ -1109,7 +1133,9 @@  instance FromJSON Operation where   parseJSON = genericParseJSON (jsonPrefix "operation")-    `withDefaults` [ "security"   .= ([] :: [SecurityRequirement]) ]+    `withDefaults` [ "security"   .= ([] :: [SecurityRequirement])+                   , "tags"       .= ([] :: [Tag])+                   , "parameters" .= ([] :: [Referenced Param]) ]  instance FromJSON PathItem where   parseJSON = genericParseJSON (jsonPrefix "pathItem")@@ -1130,6 +1156,7 @@       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)+referencedParseJSON _ _ = fail "referenceParseJSON: not an object"  instance FromJSON (Referenced Schema)   where parseJSON = referencedParseJSON "#/definitions/" instance FromJSON (Referenced Param)    where parseJSON = referencedParseJSON "#/parameters/"@@ -1144,10 +1171,10 @@ instance FromJSON (SwaggerType ParamOtherSchema) where   parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile] -instance {-# OVERLAPPABLE #-} FromJSON (SwaggerType t) where+instance OVERLAPPABLE_ FromJSON (SwaggerType t) where   parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray] -instance {-# OVERLAPPABLE #-} FromJSON (CollectionFormat t) where+instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where   parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]  instance FromJSON (CollectionFormat ParamOtherSchema) where

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -8,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-}+#include "overlapping-compat.h" module Data.Swagger.Internal.ParamSchema where  import Control.Lens@@ -23,12 +25,35 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time+import qualified Data.Vector as V+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU import Data.Word  import Data.Swagger.Internal import Data.Swagger.Lens import Data.Swagger.SchemaOptions +-- | Default schema for binary data (any sequence of octets).+binaryParamSchema :: ParamSchema t+binaryParamSchema = mempty+  & type_ .~ SwaggerString+  & format ?~ "binary"++-- | Default schema for binary data (base64 encoded).+byteParamSchema :: ParamSchema t+byteParamSchema = mempty+  & type_ .~ SwaggerString+  & format ?~ "byte"++-- | Default schema for password string.+-- @"password"@ format is used to hint UIs the input needs to be obscured.+passwordParamSchema :: ParamSchema t+passwordParamSchema = mempty+  & type_ .~ SwaggerString+  & format ?~ "password"+ -- | Convert a type into a plain @'ParamSchema'@. -- -- An example type and instance:@@ -42,8 +67,8 @@ -- -- instance ToParamSchema Direction where --   toParamSchema = mempty---      & schemaType .~ SwaggerString---      & schemaEnum .~ [ \"Up\", \"Down\" ]+--      & type_ .~ SwaggerString+--      & enum_ .~ [ \"Up\", \"Down\" ] -- @ -- -- Instead of manually writing your @'ToParamSchema'@ instance you can@@ -73,24 +98,24 @@   default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t   toParamSchema = genericToParamSchema defaultSchemaOptions -instance {-# OVERLAPPING #-} ToParamSchema String where-  toParamSchema _ = mempty & schemaType .~ SwaggerString+instance OVERLAPPING_ ToParamSchema String where+  toParamSchema _ = mempty & type_ .~ SwaggerString  instance ToParamSchema Bool where-  toParamSchema _ = mempty & schemaType .~ SwaggerBoolean+  toParamSchema _ = mempty & type_ .~ SwaggerBoolean  instance ToParamSchema Integer where-  toParamSchema _ = mempty & schemaType .~ SwaggerInteger+  toParamSchema _ = mempty & type_ .~ SwaggerInteger  instance ToParamSchema Int    where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Int8   where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Int16  where toParamSchema = toParamSchemaBoundedIntegral  instance ToParamSchema Int32 where-  toParamSchema proxy = toParamSchemaBoundedIntegral proxy & schemaFormat ?~ "int32"+  toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int32"  instance ToParamSchema Int64 where-  toParamSchema proxy = toParamSchemaBoundedIntegral proxy & schemaFormat ?~ "int64"+  toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64"  instance ToParamSchema Word   where toParamSchema = toParamSchemaBoundedIntegral instance ToParamSchema Word8  where toParamSchema = toParamSchemaBoundedIntegral@@ -104,52 +129,52 @@ -- "{\"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))+  & type_ .~ SwaggerInteger+  & minimum_ ?~ fromInteger (toInteger (minBound :: a))+  & maximum_ ?~ fromInteger (toInteger (maxBound :: a))  instance ToParamSchema Char where   toParamSchema _ = mempty-    & schemaType .~ SwaggerString-    & schemaMaxLength ?~ 1-    & schemaMinLength ?~ 1+    & type_ .~ SwaggerString+    & maxLength ?~ 1+    & minLength ?~ 1  instance ToParamSchema Scientific where-  toParamSchema _ = mempty & schemaType .~ SwaggerNumber+  toParamSchema _ = mempty & type_ .~ SwaggerNumber  instance ToParamSchema Double where   toParamSchema _ = mempty-    & schemaType   .~ SwaggerNumber-    & schemaFormat ?~ "double"+    & type_  .~ SwaggerNumber+    & format ?~ "double"  instance ToParamSchema Float where   toParamSchema _ = mempty-    & schemaType   .~ SwaggerNumber-    & schemaFormat ?~ "float"+    & type_  .~ SwaggerNumber+    & format ?~ "float"  timeParamSchema :: String -> ParamSchema t-timeParamSchema format = mempty-  & schemaType      .~ SwaggerString-  & schemaFormat    ?~ T.pack format+timeParamSchema fmt = mempty+  & type_  .~ SwaggerString+  & format ?~ T.pack fmt  -- | Format @"date"@ corresponds to @yyyy-mm-dd@ format. instance ToParamSchema Day where   toParamSchema _ = timeParamSchema "date"  -- |--- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. schemaFormat+-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format -- Just "yyyy-mm-ddThh:MM:ss" instance ToParamSchema LocalTime where   toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss"  -- |--- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat+-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format -- Just "yyyy-mm-ddThh:MM:ss+hhMM" instance ToParamSchema ZonedTime where   toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"  -- |--- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. schemaFormat+-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format -- Just "yyyy-mm-ddThh:MM:ssZ" instance ToParamSchema UTCTime where   toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"@@ -173,12 +198,17 @@  instance ToParamSchema a => ToParamSchema [a] where   toParamSchema _ = mempty-    & schemaType  .~ SwaggerArray-    & schemaItems ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))+    & type_ .~ SwaggerArray+    & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a)) +instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])+instance ToParamSchema a => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])+instance ToParamSchema a => ToParamSchema (VS.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])+instance ToParamSchema a => ToParamSchema (VU.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])+ instance ToParamSchema a => ToParamSchema (Set a) where   toParamSchema _ = toParamSchema (Proxy :: Proxy [a])-    & schemaUniqueItems ?~ True+    & uniqueItems ?~ True  instance ToParamSchema a => ToParamSchema (HashSet a) where   toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a))@@ -188,8 +218,8 @@ -- "{\"type\":\"string\",\"enum\":[\"_\"]}" instance ToParamSchema () where   toParamSchema _ = mempty-    & schemaType .~ SwaggerString-    & schemaEnum ?~ ["_"]+    & type_ .~ SwaggerString+    & enum_ ?~ ["_"]  -- | A configurable generic @'ParamSchema'@ creator. --@@ -226,8 +256,8 @@  instance Constructor c => GEnumParamSchema (C1 c U1) where   genumParamSchema opts _ s = s-    & schemaType .~ SwaggerString-    & schemaEnum %~ addEnumValue tag+    & type_ .~ SwaggerString+    & enum_ %~ addEnumValue tag     where       tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) 

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -11,61 +12,68 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-}+#include "overlapping-compat.h" module Data.Swagger.Internal.Schema where +import Prelude ()+import Prelude.Compat+ import Control.Lens import Data.Data.Lens (template) +import Control.Applicative import Control.Monad import Control.Monad.Writer import Data.Aeson import Data.Char import Data.Data (Data) import Data.Foldable (traverse_)+import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap-import "unordered-containers" Data.HashSet (HashSet)+import           "unordered-containers" Data.HashSet (HashSet)+import qualified "unordered-containers" Data.HashSet as 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 qualified Data.Vector as V+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU 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.Lens hiding (name, schema) 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+#ifdef __DOCTEST__+import Data.Swagger.Lens (name, schema)+#endif  unnamed :: Schema -> NamedSchema-unnamed schema = (Nothing, schema)+unnamed schema = NamedSchema Nothing schema  named :: T.Text -> Schema -> NamedSchema-named name schema = (Just name, schema)+named name schema = NamedSchema (Just name) schema -plain :: Schema -> Declare Definitions NamedSchema+plain :: Schema -> Declare (Definitions Schema) NamedSchema plain = pure . unnamed  unname :: NamedSchema -> NamedSchema-unname (_, schema) = (Nothing, schema)+unname (NamedSchema _ schema) = unnamed schema  rename :: Maybe T.Text -> NamedSchema -> NamedSchema-rename name (_, schema) = (name, schema)+rename name (NamedSchema _ schema) = NamedSchema name schema  -- | Convert a type into @'Schema'@. --@@ -83,12 +91,12 @@ --   declareNamedSchema = pure (Just \"Coord\", schema) --    where --      schema = mempty---        & schemaType .~ SwaggerObject---        & schemaProperties .~+--        & type_ .~ SwaggerObject+--        & properties .~ --            [ (\"x\", toSchemaRef (Proxy :: Proxy Double)) --            , (\"y\", toSchemaRef (Proxy :: Proxy Double)) --            ]---        & schemaRequired .~ [ \"x\", \"y\" ]+--        & required .~ [ \"x\", \"y\" ] -- @ -- -- Instead of manually writing your @'ToSchema'@ instance you can@@ -114,21 +122,25 @@   -- 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 :: proxy a -> Declare (Definitions Schema) NamedSchema+  default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) 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+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema+declareSchema = fmap _namedSchemaSchema . declareNamedSchema  -- | Convert a type into an optionally named schema. ----- >>> encode <$> toNamedSchema (Proxy :: Proxy String)--- (Nothing,"{\"type\":\"string\"}")+-- >>> toNamedSchema (Proxy :: Proxy String) ^. name+-- Nothing+-- >>> encode (toNamedSchema (Proxy :: Proxy String) ^. schema)+-- "{\"type\":\"string\"}" ----- >>> encode <$> toNamedSchema (Proxy :: Proxy Day)--- (Just "Day","{\"format\":\"date\",\"type\":\"string\"}")+-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name+-- Just "Day"+-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)+-- "{\"format\":\"date\",\"type\":\"string\"}" toNamedSchema :: ToSchema a => proxy a -> NamedSchema toNamedSchema = undeclare . declareNamedSchema @@ -140,7 +152,7 @@ -- >>> schemaName (Proxy :: Proxy UTCTime) -- Just "UTCTime" schemaName :: ToSchema a => proxy a -> Maybe T.Text-schemaName = fst . toNamedSchema+schemaName = _namedSchemaName . toNamedSchema  -- | Convert a type into a schema. --@@ -150,7 +162,7 @@ -- >>> encode $ toSchema (Proxy :: Proxy [Day]) -- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}" toSchema :: ToSchema a => proxy a -> Schema-toSchema = snd . toNamedSchema+toSchema = _namedSchemaSchema . toNamedSchema  -- | Convert a type into a referenced schema if possible. -- Only named schemas can be referenced, nameless schemas are inlined.@@ -170,10 +182,10 @@ -- 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 :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema) declareSchemaRef proxy = do   case toNamedSchema proxy of-    (Just name, schema) -> do+    NamedSchema (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@@ -196,7 +208,7 @@ -- -- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas -- when inlining recursive schemas.-inlineSchemasWhen :: Data s => (T.Text -> Bool) -> Definitions -> s -> s+inlineSchemasWhen :: Data s => (T.Text -> Bool) -> (Definitions Schema) -> s -> s inlineSchemasWhen p defs = template %~ deref   where     deref r@(Ref (Reference name))@@ -214,7 +226,7 @@ -- -- __WARNING:__ @'inlineSchemas'@ will produce infinite schemas -- when inlining recursive schemas.-inlineSchemas :: Data s => [T.Text] -> Definitions -> s -> s+inlineSchemas :: Data s => [T.Text] -> (Definitions Schema) -> s -> s inlineSchemas names = inlineSchemasWhen (`elem` names)  -- | Inline all schema references for which the definition@@ -222,7 +234,7 @@ -- -- __WARNING:__ @'inlineAllSchemas'@ will produce infinite schemas -- when inlining recursive schemas.-inlineAllSchemas :: Data s => Definitions -> s -> s+inlineAllSchemas :: Data s => (Definitions Schema) -> s -> s inlineAllSchemas = inlineSchemasWhen (const True)  -- | Convert a type into a schema without references.@@ -239,7 +251,7 @@  -- | Inline all /non-recursive/ schemas for which the definition -- can be found in @'Definitions'@.-inlineNonRecursiveSchemas :: Data s => Definitions -> s -> s+inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs   where     nonRecursive name =@@ -258,17 +270,135 @@           traverse_ usedNames (HashMap.lookup name defs)       Inline subschema -> usedNames subschema +-- | Default schema for binary data (any sequence of octets).+binarySchema :: Schema+binarySchema = mempty+  & type_ .~ SwaggerString+  & format ?~ "binary"++-- | Default schema for binary data (base64 encoded).+byteSchema :: Schema+byteSchema = mempty+  & type_ .~ SwaggerString+  & format ?~ "byte"++-- | Default schema for password string.+-- @"password"@ format is used to hint UIs the input needs to be obscured.+passwordSchema :: Schema+passwordSchema = mempty+  & type_ .~ SwaggerString+  & format ?~ "password"++-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.+-- Produced schema can be used for further refinement.+--+-- >>> encode $ sketchSchema "hello"+-- "{\"example\":\"hello\",\"type\":\"string\"}"+--+-- >>> encode $ sketchSchema (1, 2, 3)+-- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}"+--+-- >>> encode $ sketchSchema ("Jack", 25)+-- "{\"example\":[\"Jack\",25],\"items\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"type\":\"array\"}"+--+-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)+-- >>> instance ToJSON Person+-- >>> encode $ sketchSchema (Person "Jack" 25)+-- "{\"example\":{\"age\":25,\"name\":\"Jack\"},\"required\":[\"age\",\"name\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}}}"+sketchSchema :: ToJSON a => a -> Schema+sketchSchema = sketch . toJSON+  where+    sketch Null = go Null+    sketch js@(Bool _) = go js+    sketch js = go js & example ?~ js++    go Null          = mempty & type_ .~ SwaggerNull+    go js@(Bool _)   = mempty & type_ .~ SwaggerBoolean+    go js@(String s) = mempty & type_   .~ SwaggerString+    go js@(Number n) = mempty & type_ .~ SwaggerNumber+    go js@(Array xs) = mempty+      & type_   .~ SwaggerArray+      & items ?~ case ischema of+          Just s -> SwaggerItemsObject (Inline s)+          _      -> SwaggerItemsArray (map Inline ys)+      where+        ys = map go (V.toList xs)+        allSame = and ((zipWith (==)) ys (tail ys))++        ischema = case ys of+          (z:zs) | allSame -> Just z+          _ -> Nothing+    go js@(Object o) = mempty+      & type_         .~ SwaggerObject+      & required      .~ HashMap.keys o+      & properties    .~ fmap (Inline . go) o++-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.+-- Produced schema uses as much constraints as possible.+--+-- >>> encode $ sketchStrictSchema "hello"+-- "{\"maxLength\":5,\"pattern\":\"hello\",\"minLength\":5,\"type\":\"string\",\"enum\":[\"hello\"]}"+--+-- >>> encode $ sketchStrictSchema (1, 2, 3)+-- "{\"minItems\":3,\"uniqueItems\":true,\"items\":[{\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\",\"enum\":[1]},{\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\",\"enum\":[2]},{\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\",\"enum\":[3]}],\"maxItems\":3,\"type\":\"array\",\"enum\":[[1,2,3]]}"+--+-- >>> encode $ sketchStrictSchema ("Jack", 25)+-- "{\"minItems\":2,\"uniqueItems\":true,\"items\":[{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]},{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]}],\"maxItems\":2,\"type\":\"array\",\"enum\":[[\"Jack\",25]]}"+--+-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)+-- >>> instance ToJSON Person+-- >>> encode $ sketchStrictSchema (Person "Jack" 25)+-- "{\"minProperties\":2,\"required\":[\"age\",\"name\"],\"maxProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}}}"+sketchStrictSchema :: ToJSON a => a -> Schema+sketchStrictSchema = go . toJSON+  where+    go Null       = mempty & type_ .~ SwaggerNull+    go js@(Bool _) = mempty+      & type_ .~ SwaggerBoolean+      & enum_ ?~ [js]+    go js@(String s) = mempty+      & type_ .~ SwaggerString+      & maxLength ?~ fromIntegral (T.length s)+      & minLength ?~ fromIntegral (T.length s)+      & pattern   ?~ s+      & enum_     ?~ [js]+    go js@(Number n) = mempty+      & type_       .~ SwaggerNumber+      & maximum_    ?~ n+      & minimum_    ?~ n+      & multipleOf  ?~ n+      & enum_       ?~ [js]+    go js@(Array xs) = mempty+      & type_       .~ SwaggerArray+      & maxItems    ?~ fromIntegral sz+      & minItems    ?~ fromIntegral sz+      & items       ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))+      & uniqueItems ?~ allUnique+      & enum_       ?~ [js]+      where+        sz = length xs+        allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))+    go js@(Object o) = mempty+      & type_         .~ SwaggerObject+      & required      .~ names+      & properties    .~ fmap (Inline . go) o+      & maxProperties ?~ fromIntegral (length names)+      & minProperties ?~ fromIntegral (length names)+      & enum_         ?~ [js]+      where+        names = HashMap.keys o+ class GToSchema (f :: * -> *) where-  gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare Definitions NamedSchema+  gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema -instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where+instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where   declareNamedSchema _ = do     ref <- declareSchemaRef (Proxy :: Proxy a)     return $ unnamed $ mempty-      & schemaType  .~ SwaggerArray-      & schemaItems ?~ SwaggerItemsObject ref+      & type_ .~ SwaggerArray+      & items ?~ SwaggerItemsObject ref -instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema+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@@ -293,7 +423,7 @@ instance (ToSchema a, ToSchema b) => ToSchema (Either a b)  instance ToSchema () where-  declareNamedSchema _ = pure (Nothing, nullarySchema)+  declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)  instance (ToSchema a, ToSchema b) => ToSchema (a, b) instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)@@ -303,16 +433,16 @@ 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+timeSchema fmt = mempty+  & type_ .~ SwaggerString+  & format ?~ fmt  -- | Format @"date"@ corresponds to @yyyy-mm-dd@ format. instance ToSchema Day where   declareNamedSchema _ = pure $ named "Day" (timeSchema "date")  -- |--- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat+-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format -- Just "yyyy-mm-ddThh:MM:ss" instance ToSchema LocalTime where   declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")@@ -325,7 +455,7 @@   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)  -- |--- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat+-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format -- Just "yyyy-mm-ddThh:MM:ssZ" instance ToSchema UTCTime where   declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")@@ -343,8 +473,8 @@   declareNamedSchema _ = do     schema <- declareSchema (Proxy :: Proxy a)     return $ unnamed $ mempty-      & schemaType  .~ SwaggerObject-      & schemaAdditionalProperties ?~ schema+      & type_ .~ SwaggerObject+      & additionalProperties ?~ 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))@@ -353,11 +483,16 @@ 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 (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])+instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])+instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])+instance ToSchema a => ToSchema (VP.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])+ instance ToSchema a => ToSchema (Set a) where   declareNamedSchema _ = do     schema <- declareSchema (Proxy :: Proxy [a])     return $ unnamed $ schema-      & schemaUniqueItems ?~ True+      & uniqueItems ?~ True  instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a)) @@ -376,9 +511,9 @@ -- "{\"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))+  & type_ .~ SwaggerInteger+  & minimum_ ?~ fromInteger (toInteger (minBound :: a))+  & maximum_ ?~ fromInteger (toInteger (maxBound :: a))  -- | Default generic named schema for @'Bounded'@, @'Integral'@ types. genericToNamedSchemaBoundedIntegral :: forall a d f proxy.@@ -386,17 +521,17 @@   , Generic a, Rep a ~ D1 d f, Datatype d)   => SchemaOptions -> proxy a -> NamedSchema genericToNamedSchemaBoundedIntegral opts proxy-  = (gdatatypeSchemaName opts (Proxy :: Proxy d), toSchemaBoundedIntegral proxy)+  = NamedSchema (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+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy  -- | A configurable generic @'NamedSchema'@ creator. -- This function applied to @'defaultSchemaOptions'@ -- is used as the default for @'declareNamedSchema'@ -- when the type is an instance of @'Generic'@.-genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare Definitions NamedSchema+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty  gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text@@ -410,27 +545,26 @@ 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)+paramSchemaToNamedSchema opts proxy = NamedSchema (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)+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)  nullarySchema :: Schema nullarySchema = mempty-  & schemaType .~ SwaggerArray-  & schemaEnum ?~ [ toJSON () ]-  & schemaItems ?~ SwaggerItemsArray []+  & type_ .~ SwaggerArray+  & items ?~ SwaggerItemsArray []  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+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema+gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty  instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where   gdeclareNamedSchema opts _ schema = do-    (_, gschema) <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema+    NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema     gdeclareNamedSchema opts (Proxy :: Proxy f) gschema  instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where@@ -438,10 +572,10 @@     where       name = gdatatypeSchemaName opts (Proxy :: Proxy d) -instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where+instance OVERLAPPABLE_ GToSchema f => GToSchema (C1 c f) where   gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f) -instance {-# OVERLAPPING #-} Constructor c => GToSchema (C1 c U1) where+instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where   gdeclareNamedSchema = gdeclareNamedSumSchema  -- | Single field constructor.@@ -449,20 +583,20 @@   gdeclareNamedSchema opts _ s     | unwrapUnaryRecords opts = fieldSchema     | otherwise =-        case schema ^. schemaItems of+        case schema ^. items of           Just (SwaggerItemsArray [_]) -> fieldSchema           _ -> do             declare defs             return (unnamed schema)     where-      (defs, (_, schema)) = runDeclare recordSchema mempty+      (defs, NamedSchema _ schema) = runDeclare recordSchema mempty       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 :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema) gdeclareSchemaRef opts proxy = do   case gtoNamedSchema opts proxy of-    (Just name, schema) -> do+    NamedSchema (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@@ -484,41 +618,41 @@ 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+  SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema withFieldSchema opts _ isRequiredField schema = do   ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)   return $     if T.null fname       then schema-        & schemaType .~ SwaggerArray-        & schemaItems %~ appendItem ref+        & type_ .~ SwaggerArray+        & items %~ appendItem ref       else schema-        & schemaType .~ SwaggerObject-        & schemaProperties . at fname ?~ ref+        & type_ .~ SwaggerObject+        & properties . at fname ?~ ref         & if isRequiredField-            then schemaRequired %~ (fname :)+            then required %~ (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+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+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+instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where   gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c) -instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where+instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where   gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)  instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where   gdeclareNamedSchema = gdeclareNamedSumSchema -gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare Definitions NamedSchema+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema gdeclareNamedSumSchema opts proxy s   | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)   | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema@@ -527,30 +661,34 @@     (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)      toStringTag schema = mempty-      & schemaType .~ SwaggerString-      & schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex)+      & type_ .~ SwaggerString+      & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)  type AllNullary = All  class GSumToSchema f where-  gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare Definitions) Schema+  gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) 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+gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>+  Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema+gsumConToSchemaWith ref opts _ schema = schema+  & type_ .~ SwaggerObject+  & properties . at tag ?~ ref+  & maxProperties ?~ 1+  & minProperties ?~ 1   where     tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) -instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>+  SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema+gsumConToSchema opts proxy schema = do+  ref <- gdeclareSchemaRef opts proxy+  return $ gsumConToSchemaWith ref opts proxy schema++instance OVERLAPPABLE_ (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where   gsumToSchema opts proxy schema = do     tell (All False)     lift $ gsumConToSchema opts proxy schema@@ -561,7 +699,7 @@     lift $ gsumConToSchema opts proxy schema  instance Constructor c => GSumToSchema (C1 c U1) where-  gsumToSchema opts proxy = lift . gsumConToSchema opts proxy+  gsumToSchema opts proxy = pure . gsumConToSchemaWith (Inline nullarySchema) opts proxy  data Proxy2 a b = Proxy2 

@@ -0,0 +1,324 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module:      Data.Swagger.Internal.Schema.Validation+-- Copyright:   (c) 2015 GetShopTV+-- License:     BSD3+-- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability:   experimental+--+-- Validate JSON values with Swagger Schema.+module Data.Swagger.Internal.Schema.Validation where++import Control.Applicative+import Control.Lens+import Control.Lens.TH+import Control.Monad (when)++import Data.Aeson hiding (Result)+import Data.Foldable (traverse_, for_, sequenceA_)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified "unordered-containers" Data.HashSet as HashSet+import Data.Monoid+import Data.Proxy+import Data.Scientific (Scientific, isInteger)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Vector (Vector)+import qualified Data.Vector as Vector++import Data.Swagger.Declare+import Data.Swagger.Internal+import Data.Swagger.Internal.Schema+import Data.Swagger.Lens++-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.+-- This can be used with QuickCheck to ensure those instances are coherent:+--+-- prop> validateToJSON (x :: Int) == []+--+-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.+-- See @'validateToJSONWithPatternChecker'@.+validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]+validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)++-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.+-- This can be used with QuickCheck to ensure those instances are coherent.+--+-- For validation without patterns see @'validateToJSON'@.+validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>+  (Pattern -> Text -> Bool) -> a -> [ValidationError]+validateToJSONWithPatternChecker checker x = case runValidation (validateWithSchema js) cfg schema of+    Failed xs -> xs+    Passed _  -> mempty+  where+    (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty+    js = toJSON x+    cfg = defaultConfig+            { configPatternChecker = checker+            , configDefinitions = defs }++-- | Validation error message.+type ValidationError = String++-- | Validation result type.+data Result a+  = Failed [ValidationError]  -- ^ Validation failed with a list of error messages.+  | Passed a                  -- ^ Validation passed.+  deriving (Eq, Show, Functor)++instance Applicative Result where+  pure = Passed+  Passed f <*> Passed x = Passed (f x)+  Failed xs <*> Failed ys = Failed (xs <> ys)+  Failed xs <*> _ = Failed xs+  _ <*> Failed ys = Failed ys++instance Alternative Result where+  empty = Failed mempty+  Passed x <|> _ = Passed x+  _        <|> y = y++instance Monad Result where+  return = pure+  Passed x >>=  f = f x+  Failed xs >>= f = Failed xs++-- | Validation configuration.+data Config = Config+  { -- | Pattern checker for @'_paramSchemaPattern'@ validation.+    configPatternChecker :: Pattern -> Text -> Bool+    -- | Schema definitions in scope to resolve references.+  , configDefinitions    :: Definitions Schema+  }++-- | Default @'Config'@:+--+-- @+-- defaultConfig = 'Config'+--   { 'configPatternChecker' = \\_pattern _str -> True+--   , 'configDefinitions'    = mempty+--   }+-- @+defaultConfig :: Config+defaultConfig = Config+  { configPatternChecker = \_pattern _str -> True+  , configDefinitions    = mempty+  }++-- | Value validation.+newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }+  deriving (Functor)++instance Applicative (Validation schema) where+  pure x = Validation (\_ _ -> pure x)+  Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)++instance Alternative (Validation schema) where+  empty = Validation (\_ _ -> empty)+  Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)++instance Profunctor Validation where+  dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))++instance Choice Validation where+  left'  (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))+  right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))++instance Monad (Validation s) where+  return = pure+  Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)+  (>>) = (*>)++withConfig :: (Config -> Validation s a) -> Validation s a+withConfig f = Validation (\c -> runValidation (f c) c)++withSchema :: (s -> Validation s a) -> Validation s a+withSchema f = Validation (\c s -> runValidation (f s) c s)++-- | Issue an error message.+invalid :: String -> Validation schema a+invalid msg = Validation (\_ _ -> Failed [msg])++-- | Validation passed.+valid :: Validation schema ()+valid = pure ()++-- | Validate schema's property given a lens into that property+-- and property checker.+check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()+check l g = withSchema $ \schema ->+  case schema ^. l of+    Nothing -> valid+    Just x  -> g x++-- | Validate same value with different schema.+sub :: t -> Validation t a -> Validation s a+sub = lmap . const++-- | Validate same value with a part of the original schema.+sub_ :: Getting a s a -> Validation a r -> Validation s r+sub_ = lmap . view++-- | Validate value against a schema given schema reference and validation function.+withRef :: Reference -> (Schema -> Validation s a) -> Validation s a+withRef (Reference ref) f = withConfig $ \cfg ->+  case HashMap.lookup ref (configDefinitions cfg) of+    Nothing -> invalid $ "unknown schema " ++ show ref+    Just s  -> f s++validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()+validateWithSchemaRef (Ref ref)  js = withRef ref $ \schema -> sub schema (validateWithSchema js)+validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)++-- | Validate JSON @'Value'@ with Swagger @'Schema'@.+validateWithSchema :: Value -> Validation Schema ()+validateWithSchema value = do+  validateSchemaType value+  sub_ paramSchema $ validateEnum value++-- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@.+validateWithParamSchema :: Value -> Validation (ParamSchema t) ()+validateWithParamSchema value = do+  validateParamSchemaType value+  validateEnum value++validateInteger :: Scientific -> Validation (ParamSchema t) ()+validateInteger n = do+  when (not (isInteger n)) $+    invalid ("not an integer")+  validateNumber n++validateNumber :: Scientific -> Validation (ParamSchema t) ()+validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do+  let exMax = Just True == schema ^. exclusiveMaximum+      exMin = Just True == schema ^. exclusiveMinimum++  check maximum_ $ \m ->+    when (if exMax then (n >= m) else (n > m)) $+      invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")++  check minimum_ $ \m ->+    when (if exMin then (n <= m) else (n < m)) $+      invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")")++  check multipleOf $ \k ->+    when (not (isInteger (n / k))) $+      invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)++validateString :: Text -> Validation (ParamSchema t) ()+validateString s = do+  check maxLength $ \n ->+    when (len > fromInteger n) $+      invalid ("string is too long (length should be <=" ++ show n ++ ")")++  check minLength $ \n ->+    when (len < fromInteger n) $+      invalid ("string is too short (length should be >=" ++ show n ++ ")")++  check pattern $ \regex -> do+    withConfig $ \cfg -> do+      when (not (configPatternChecker cfg regex s)) $+        invalid ("string does not match pattern " ++ show regex)+  where+    len = Text.length s++validateArray :: Vector Value -> Validation (ParamSchema t) ()+validateArray xs = do+  check maxItems $ \n ->+    when (len > fromInteger n) $+      invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")")++  check minItems $ \n ->+    when (len < fromInteger n) $+      invalid ("array is too short (size should be >=" ++ show n ++ ")")++  check items $ \case+    SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs+    SwaggerItemsObject itemSchema      -> traverse_ (validateWithSchemaRef itemSchema) xs+    SwaggerItemsArray itemSchemas -> do+      when (len /= length itemSchemas) $+        invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")+      sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))++  check uniqueItems $ \unique ->+    when (unique && not allUnique) $+      invalid ("array is expected to contain unique items, but it does not")+  where+    len = Vector.length xs+    allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))++validateObject :: HashMap Text Value -> Validation Schema ()+validateObject o = withSchema $ \schema ->+  case schema ^. discriminator of+    Just pname -> case fromJSON <$> HashMap.lookup pname o of+      Just (Success ref) -> validateWithSchemaRef ref (Object o)+      Just (Error msg)   -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)+      Nothing            -> invalid ("discriminator property " ++ show pname ++ "is missing")+    Nothing -> do+      check maxProperties $ \n ->+        when (size > n) $+          invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")")++      check minProperties $ \n ->+        when (size < n) $+          invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")")++      validateRequired+      validateProps+  where+    size = fromIntegral (HashMap.size o)++    validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)+    validateReq name =+      when (not (HashMap.member name o)) $+        invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))++    validateProps = withSchema $ \schema -> do+      for_ (HashMap.toList o) $ \(k, v) ->+        case v of+          Null | not (k `elem` (schema ^. required)) -> valid  -- null is fine for non-required property+          _ ->+            case HashMap.lookup k (schema ^. properties) of+              Nothing -> check additionalProperties $ \s -> sub s $ validateWithSchema v+              Just s  -> validateWithSchemaRef s v++validateEnum :: Value -> Validation (ParamSchema t) ()+validateEnum value = do+  check enum_ $ \xs ->+    when (value `notElem` xs) $+      invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)++validateSchemaType :: Value -> Validation Schema ()+validateSchemaType value = withSchema $ \schema ->+  case (schema ^. type_, value) of+    (SwaggerNull,    Null)       -> valid+    (SwaggerBoolean, Bool _)     -> valid+    (SwaggerInteger, Number n)   -> sub_ paramSchema (validateInteger n)+    (SwaggerNumber,  Number n)   -> sub_ paramSchema (validateNumber n)+    (SwaggerString,  String s)   -> sub_ paramSchema (validateString s)+    (SwaggerArray,   Array xs)   -> sub_ paramSchema (validateArray xs)+    (SwaggerObject,  Object o)   -> validateObject o+    (t, _) -> invalid $ "expected JSON value of type " ++ show t++validateParamSchemaType :: Value -> Validation (ParamSchema t) ()+validateParamSchemaType value = withSchema $ \schema ->+  case (schema ^. type_, value) of+    (SwaggerBoolean, Bool _)     -> valid+    (SwaggerInteger, Number n)   -> validateInteger n+    (SwaggerNumber,  Number n)   -> validateNumber n+    (SwaggerString,  String s)   -> validateString s+    (SwaggerArray,   Array xs)   -> validateArray xs+    (t, _) -> invalid $ "expected JSON value of type " ++ show t+

@@ -6,8 +6,13 @@ {-# LANGUAGE TypeOperators #-} module Data.Swagger.Internal.Utils where +import Prelude ()+import Prelude.Compat+ import Control.Arrow (first) import Control.Applicative+import Control.Lens ((&), (%~))+import Control.Lens.TH import Data.Aeson import Data.Aeson.Types import Data.Char@@ -17,10 +22,32 @@ import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import Data.Monoid+import Data.Set (Set) import Data.Text (Text) import GHC.Generics+import Language.Haskell.TH (mkName) import Text.Read (readMaybe) +swaggerFieldRules :: LensRules+swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer+  where+    swaggerFieldNamer namer dname fnames fname =+      map fixDefName (namer dname fnames fname)++    fixDefName (MethodName cname mname) = MethodName cname (fixName mname)+    fixDefName (TopName name) = TopName (fixName name)++    fixName = mkName . fixName' . show++    fixName' "in"       = "in_"       -- keyword+    fixName' "type"     = "type_"     -- keyword+    fixName' "default"  = "default_"  -- keyword+    fixName' "minimum"  = "minimum_"  -- Prelude conflict+    fixName' "maximum"  = "maximum_"  -- Prelude conflict+    fixName' "enum"     = "enum_"     -- Control.Lens conflict+    fixName' "head"     = "head_"     -- Prelude conflict+    fixName' n = n+ gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of   Just x -> z x@@ -127,9 +154,10 @@   swaggerMappend = mappend  instance SwaggerMonoid [a]+instance Ord a => SwaggerMonoid (Set a) instance Ord k => SwaggerMonoid (Map k v) -instance {-# OVERLAPPABLE #-} (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where+instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where   swaggerMempty = mempty   swaggerMappend = HashMap.unionWith (\_old new -> new) 

@@ -1,48 +1,55 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#include "overlapping-compat.h" module Data.Swagger.Lens where  import Control.Lens import Data.Aeson (Value) import Data.Scientific (Scientific) import Data.Swagger.Internal+import Data.Swagger.Internal.Utils import Data.Text (Text) --- =======================================================================--- * TH derived lenses+-- * Classy 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--- ** 'Param' lenses-makeLenses ''Param+makeFields ''Swagger+makeFields ''Host+makeFields ''Info+makeFields ''Contact+makeFields ''License+makeLensesWith swaggerFieldRules ''PathItem+makeFields ''Tag+makeFields ''Operation+makeFields ''Param+makeLensesWith swaggerFieldRules ''ParamOtherSchema+makeFields ''Header+makeFields ''Schema+makeFields ''NamedSchema+makeLensesWith swaggerFieldRules ''ParamSchema+makeFields ''Xml+makeLensesWith swaggerFieldRules ''Responses+makeFields ''Response+makeLensesWith swaggerFieldRules ''SecurityScheme+makeFields ''ApiKeyParams+makeFields ''OAuth2Params+makeFields ''ExternalDocs++-- * Prisms -- ** 'ParamAnySchema' prisms makePrisms ''ParamAnySchema--- ** 'ParamOtherSchema' lenses-makeLenses ''ParamOtherSchema--- ** 'Header' lenses-makeLenses ''Header--- ** 'Schema' lenses-makeLenses ''Schema+-- ** 'SecuritySchemeType' prisms+makePrisms ''SecuritySchemeType+-- ** 'Referenced' prisms+makePrisms ''Referenced  -- ** 'SwaggerItems' prisms @@ -63,94 +70,100 @@ _SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t) _SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p) --- ** '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+-- =============================================================+-- More helpful instances for easier access to schema properties --- =======================================================================--- * Helper classy lenses+type instance Index Responses = HttpStatusCode+type instance Index Operation = HttpStatusCode -class HasDescription s d | s -> d where-  description :: Lens' s d+type instance IxValue Responses = Referenced Response+type instance IxValue Operation = Referenced Response -instance HasDescription Response       Text where description = responseDescription-instance HasDescription Info           (Maybe Text) where description = infoDescription-instance HasDescription Tag            (Maybe Text) where description = tagDescription-instance HasDescription Operation      (Maybe Text) where description = operationDescription-instance HasDescription 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+instance Ixed Responses where ix n = responses . ix n+instance At   Responses where at n = responses . at n -class HasParamSchema s t | s -> t where-  parameterSchema :: Lens' s (ParamSchema t)+instance Ixed Operation where ix n = responses . ix n+instance At   Operation where at n = responses . at n -instance HasParamSchema Schema Schema where parameterSchema = schemaParamSchema-instance HasParamSchema ParamOtherSchema ParamOtherSchema where parameterSchema = paramOtherSchemaParamSchema-instance HasParamSchema Header Header where parameterSchema = headerParamSchema-instance HasParamSchema (ParamSchema t) t where parameterSchema = id+instance HasParamSchema NamedSchema (ParamSchema Schema) where paramSchema = schema.paramSchema -schemaType :: HasParamSchema s t => Lens' s (SwaggerType t)-schemaType = parameterSchema.paramSchemaType+-- HasType instances+instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_+instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_+instance HasType NamedSchema (SwaggerType Schema) where type_ = paramSchema.type_+instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_ -schemaFormat :: HasParamSchema s t => Lens' s (Maybe Format)-schemaFormat = parameterSchema.paramSchemaFormat+-- HasDefault instances+instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_+instance HasDefault Schema (Maybe Value) where default_ = paramSchema.default_+instance HasDefault ParamOtherSchema (Maybe Value) where default_ = paramSchema.default_ -schemaItems :: HasParamSchema s t => Lens' s (Maybe (SwaggerItems t))-schemaItems = parameterSchema.paramSchemaItems+-- OVERLAPPABLE instances -schemaDefault :: HasParamSchema s t => Lens' s (Maybe Value)-schemaDefault = parameterSchema.paramSchemaDefault+instance+#if __GLASGOW_HASKELL__ >= 710+  OVERLAPPABLE_+#endif+  HasParamSchema s (ParamSchema t)+  => HasFormat s (Maybe Format) where+  format = paramSchema.format -schemaMaximum :: HasParamSchema s t => Lens' s (Maybe Scientific)-schemaMaximum = parameterSchema.paramSchemaMaximum+instance+#if __GLASGOW_HASKELL__ >= 710+  OVERLAPPABLE_+#endif+  HasParamSchema s (ParamSchema t)+  => HasItems s (Maybe (SwaggerItems t)) where+  items = paramSchema.items -schemaExclusiveMaximum :: HasParamSchema s t => Lens' s (Maybe Bool)-schemaExclusiveMaximum = parameterSchema.paramSchemaExclusiveMaximum+instance+#if __GLASGOW_HASKELL__ >= 710+  OVERLAPPABLE_+#endif+  HasParamSchema s (ParamSchema t)+  => HasMaximum s (Maybe Scientific) where+  maximum_ = paramSchema.maximum_ -schemaMinimum :: HasParamSchema s t => Lens' s (Maybe Scientific)-schemaMinimum = parameterSchema.paramSchemaMinimum+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasExclusiveMaximum s (Maybe Bool) where+  exclusiveMaximum = paramSchema.exclusiveMaximum -schemaExclusiveMinimum :: HasParamSchema s t => Lens' s (Maybe Bool)-schemaExclusiveMinimum = parameterSchema.paramSchemaExclusiveMinimum+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasMinimum s (Maybe Scientific) where+  minimum_ = paramSchema.minimum_ -schemaMaxLength :: HasParamSchema s t => Lens' s (Maybe Integer)-schemaMaxLength = parameterSchema.paramSchemaMaxLength+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasExclusiveMinimum s (Maybe Bool) where+  exclusiveMinimum = paramSchema.exclusiveMinimum -schemaMinLength :: HasParamSchema s t => Lens' s (Maybe Integer)-schemaMinLength = parameterSchema.paramSchemaMinLength+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasMaxLength s (Maybe Integer) where+  maxLength = paramSchema.maxLength -schemaPattern :: HasParamSchema s t => Lens' s (Maybe Text)-schemaPattern = parameterSchema.paramSchemaPattern+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasMinLength s (Maybe Integer) where+  minLength = paramSchema.minLength -schemaMaxItems :: HasParamSchema s t => Lens' s (Maybe Integer)-schemaMaxItems = parameterSchema.paramSchemaMaxItems+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasPattern s (Maybe Text) where+  pattern = paramSchema.pattern -schemaMinItems :: HasParamSchema s t => Lens' s (Maybe Integer)-schemaMinItems = parameterSchema.paramSchemaMinItems+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasMaxItems s (Maybe Integer) where+  maxItems = paramSchema.maxItems -schemaUniqueItems :: HasParamSchema s t => Lens' s (Maybe Bool)-schemaUniqueItems = parameterSchema.paramSchemaUniqueItems+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasMinItems s (Maybe Integer) where+  minItems = paramSchema.minItems -schemaEnum :: HasParamSchema s t => Lens' s (Maybe [Value])-schemaEnum = parameterSchema.paramSchemaEnum+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasUniqueItems s (Maybe Bool) where+  uniqueItems = paramSchema.uniqueItems -schemaMultipleOf :: HasParamSchema s t => Lens' s (Maybe Scientific)-schemaMultipleOf = parameterSchema.paramSchemaMultipleOf+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasEnum s (Maybe [Value]) where+  enum_ = paramSchema.enum_ +instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)+  => HasMultipleOf s (Maybe Scientific) where+  multipleOf = paramSchema.multipleOf

@@ -0,0 +1,196 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module:      Data.Swagger.Operation+-- Copyright:   (c) 2015 GetShopTV+-- License:     BSD3+-- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability:   experimental+--+-- Helper traversals and functions for Swagger operations manipulations.+-- These might be useful when you already have Swagger specification+-- generated by something else.+module Data.Swagger.Operation (+  -- * Operation traversals+  allOperations,+  operationsOf,++  -- * Manipulation+  -- ** Tags+  applyTags,+  applyTagsFor,++  -- ** Responses+  setResponse,+  setResponseWith,+  setResponseFor,+  setResponseForWith,++  -- ** Paths+  prependPath,++  -- * Miscellaneous+  declareResponse,+) where++import Control.Applicative+import Control.Arrow+import Control.Lens+import Data.Data.Lens+import qualified Data.HashMap.Strict as HashMap+import Data.List+import Data.Maybe (mapMaybe)+import Data.Monoid+import qualified Data.Set as Set+import Data.Traversable++import Data.Swagger.Declare+import Data.Swagger.Internal+import Data.Swagger.Lens+import Data.Swagger.Schema++-- $setup+-- >>> import Data.Aeson+-- >>> import Data.Proxy+-- >>> import Data.Time++-- | Prepend path piece to all operations of the spec.+-- Leading and trailing slashes are trimmed/added automatically.+--+-- >>> let api = (mempty :: Swagger) & paths .~ [("/info", mempty)]+-- >>> encode $ prependPath "user/{user_id}" api ^. paths+-- "{\"/user/{user_id}/info\":{}}"+prependPath :: FilePath -> Swagger -> Swagger+prependPath path = paths %~ mapKeys (path </>)+  where+    mapKeys f = HashMap.fromList . map (first f) . HashMap.toList++    x </> y = case trim y of+      "" -> "/" <> trim x+      y' -> "/" <> trim x <> "/" <> y'++    trim = dropWhile (== '/') . dropWhileEnd (== '/')++-- | All operations of a Swagger spec.+allOperations :: Traversal' Swagger Operation+allOperations = paths.traverse.template++-- | @'operationsOf' sub@ will traverse only those operations+-- that are present in @sub@. Note that @'Operation'@ is determined+-- by both path and method.+--+-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"+-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]+-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]+-- >>> encode api+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"+-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}"+operationsOf :: Swagger -> Traversal' Swagger Operation+operationsOf sub = paths.itraversed.withIndex.subops+  where+    -- | Traverse operations that correspond to paths and methods of the sub API.+    subops :: Traversal' (FilePath, PathItem) Operation+    subops f (path, item) = case HashMap.lookup path (sub ^. paths) of+      Just subitem -> (,) path <$> methodsOf subitem f item+      Nothing      -> pure (path, item)++    -- | Traverse operations that exist in a given @'PathItem'@+    -- This is used to traverse only the operations that exist in sub API.+    methodsOf :: PathItem -> Traversal' PathItem Operation+    methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just+      where+        ops = pathItem ^.. template :: [Maybe Operation]+        ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops++-- | Apply tags to all operations and update the global list of tags.+--+-- @+-- 'applyTags' = 'applyTagsFor' 'allOperations'+-- @+applyTags :: [Tag] -> Swagger -> Swagger+applyTags = applyTagsFor allOperations++-- | Apply tags to a part of Swagger spec and update the global+-- list of tags.+applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger+applyTagsFor ops ts swag = swag+  & ops . tags %~ (<> Set.fromList (map _tagName ts))+  & tags %~ (<> Set.fromList ts)++-- | Construct a response with @'Schema'@ while declaring all+-- necessary schema definitions.+--+-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty+-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]"+declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response+declareResponse proxy = do+  s <- declareSchemaRef proxy+  return (mempty & schema ?~ s)++-- | Set response for all operations.+-- This will also update global schema definitions.+--+-- If the response already exists it will be overwritten.+--+-- @+-- 'setResponse' = 'setResponseFor' 'allOperations'+-- @+--+-- Example:+--+-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]+-- >>> let res = declareResponse (Proxy :: Proxy Day)+-- >>> encode $ api & setResponse 200 res+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}"+--+-- See also @'setResponseWith'@.+setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger+setResponse = setResponseFor allOperations++-- | Set or update response for all operations.+-- This will also update global schema definitions.+--+-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),+-- then just the new response is used.+--+-- @+-- 'setResponseWith' = 'setResponseForWith' 'allOperations'+-- @+--+-- See also @'setResponse'@.+setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger+setResponseWith = setResponseForWith allOperations++-- | Set response for specified operations.+-- This will also update global schema definitions.+--+-- If the response already exists it will be overwritten.+--+-- See also @'setResponseForWith'@.+setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger+setResponseFor ops code dres swag = swag+  & definitions %~ (<> defs)+  & ops . at code ?~ Inline res+  where+    (defs, res) = runDeclare dres mempty++-- | Set or update response for specified operations.+-- This will also update global schema definitions.+--+-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),+-- then just the new response is used.+--+-- See also @'setResponseFor'@.+setResponseForWith :: Traversal' Swagger Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger+setResponseForWith ops f code dres swag = swag+  & definitions %~ (<> defs)+  & ops . at code %~ Just . Inline . combine+  where+    (defs, new) = runDeclare dres mempty++    combine (Just (Ref (Reference name))) = case swag ^. responses.at name of+      Just old -> f old new+      Nothing  -> new -- response name can't be dereferenced, replacing with new response+    combine (Just (Inline old)) = f old new+    combine Nothing = new+

@@ -14,6 +14,11 @@   genericToParamSchema,   toParamSchemaBoundedIntegral, +  -- * Schema templates+  passwordParamSchema,+  binaryParamSchema,+  byteParamSchema,+   -- * Generic encoding configuration   SchemaOptions(..),   defaultSchemaOptions,

@@ -9,8 +9,6 @@ module Data.Swagger.Schema (   -- * Encoding   ToSchema(..),-  Definitions,-  NamedSchema,   declareSchema,   declareSchemaRef,   toSchema,@@ -25,6 +23,15 @@   toSchemaBoundedIntegral,   paramSchemaToNamedSchema,   paramSchemaToSchema,++  -- * Schema templates+  passwordSchema,+  binarySchema,+  byteSchema,++  -- * Sketching @'Schema'@s using @'ToJSON'@+  sketchSchema,+  sketchStrictSchema,    -- * Inlining @'Schema'@s   inlineNonRecursiveSchemas,

@@ -0,0 +1,83 @@+-- |+-- Module:      Data.Swagger.Schema.Validation+-- Copyright:   (c) 2015 GetShopTV+-- License:     BSD3+-- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>+-- Stability:   experimental+--+-- Validate JSON values with Swagger Schema.+module Data.Swagger.Schema.Validation (+  -- * How to use validation+  -- $howto++  -- ** Examples+  -- $examples++  -- ** Validating @'Maybe'@+  -- $maybe++  -- * JSON validation+  validateToJSON,+  validateToJSONWithPatternChecker,+  ValidationError,+) where++import Data.Swagger.Internal.Schema.Validation++-- $setup+-- >>> import Control.Lens+-- >>> import Data.Aeson+-- >>> import Data.Proxy+-- >>> import Data.Swagger+-- >>> import GHC.Generics+-- >>> :set -XDeriveGeneric++-- $howto+--+-- This module provides helpful functions for JSON validation.+-- These functions are meant to be used in test suites for your application+-- to ensure that JSON respresentation for your data corresponds to+-- schemas you're using for the Swagger specification.+--+-- It is recommended to use validation functions as QuickCheck properties+-- (see <http://hackage.haskell.org/package/QuickCheck>).++-- $examples+--+-- >>> validateToJSON "hello"+-- []+--+-- >>> validateToJSON False+-- []+--+-- >>> newtype Nat = Nat Integer deriving Generic+-- >>> instance ToJSON Nat where toJSON (Nat n) = toJSON n+-- >>> instance ToSchema Nat where declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy & mapped.minimum_ ?~ 0+-- >>> validateToJSON (Nat 10)+-- []+-- >>> validateToJSON (Nat (-5))+-- ["value -5.0 falls below minimum (should be >=0.0)"]++-- $maybe+--+-- Because @'Maybe' a@ has the same schema as @a@, validation+-- generally fails for @null@ JSON:+--+-- >>> validateToJSON (Nothing :: Maybe String)+-- ["expected JSON value of type SwaggerString"]+-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])+-- ["expected JSON value of type SwaggerString"]+-- >>> validateToJSON (123, Nothing :: Maybe String)+-- ["expected JSON value of type SwaggerString"]+--+-- However, when @'Maybe' a@ is a type of a record field,+-- validation takes @'required'@ property of the @'Schema'@+-- into account:+--+-- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic+-- >>> instance ToJSON Person+-- >>> instance ToSchema Person+-- >>> validateToJSON (Person "Nick" (Just 24))+-- []+-- >>> validateToJSON (Person "Nick" Nothing)+-- []

@@ -1,5 +1,5 @@ name:                swagger2-version:             1.2.1+version:             2.0 synopsis:            Swagger 2.0 data model description:         Please see README.md homepage:            https://github.com/GetShopTV/swagger2@@ -15,57 +15,73 @@     README.md   , CHANGELOG.md   , examples/*.hs+  , include/overlapping-compat.h cabal-version:       >=1.10+tested-with:         GHC==7.8.4, GHC==7.10.3  library   hs-source-dirs:      src+  include-dirs:        include   exposed-modules:     Data.Swagger     Data.Swagger.Declare     Data.Swagger.Lens+    Data.Swagger.Operation     Data.Swagger.ParamSchema     Data.Swagger.Schema+    Data.Swagger.Schema.Validation     Data.Swagger.SchemaOptions      -- internal modules     Data.Swagger.Internal     Data.Swagger.Internal.Schema+    Data.Swagger.Internal.Schema.Validation     Data.Swagger.Internal.ParamSchema     Data.Swagger.Internal.Utils-  build-depends:       base == 4.*+  build-depends:       base        >=4.7   && <4.10+                     , base-compat >=0.6.0 && <0.10                      , aeson                      , containers                      , hashable                      , http-media+                     , lens                      , mtl                      , network+                     , scientific                      , text+                     , template-haskell                      , time+                     , transformers                      , unordered-containers-                     , lens-                     , scientific+                     , vector   default-language:    Haskell2010  test-suite spec   type:             exitcode-stdio-1.0   hs-source-dirs:   test   main-is:          Spec.hs-  build-depends:    base  == 4.*-                  , swagger2+  build-depends:    base+                  , base-compat+                  , aeson+                  , aeson-qq+                  , containers+                  , hashable                   , hspec                   , HUnit+                  , mtl                   , QuickCheck+                  , swagger2                   , text-                  , aeson-                  , aeson-qq-                  , containers+                  , time                   , unordered-containers                   , vector                   , lens   other-modules:     SpecCommon     Data.SwaggerSpec+    Data.Swagger.ParamSchemaSpec     Data.Swagger.SchemaSpec+    Data.Swagger.Schema.ValidationSpec   default-language: Haskell2010  test-suite doctest

@@ -0,0 +1,114 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+module Data.Swagger.ParamSchemaSpec where++import Data.Aeson+import Data.Aeson.QQ+import Data.Char+import Data.Proxy+import GHC.Generics++import Data.Swagger++import SpecCommon+import Test.Hspec++checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js++spec :: Spec+spec = do+  describe "Generic ToParamSchema" $ do+    context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON+    context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON+    context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON+    context "Unary records" $ do+      context "Email (unary record)"  $ checkToParamSchema (Proxy :: Proxy Email)  emailSchemaJSON+      context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON++main :: IO ()+main = hspec spec++-- ========================================================================+-- Unit type+-- ========================================================================++data Unit = Unit deriving (Generic)+instance ToParamSchema Unit++unitSchemaJSON :: Value+unitSchemaJSON = [aesonQQ|+{+  "type": "string",+  "enum": ["Unit"]+}+|]++-- ========================================================================+-- Color (enum)+-- ========================================================================+data Color+  = Red+  | Green+  | Blue+  deriving (Generic)+instance ToParamSchema Color++colorSchemaJSON :: Value+colorSchemaJSON = [aesonQQ|+{+  "type": "string",+  "enum": ["Red", "Green", "Blue"]+}+|]++-- ========================================================================+-- Status (constructorTagModifier)+-- ========================================================================++data Status = StatusOk | StatusError deriving (Generic)++instance ToParamSchema Status where+  toParamSchema = genericToParamSchema defaultSchemaOptions+    { constructorTagModifier = map toLower . drop (length "Status") }++statusSchemaJSON :: Value+statusSchemaJSON = [aesonQQ|+{+  "type": "string",+  "enum": ["ok", "error"]+}+|]++-- ========================================================================+-- Email (newtype with unwrapUnaryRecords set to True)+-- ========================================================================++newtype Email = Email { getEmail :: String }+  deriving (Generic)+instance ToParamSchema Email++emailSchemaJSON :: Value+emailSchemaJSON = [aesonQQ|+{+  "type": "string"+}+|]++-- ========================================================================+-- UserId (non-record newtype)+-- ========================================================================++newtype UserId = UserId Integer+  deriving (Generic)+instance ToParamSchema UserId++userIdSchemaJSON :: Value+userIdSchemaJSON = [aesonQQ|+{+  "type": "integer"+}+|]+

@@ -0,0 +1,213 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PackageImports #-}+module Data.Swagger.Schema.ValidationSpec where++import Control.Applicative+import Data.Aeson+import Data.Aeson.Types+import Data.Int+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import Data.Hashable (Hashable)+import "unordered-containers" Data.HashSet (HashSet)+import qualified "unordered-containers" Data.HashSet as HashSet+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Proxy+import Data.Time+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Word+import GHC.Generics++import Data.Swagger+import Data.Swagger.Declare+import Data.Swagger.Schema.Validation++import SpecCommon+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool+shouldValidate _ x = validateToJSON x == []++spec :: Spec+spec = do+  describe "Validation" $ do+    prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)+    prop "Char" $ shouldValidate (Proxy :: Proxy Char)+    prop "Double" $ shouldValidate (Proxy :: Proxy Double)+    prop "Float" $ shouldValidate (Proxy :: Proxy Float)+    prop "Int" $ shouldValidate (Proxy :: Proxy Int)+    prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)+    prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)+    prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)+    prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)+    prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)+    prop "Word" $ shouldValidate (Proxy :: Proxy Word)+    prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)+    prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)+    prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)+    prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)+    prop "String" $ shouldValidate (Proxy :: Proxy String)+    prop "()" $ shouldValidate (Proxy :: Proxy ())+    prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)+    prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)+    prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)+    prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)+    prop "[String]" $ shouldValidate (Proxy :: Proxy [String])+    -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))+    prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))+    prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))+    prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))+    prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))+    prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))+    prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))+    prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))+    prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))+    prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))+    prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))+    prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))+    prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))+    prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))+    prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))+    prop "Person" $ shouldValidate (Proxy :: Proxy Person)+    prop "Color" $ shouldValidate (Proxy :: Proxy Color)+    prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)+    prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)+    prop "Light" $ shouldValidate (Proxy :: Proxy Light)++main :: IO ()+main = hspec spec++-- ========================================================================+-- Person (simple record with optional fields)+-- ========================================================================+data Person = Person+  { name  :: String+  , phone :: Integer+  , email :: Maybe String+  } deriving (Show, Generic)++instance ToJSON Person+instance ToSchema Person++instance Arbitrary Person where+  arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary++-- ========================================================================+-- Color (enum)+-- ========================================================================+data Color = Red | Green | Blue deriving (Show, Generic, Bounded, Enum)++instance ToJSON Color+instance ToSchema Color++instance Arbitrary Color where+  arbitrary = arbitraryBoundedEnum++-- ========================================================================+-- Paint (record with bounded enum property)+-- ========================================================================++newtype Paint = Paint { color :: Color }+  deriving (Show, Generic)++instance ToJSON Paint+instance ToSchema Paint++instance Arbitrary Paint where+  arbitrary = Paint <$> arbitrary++-- ========================================================================+-- MyRoseTree (custom datatypeNameModifier)+-- ========================================================================++data MyRoseTree = MyRoseTree+  { root  :: String+  , trees :: [MyRoseTree]+  } deriving (Show, Generic)++instance ToJSON MyRoseTree++instance ToSchema MyRoseTree where+  declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions+    { datatypeNameModifier = drop (length "My") }++instance Arbitrary MyRoseTree where+  arbitrary = fmap (cut limit) $ MyRoseTree <$> arbitrary <*> (take limit <$> arbitrary)+    where+      limit = 4+      cut 0 (MyRoseTree x _ ) = MyRoseTree x []+      cut n (MyRoseTree x xs) = MyRoseTree x (map (cut (n - 1)) xs)++-- ========================================================================+-- Light (sum type)+-- ========================================================================++data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)++instance ToSchema Light++instance ToJSON Light where+  toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }++instance Arbitrary Light where+  arbitrary = oneof+    [ return NoLight+    , LightFreq <$> arbitrary+    , LightColor <$> arbitrary+    ]++-- Arbitrary instances for common types++#if MIN_VERSION_QuickCheck(2,8,2)+#else+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where+  arbitrary = Map.fromList <$> arbitrary++instance Arbitrary a => Arbitrary (IntMap a) where+  arbitrary = IntMap.fromList <$> arbitrary++instance (Ord a, Arbitrary a) => Arbitrary (Set a) where+  arbitrary = Set.fromList <$> arbitrary+#endif++instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where+  arbitrary = HashMap.fromList <$> arbitrary++instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where+  arbitrary = HashSet.fromList <$> arbitrary++instance Arbitrary T.Text where+  arbitrary = T.pack <$> arbitrary++instance Arbitrary TL.Text where+  arbitrary = TL.pack <$> arbitrary++instance Arbitrary Day where+  arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary++instance Arbitrary LocalTime where+  arbitrary = LocalTime+    <$> arbitrary+    <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))++instance Eq ZonedTime where+  ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y++instance Arbitrary ZonedTime where+  arbitrary = ZonedTime+    <$> arbitrary+    <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))++instance Arbitrary UTCTime where+  arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))+

@@ -1,10 +1,12 @@ {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} module Data.Swagger.SchemaSpec where +import Prelude ()+import Prelude.Compat+ import Data.Aeson import Data.Aeson.QQ import Data.Char@@ -12,7 +14,6 @@ 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 @@ -41,14 +42,14 @@ 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+checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js   where-    (defs, schema) = runDeclare (declareSchema proxy) mempty+    (defs, s) = runDeclare (declareSchema proxy) mempty  checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec-checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs schema <=> js+checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js   where-    (defs, schema) = runDeclare (declareSchema proxy) mempty+    (defs, s) = runDeclare (declareSchema proxy) mempty  spec :: Spec spec = do@@ -101,8 +102,10 @@   { name  :: String   , phone :: Integer   , email :: Maybe String-  } deriving (Generic, ToSchema)+  } deriving (Generic) +instance ToSchema Person+ personSchemaJSON :: Value personSchemaJSON = [aesonQQ| {@@ -121,8 +124,10 @@ -- ISPair (non-record product data type) -- ======================================================================== data ISPair = ISPair Integer String-  deriving (Generic, ToSchema)+  deriving (Generic) +instance ToSchema ISPair+ ispairSchemaJSON :: Value ispairSchemaJSON = [aesonQQ| {@@ -168,7 +173,8 @@   = Red   | Green   | Blue-  deriving (Generic, ToSchema)+  deriving (Generic)+instance ToSchema Color  colorSchemaJSON :: Value colorSchemaJSON = [aesonQQ|@@ -182,7 +188,8 @@ -- Shade (paramSchemaToNamedSchema) -- ======================================================================== -data Shade = Dim | Bright deriving (Generic, ToParamSchema)+data Shade = Dim | Bright deriving (Generic)+instance ToParamSchema Shade  instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions @@ -199,7 +206,8 @@ -- ========================================================================  newtype Paint = Paint { color :: Color }-  deriving (Generic, ToSchema)+  deriving (Generic)+instance ToSchema Paint  paintSchemaJSON :: Value paintSchemaJSON = [aesonQQ|@@ -255,7 +263,8 @@ -- ========================================================================  newtype UserId = UserId Integer-  deriving (Eq, Ord, Generic, ToSchema)+  deriving (Eq, Ord, Generic)+instance ToSchema UserId  userIdSchemaJSON :: Value userIdSchemaJSON = [aesonQQ|@@ -269,7 +278,8 @@ -- ========================================================================  newtype UserGroup = UserGroup (Set UserId)-  deriving (Generic, ToSchema)+  deriving (Generic)+instance ToSchema UserGroup  userGroupSchemaJSON :: Value userGroupSchemaJSON = [aesonQQ|@@ -286,7 +296,8 @@  newtype Player = Player   { position :: Point-  } deriving (Generic, ToSchema)+  } deriving (Generic)+instance ToSchema Player  playerSchemaJSON :: Value playerSchemaJSON = [aesonQQ|@@ -345,10 +356,11 @@ instance ToSchema a => ToSchema (Inlined a) where   declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)     where-      unname (_, schema) = (Nothing, schema)+      unname (NamedSchema _ s) = NamedSchema Nothing s  newtype Players = Players [Inlined Player]-  deriving (Generic, ToSchema)+  deriving (Generic)+instance ToSchema Players  playersSchemaJSON :: Value playersSchemaJSON = [aesonQQ|@@ -400,7 +412,8 @@ -- Unit type -- ======================================================================== -data Unit = Unit deriving (Generic, ToSchema)+data Unit = Unit deriving (Generic)+instance ToSchema Unit  unitSchemaJSON :: Value unitSchemaJSON = [aesonQQ|@@ -418,7 +431,8 @@ data Character   = PC Player   | NPC { npcName :: String, npcPosition :: Point }-  deriving (Generic, ToSchema)+  deriving (Generic)+instance ToSchema Character  characterSchemaJSON :: Value characterSchemaJSON = [aesonQQ|@@ -531,7 +545,8 @@ -- ========================================================================  data Light-  = LightFreq Double+  = NoLight+  | LightFreq Double   | LightColor Color   | LightWaveLength { waveLength :: Double }   deriving (Generic)@@ -546,6 +561,7 @@   "type": "object",   "properties":     {+      "NoLight": { "type": "array", "items": [] },       "LightFreq": { "type": "number", "format": "double" },       "LightColor": { "$ref": "#/definitions/Color" },       "LightWaveLength": { "type": "number", "format": "double" }@@ -561,6 +577,7 @@   "type": "object",   "properties":     {+      "NoLight": { "type": "array", "items": [] },       "LightFreq": { "type": "number", "format": "double" },       "LightColor":         {@@ -578,6 +595,8 @@ -- ResourceId (series of newtypes) -- ======================================================================== -newtype Id = Id String deriving (Generic, ToSchema)+newtype Id = Id String deriving (Generic)+instance ToSchema Id -newtype ResourceId = ResourceId Id deriving (Generic, ToSchema)+newtype ResourceId = ResourceId Id deriving (Generic)+instance ToSchema ResourceId

@@ -4,16 +4,20 @@ {-# LANGUAGE QuasiQuotes #-} module Data.SwaggerSpec where +import Prelude ()+import Prelude.Compat+ import Control.Lens  import Data.Aeson import Data.Aeson.QQ import Data.HashMap.Strict (HashMap)+import qualified Data.Set as Set import Data.Text (Text)  import Data.Swagger import SpecCommon-import Test.Hspec+import Test.Hspec hiding (example)  spec :: Spec spec = do@@ -44,13 +48,13 @@ -- =======================================================================  infoExample :: Info-infoExample = Info-  { _infoTitle = "Swagger Sample App"-  , _infoDescription = Just "This is a sample server Petstore server."-  , _infoTermsOfService = Just "http://swagger.io/terms/"-  , _infoContact = Just contactExample-  , _infoLicense = Just licenseExample-  , _infoVersion = "1.0.1" }+infoExample = mempty+  & title          .~ "Swagger Sample App"+  & description    ?~ "This is a sample server Petstore server."+  & termsOfService ?~ "http://swagger.io/terms/"+  & contact        ?~ contactExample+  & license        ?~ licenseExample+  & version        .~ "1.0.1"  infoExampleJSON :: Value infoExampleJSON = [aesonQQ|@@ -76,10 +80,10 @@ -- =======================================================================  contactExample :: Contact-contactExample = Contact-  { _contactName = Just "API Support"-  , _contactUrl = Just (URL "http://www.swagger.io/support")-  , _contactEmail = Just "support@swagger.io" }+contactExample = mempty+  & name  ?~ "API Support"+  & url   ?~ URL "http://www.swagger.io/support"+  & email ?~ "support@swagger.io"  contactExampleJSON :: Value contactExampleJSON = [aesonQQ|@@ -95,9 +99,8 @@ -- =======================================================================  licenseExample :: License-licenseExample = License-  { _licenseName = "Apache 2.0"-  , _licenseUrl = Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html") }+licenseExample = "Apache 2.0"+  & url ?~ URL "http://www.apache.org/licenses/LICENSE-2.0.html"  licenseExampleJSON :: Value licenseExampleJSON = [aesonQQ|@@ -114,46 +117,38 @@  operationExample :: Operation operationExample = mempty-  { _operationTags = ["pet"]-  , _operationSummary = Just "Updates a pet in the store with form data"-  , _operationDescription = Just ""-  , _operationOperationId = Just "updatePetWithForm"-  , _operationConsumes = Just (MimeList ["application/x-www-form-urlencoded"])-  , _operationProduces = Just (MimeList ["application/json", "application/xml"])-  , _operationParameters = params-  , _operationResponses = responses-  , _operationSecurity = security-  }-  where-    security = [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]--    responses = mempty-      { _responsesResponses =-          [ (200, Inline mempty { _responseDescription = "Pet updated." })-          , (405, Inline mempty { _responseDescription = "Invalid input" }) ] }--    params = map Inline-      [ 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) }+  & tags    .~ Set.fromList ["pet"]+  & summary ?~ "Updates a pet in the store with form data"+  & description ?~ ""+  & operationId ?~ "updatePetWithForm"+  & consumes    ?~ MimeList ["application/x-www-form-urlencoded"]+  & produces    ?~ MimeList ["application/json", "application/xml"]+  & parameters .~ map Inline+      [ mempty+          & name        .~ "petId"+          & description ?~ "ID of pet that needs to be updated"+          & required    ?~ True+          & schema .~ ParamOther (stringSchema ParamPath)+      , mempty+          & name        .~ "name"+          & description ?~ "Updated name of the pet"+          & required    ?~ False+          & schema .~ ParamOther (stringSchema ParamFormData)+      , mempty+          & name        .~ "status"+          & description ?~ "Updated status of the pet"+          & required    ?~ False+          & schema .~ ParamOther (stringSchema ParamFormData)       ] +  & at 200 ?~ "Pet updated."+  & at 405 ?~ "Invalid input"+  & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]+  where     stringSchema :: ParamLocation -> ParamOtherSchema-    stringSchema i = mempty-      & paramOtherSchemaIn .~ i-      & schemaType .~ SwaggerString+    stringSchema loc = mempty+      & in_ .~ loc+      & type_ .~ SwaggerString  operationExampleJSON :: Value operationExampleJSON = [aesonQQ|@@ -219,8 +214,8 @@  schemaPrimitiveExample :: Schema schemaPrimitiveExample = mempty-  & schemaType    .~ SwaggerString-  & schemaFormat  ?~ "email"+  & type_  .~ SwaggerString+  & format ?~ "email"  schemaPrimitiveExampleJSON :: Value schemaPrimitiveExampleJSON = [aesonQQ|@@ -232,15 +227,15 @@  schemaSimpleModelExample :: Schema schemaSimpleModelExample = mempty-  & schemaType .~ SwaggerObject-  & schemaRequired .~ [ "name" ]-  & schemaProperties .~-      [ ("name", Inline (mempty & schemaType .~ SwaggerString))+  & type_ .~ SwaggerObject+  & required .~ [ "name" ]+  & properties .~+      [ ("name", Inline (mempty & type_ .~ SwaggerString))       , ("address", Ref (Reference "Address"))       , ("age", Inline $ mempty-            & schemaMinimum ?~ 0-            & schemaType    .~ SwaggerInteger-            & schemaFormat  ?~ "int32" ) ]+            & minimum_ ?~ 0+            & type_    .~ SwaggerInteger+            & format   ?~ "int32" ) ]  schemaSimpleModelExampleJSON :: Value schemaSimpleModelExampleJSON = [aesonQQ|@@ -267,8 +262,8 @@  schemaModelDictExample :: Schema schemaModelDictExample = mempty-  & schemaType .~ SwaggerObject-  & schemaAdditionalProperties ?~ (mempty & schemaType .~ SwaggerString)+  & type_ .~ SwaggerObject+  & additionalProperties ?~ (mempty & type_ .~ SwaggerString)  schemaModelDictExampleJSON :: Value schemaModelDictExampleJSON = [aesonQQ|@@ -281,19 +276,21 @@ |]  schemaWithExampleExample :: Schema-schemaWithExampleExample = (mempty & schemaType .~ SwaggerObject)-  { _schemaProperties =+schemaWithExampleExample = mempty+  & type_ .~ SwaggerObject+  & properties .~       [ ("id", Inline $ mempty-            & schemaType .~ SwaggerInteger-            & schemaFormat ?~ "int64" )-      , ("name", Inline (mempty & schemaType .~ SwaggerString)) ]-  , _schemaRequired = [ "name" ]-  , _schemaExample = Just [aesonQQ|-      {-        "name": "Puma",-        "id": 1-      }-    |] }+            & type_  .~ SwaggerInteger+            & format ?~ "int64" )+      , ("name", Inline $ mempty+            & type_ .~ SwaggerString) ]+  & required .~ [ "name" ]+  & example ?~ [aesonQQ|+    {+      "name": "Puma",+      "id": 1+    }+  |]  schemaWithExampleExampleJSON :: Value schemaWithExampleExampleJSON = [aesonQQ|@@ -325,19 +322,19 @@ definitionsExample :: HashMap Text Schema definitionsExample =   [ ("Category", mempty-      & schemaType .~ SwaggerObject-      & schemaProperties .~+      & type_ .~ SwaggerObject+      & properties .~           [ ("id", Inline $ mempty-              & schemaType   .~ SwaggerInteger-              & schemaFormat ?~ "int64")-          , ("name", Inline (mempty & schemaType .~ SwaggerString)) ] )+              & type_  .~ SwaggerInteger+              & format ?~ "int64")+          , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )   , ("Tag", mempty-      & schemaType .~ SwaggerObject-      & schemaProperties .~+      & type_ .~ SwaggerObject+      & properties .~           [ ("id", Inline $ mempty-              & schemaType   .~ SwaggerInteger-              & schemaFormat ?~ "int64")-          , ("name", Inline (mempty & schemaType .~ SwaggerString)) ] ) ]+              & type_  .~ SwaggerInteger+              & format ?~ "int64")+          , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]  definitionsExampleJSON :: Value definitionsExampleJSON = [aesonQQ|@@ -376,21 +373,21 @@ paramsDefinitionExample :: HashMap Text Param paramsDefinitionExample =   [ ("skipParam", mempty-      { _paramName = "skip"-      , _paramDescription = Just "number of items to skip"-      , _paramRequired = Just True-      , _paramSchema = ParamOther $ mempty-          & paramOtherSchemaIn .~ ParamQuery-          & schemaType .~ SwaggerInteger-          & schemaFormat ?~ "int32" })+      & name .~ "skip"+      & description ?~ "number of items to skip"+      & required ?~ True+      & schema .~ ParamOther (mempty+          & in_    .~ ParamQuery+          & type_  .~ SwaggerInteger+          & format ?~ "int32" ))   , ("limitParam", mempty-      { _paramName = "limit"-      , _paramDescription = Just "max records to return"-      , _paramRequired = Just True-      , _paramSchema = ParamOther $ mempty-          & paramOtherSchemaIn .~ ParamQuery-          & schemaType .~ SwaggerInteger-          & schemaFormat ?~ "int32" }) ]+      & name .~ "limit"+      & description ?~ "max records to return"+      & required ?~ True+      & schema .~ ParamOther (mempty+          & in_    .~ ParamQuery+          & type_  .~ SwaggerInteger+          & format ?~ "int32" )) ]  paramsDefinitionExampleJSON :: Value paramsDefinitionExampleJSON = [aesonQQ|@@ -420,8 +417,8 @@  responsesDefinitionExample :: HashMap Text Response responsesDefinitionExample =-  [ ("NotFound", mempty { _responseDescription = "Entity not found." })-  , ("IllegalInput", mempty { _responseDescription = "Illegal input for operation." }) ]+  [ ("NotFound", mempty & description .~ "Entity not found.")+  , ("IllegalInput", mempty & description .~ "Illegal input for operation.") ]  responsesDefinitionExampleJSON :: Value responsesDefinitionExampleJSON = [aesonQQ|@@ -478,45 +475,40 @@  swaggerExample :: Swagger swaggerExample = mempty-  { _basePath = Just "/"-  , _schemes = Just [Http]-  , _info = mempty-      { _infoVersion = "1.0"-      , _infoTitle = "Todo API"-      , _infoLicense = Just License-          { _licenseName = "MIT"-          , _licenseUrl = Just (URL "http://mit.com") }-      , _infoDescription = Just "This is a an API that tests servant-swagger support for a Todo API" }-  , _paths = mempty-      { _pathsMap =-          [ ("/todo/{id}", mempty-              { _pathItemGet = Just mempty-                  { _operationResponses = mempty-                      { _responsesResponses =-                          [ (200, Inline mempty-                              { _responseSchema = Just $ Inline (mempty & schemaType .~ SwaggerObject)-                                { _schemaExample = Just [aesonQQ|-                                    {-                                      "created": 100,-                                      "description": "get milk"-                                    } |]-                                , _schemaDescription = Just "This is some real Todo right here"-                                , _schemaProperties =-                                    [ ("created", Inline $ mempty-                                        & schemaType   .~ SwaggerInteger-                                        & schemaFormat ?~ "int32")-                                    , ("description", Inline (mempty & schemaType .~ SwaggerString)) ] }-                              , _responseDescription = "OK" }) ] }-                  , _operationProduces = Just (MimeList [ "application/json" ])-                  , _operationParameters =-                      [ Inline mempty-                          { _paramRequired = Just True-                          , _paramName = "id"-                          , _paramDescription = Just "TodoId param"-                          , _paramSchema = ParamOther $ mempty-                              & paramOtherSchemaIn .~ ParamPath-                              & schemaType .~ SwaggerString } ]-                  , _operationTags = [ "todo" ] } }) ] } }+  & basePath ?~ "/"+  & schemes ?~ [Http]+  & info .~ (mempty+      & version .~ "1.0"+      & title .~ "Todo API"+      & license ?~ "MIT"+      & license._Just.url ?~ URL "http://mit.com"+      & description ?~ "This is a an API that tests servant-swagger support for a Todo API")+  & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation)+      & at 200 ?~ Inline (mempty+          & description .~ "OK"+          & schema ?~ Inline (mempty+              & type_ .~ SwaggerObject+              & example ?~ [aesonQQ|+                  {+                    "created": 100,+                    "description": "get milk"+                  } |]+              & description ?~ "This is some real Todo right here" +              & properties .~+                  [ ("created", Inline $ mempty+                      & type_  .~ SwaggerInteger+                      & format ?~ "int32")+                  , ("description", Inline (mempty & type_ .~ SwaggerString))]))+      & produces ?~ MimeList [ "application/json" ]+      & parameters .~+          [ Inline $ mempty+              & required ?~ True+              & name .~ "id"+              & description ?~ "TodoId param"+              & schema .~ ParamOther (mempty+                  & in_ .~ ParamPath+                  & type_ .~ SwaggerString ) ]+      & tags .~ Set.fromList [ "todo" ] ))  swaggerExampleJSON :: Value swaggerExampleJSON = [aesonQQ|@@ -856,8 +848,7 @@             },             "security":[                  {  -                  "api_key":[  -                  ]+                  "api_key": []                }             ]          },@@ -1022,8 +1013,7 @@             "produces":[                  "application/json"             ],-            "parameters":[  -            ],+            "parameters": [],             "responses":{                  "200":{                     "description":"successful operation",@@ -1038,8 +1028,7 @@             },             "security":[                  {  -                  "api_key":[  -                  ]+                  "api_key": []                }             ]          }@@ -1311,8 +1300,7 @@                "application/xml",                "application/json"             ],-            "parameters":[  -            ],+            "parameters": [],             "responses":{                  "default":{                     "description":"successful operation"

@@ -4,4 +4,5 @@ import Test.DocTest (doctest)  main :: IO ()-main = glob "src/**/*.hs" >>= doctest+main = glob "src/**/*.hs" >>= doctest'+  where doctest' files = doctest $ "-Iinclude/" : "-D__DOCTEST__" : files