diff --git a/.travis.yml b/.travis.yml index cf3170f4..0678d7f9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -8,7 +8,7 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.10 +# version: 0.10.1 # version: ~> 1.0 language: c @@ -39,8 +39,8 @@ jobs: - compiler: ghc-8.10.1 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}} os: linux - - compiler: ghc-8.8.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.2"]}} + - compiler: ghc-8.8.3 + addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}} os: linux - compiler: ghc-8.6.5 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}} @@ -48,12 +48,6 @@ jobs: - compiler: ghc-8.4.4 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}} os: linux - - compiler: ghc-8.2.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.0.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}} - os: linux before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC" @@ -102,8 +96,8 @@ install: - touch cabal.project - | echo "packages: ." >> cabal.project - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package swagger2' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" + - echo 'package swagger2' >> cabal.project + - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" - | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true @@ -129,8 +123,8 @@ script: - touch cabal.project - | echo "packages: ${PKGDIR_swagger2}" >> cabal.project - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package swagger2' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" + - echo 'package swagger2' >> cabal.project + - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" - | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true @@ -146,10 +140,10 @@ script: # cabal check... - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check) # haddock... - - if [ $HCNUMVER -ge 80400 ] ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi + - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all # Building without installed constraints for packages in global-db... - rm -f cabal.project.local - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all -# REGENDATA ("0.10",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"]) +# REGENDATA ("0.10.1",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"]) # EOF diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 2ea7facb..7f47729d 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -38,8 +38,9 @@ module Data.Swagger ( -- * Swagger specification Swagger(..), - Host(..), - Scheme(..), + Server(..), + ServerVariable(..), + Components(..), -- ** Info types Info(..), @@ -58,45 +59,52 @@ module Data.Swagger ( SwaggerType(..), Format, Definitions, - CollectionFormat(..), + Style(..), -- ** Parameters Param(..), - ParamAnySchema(..), - ParamOtherSchema(..), ParamLocation(..), ParamName, Header(..), HeaderName, Example(..), + RequestBody(..), + MediaTypeObject(..), + Encoding(..), -- ** Schemas - ParamSchema(..), Schema(..), NamedSchema(..), SwaggerItems(..), Xml(..), Pattern, AdditionalProperties(..), + Discriminator(..), -- ** Responses Responses(..), Response(..), HttpStatusCode, + Link(..), + Callback(..), -- ** Security SecurityScheme(..), SecuritySchemeType(..), - SecurityRequirement(..), SecurityDefinitions(..), + SecurityRequirement(..), -- *** API key ApiKeyParams(..), ApiKeyLocation(..), -- *** OAuth2 - OAuth2Params(..), + OAuth2Flows(..), OAuth2Flow(..), + OAuth2ImplicitFlow(..), + OAuth2PasswordFlow(..), + OAuth2ClientCredentialsFlow(..), + OAuth2AuthorizationCodeFlow(..), AuthorizationURL, TokenURL, @@ -127,6 +135,7 @@ import Data.Swagger.Internal -- >>> import Data.Monoid -- >>> import Data.Proxy -- >>> import GHC.Generics +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL -- >>> :set -XDeriveGeneric -- >>> :set -XOverloadedStrings -- >>> :set -XOverloadedLists @@ -143,8 +152,8 @@ import Data.Swagger.Internal -- -- In this library you can use @'mempty'@ for a default/empty value. For instance: -- --- >>> encode (mempty :: Swagger) --- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"}}" +-- >>> BSL.putStrLn $ encode (mempty :: Swagger) +-- {"openapi":"3.0.0","info":{"version":"","title":""},"components":{}} -- -- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty. -- That is because these properties are actually required ones. @@ -152,13 +161,13 @@ import Data.Swagger.Internal -- You /should/ always override the default (empty) value for these properties, -- although it is not strictly necessary: -- --- >>> encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" } --- "{\"version\":\"1.0\",\"title\":\"Todo API\"}" +-- >>> BSL.putStrLn $ encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" } +-- {"version":"1.0","title":"Todo API"} -- -- You can merge two values using @'mappend'@ or its infix version @('<>')@: -- --- >>> encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" } --- "{\"version\":\"1.0\",\"title\":\"Todo API\"}" +-- >>> BSL.putStrLn $ encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" } +-- {"version":"1.0","title":"Todo API"} -- -- This can be useful for combining specifications of endpoints into a whole API specification: -- @@ -184,15 +193,14 @@ import Data.Swagger.Internal -- make it fairly simple to construct/modify any part of the specification: -- -- >>> :{ --- encode $ (mempty :: Swagger) --- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ] +-- BSL.putStrLn $ encode $ (mempty :: Swagger) +-- & components . schemas .~ [ ("User", mempty & type_ ?~ SwaggerString) ] -- & paths .~ -- [ ("/user", mempty & get ?~ (mempty --- & produces ?~ MimeList ["application/json"] --- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User")) +-- & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (Reference "User"))) -- & at 404 ?~ "User info not found")) ] -- :} --- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}" +-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"User info not found"},"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/User"}}},"description":"OK"}}}}},"components":{"schemas":{"User":{"type":"string"}}}} -- -- 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 @@ -204,30 +212,23 @@ import Data.Swagger.Internal -- 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\"}" +-- >>> BSL.putStrLn $ encode $ (mempty :: Response) & description .~ "No content" +-- {"description":"No content"} -- >>> :{ --- encode $ (mempty :: Schema) +-- BSL.putStrLn $ encode $ (mempty :: Schema) -- & type_ ?~ SwaggerBoolean -- & description ?~ "To be or not to be" -- :} --- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}" --- --- @'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\"}" +-- {"type":"boolean","description":"To be or not to be"} -- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@ -- have direct access to it via @'at' code@. Example: -- -- >>> :{ --- encode $ (mempty :: Operation) +-- BSL.putStrLn $ encode $ (mempty :: Operation) -- & at 404 ?~ "Not found" -- :} --- "{\"responses\":{\"404\":{\"description\":\"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. @@ -274,45 +275,22 @@ import Data.Swagger.Internal -- >>> data Person = Person { name :: String, age :: Integer } deriving Generic -- >>> instance ToJSON Person -- >>> instance ToSchema Person --- >>> encode (Person "David" 28) --- "{\"age\":28,\"name\":\"David\"}" --- >>> encode $ toSchema (Proxy :: Proxy Person) --- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}" --- --- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a --- schema for basic enums like --- --- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic --- >>> instance ToSchema SampleEnum --- >>> instance ToJSON SampleEnum --- --- and for sum types that have constructors with values --- --- >>> data SampleSumType = ChoiceInt Int | ChoiceString String deriving Generic --- >>> instance ToSchema SampleSumType --- >>> instance ToJSON SampleSumType --- --- we can not derive a valid schema for a mix of the above. The following will result in a type error --- --- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic --- >>> instance ToSchema BadMixedType --- ... --- ... error: --- ... • Cannot derive Generic-based Swagger Schema for BadMixedType --- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors). --- ... Swagger does not have a good representation for these types. --- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema --- ... that matches aeson's Generic-based toJSON, --- ... but that's not supported by some Swagger tools. --- ... --- ... In the instance declaration for ‘ToSchema BadMixedType’ --- --- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON': --- --- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic --- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions --- >>> instance ToJSON BadMixedType --- +-- >>> BSL.putStrLn $ encode (Person "David" 28) +-- {"age":28,"name":"David"} +-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Person) +-- {"required":["name","age"],"type":"object","properties":{"age":{"type":"integer"},"name":{"type":"string"}}} +-- +-- This package implements OpenAPI 3.0 spec, which supports @oneOf@ in schemas, allowing any sum types +-- to be faithfully represented. All sum encodings supported by @aeson@ are supported here as well, with +-- an exception of 'Data.Aeson.TwoElemArray', since OpenAPI spec does not support heterogeneous arrays. +-- +-- An example with 'Data.Aeson.TaggedObject' encoding: +-- +-- >>> data Error = ErrorNoUser { userId :: Int } | ErrorAccessDenied { requiredPermission :: String } deriving Generic +-- >>> instance ToJSON Error +-- >>> instance ToSchema Error +-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Error) +-- {"oneOf":[{"required":["userId","tag"],"type":"object","properties":{"tag":{"type":"string","enum":["ErrorNoUser"]},"userId":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}}},{"required":["requiredPermission","tag"],"type":"object","properties":{"tag":{"type":"string","enum":["ErrorAccessDenied"]},"requiredPermission":{"type":"string"}}}],"type":"object"} -- $manipulation -- Sometimes you have to work with an imported or generated @'Swagger'@. diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index aba43653..c3620e50 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -19,26 +19,29 @@ module Data.Swagger.Internal where import Prelude () import Prelude.Compat -import Control.Lens ((&), (.~), (?~)) import Control.Applicative -import Data.Aeson -import qualified Data.Aeson.Types as JSON -import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex) -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet.InsOrd (InsOrdHashSet) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Monoid (Monoid (..)) -import Data.Semigroup.Compat (Semigroup (..)) -import Data.Scientific (Scientific) -import Data.String (IsString(..)) -import Data.Text (Text) -import qualified Data.Text as Text -import GHC.Generics (Generic) -import Network.Socket (HostName, PortNumber) -import Network.HTTP.Media (MediaType) -import Text.Read (readMaybe) +import Control.Lens ((&), (.~), (?~)) +import Data.Aeson hiding (Encoding) +import qualified Data.Aeson.Types as JSON +import Data.Data (Constr, Data (..), DataType, Fixity (..), Typeable, + constrIndex, mkConstr, mkDataType) +import Data.Hashable (Hashable (..)) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet.InsOrd (InsOrdHashSet) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid (Monoid (..)) +import Data.Scientific (Scientific) +import Data.Semigroup.Compat (Semigroup (..)) +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import GHC.Generics (Generic) +import Network.HTTP.Media (MediaType, mainType, parameters, parseAccept, subType, (//), + (/:)) +import Network.Socket (HostName, PortNumber) +import Text.Read (readMaybe) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap @@ -68,56 +71,28 @@ data Swagger = Swagger -- The metadata can be used by the clients if needed. _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). - , _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 (/). - , _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. - , _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. - , _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. - , _swaggerProduces :: MimeList + -- | An array of Server Objects, which provide connectivity information + -- to a target server. If the servers property is not provided, or is an empty array, + -- the default value would be a 'Server' object with a url value of @/@. + , _swaggerServers :: [Server] -- | The available paths and operations for the API. - -- Holds the relative paths to the individual endpoints. - -- The path is appended to the @'basePath'@ in order to construct the full URL. , _swaggerPaths :: InsOrdHashMap FilePath PathItem - -- | An object to hold data types produced and consumed by operations. - , _swaggerDefinitions :: Definitions Schema + -- | An element to hold various schemas for the specification. + , _swaggerComponents :: Components - -- | An object to hold parameters that can be used across operations. - -- This property does not define global parameters for all operations. - , _swaggerParameters :: Definitions Param - - -- | An object to hold responses that can be used across operations. - -- This property does not define global responses for all operations. - , _swaggerResponses :: Definitions Response - - -- | Security scheme definitions that can be used across the specification. - , _swaggerSecurityDefinitions :: SecurityDefinitions - - -- | 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). + -- | A declaration of which security mechanisms can be used across the API. + -- The list of values includes alternative security requirement objects that can be used. + -- Only one of the security requirement objects need to be satisfied to authorize a request. -- Individual operations can override this definition. + -- To make security optional, an empty security requirement can be included in the array. , _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. + -- Not all tags that are used by the 'Operation' Object must be declared. + -- The tags that are not declared MAY be organized randomly or based on the tools' logic. -- Each tag name in the list MUST be unique. , _swaggerTags :: InsOrdHashSet Tag @@ -126,17 +101,17 @@ data Swagger = Swagger } deriving (Eq, Show, Generic, Data, Typeable) -- | The object provides metadata about the API. --- The metadata can be used by the clients if needed, --- and can be presented in the Swagger-UI for convenience. +-- The metadata MAY be used by the clients if needed, +-- and MAY be presented in editing or documentation generation tools for convenience. data Info = Info - { -- | The title of the application. + { -- | The title of the API. _infoTitle :: Text - -- | A short description of the application. - -- GFM syntax can be used for rich text representation. + -- | A short description of the API. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. , _infoDescription :: Maybe Text - -- | The Terms of Service for the API. + -- | A URL to the Terms of Service for the API. MUST be in the format of a URL. , _infoTermsOfService :: Maybe Text -- | The contact information for the exposed API. @@ -145,8 +120,8 @@ data Info = Info -- | The license information for the exposed API. , _infoLicense :: Maybe License - -- | Provides the version of the application API - -- (not to be confused with the specification version). + -- | The version of the OpenAPI document (which is distinct from the + -- OpenAPI Specification version or the API implementation version). , _infoVersion :: Text } deriving (Eq, Show, Generic, Data, Typeable) @@ -174,43 +149,71 @@ data License = License 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) +-- | An object representing a Server. +data Server = Server + { -- | A URL to the target host. This URL supports Server Variables and MAY be relative, + -- to indicate that the host location is relative to the location where + -- the OpenAPI document is being served. Variable substitutions will be made when + -- a variable is named in @{brackets}@. + _serverUrl :: Text + + -- | An optional string describing the host designated by the URL. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. + , _serverDescription :: Maybe Text + + -- | A map between a variable name and its value. + -- The value is used for substitution in the server's URL template. + , _serverVariables :: InsOrdHashMap Text ServerVariable + } deriving (Eq, Show, Generic, Data, Typeable) -instance IsString Host where - fromString s = Host s Nothing +data ServerVariable = ServerVariable + { -- | An enumeration of string values to be used if the substitution options + -- are from a limited set. The array SHOULD NOT be empty. + _serverVariableEnum :: Maybe (InsOrdHashSet Text) -- TODO NonEmpty -hostConstr :: Constr -hostConstr = mkConstr hostDataType "Host" [] Prefix + -- | The default value to use for substitution, which SHALL be sent if an alternate value + -- is not supplied. Note this behavior is different than the 'Schema\ Object's treatment + -- of default values, because in those cases parameter values are optional. + -- If the '_serverVariableEnum' is defined, the value SHOULD exist in the enum's values. + , _serverVariableDefault :: Text -hostDataType :: DataType -hostDataType = mkDataType "Data.Swagger.Host" [hostConstr] + -- | An optional description for the server variable. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. + , _serverVariableDescription :: Maybe Text + } deriving (Eq, Show, Generic, Data, Typeable) -instance Data Host where - gunfold k z c = case constrIndex c of - 1 -> k (k (z (\name mport -> Host name (fromInteger <$> mport)))) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Host." - toConstr (Host _ _) = hostConstr - dataTypeOf _ = hostDataType - --- | The transfer protocol of the API. -data Scheme - = Http - | Https - | Ws - | Wss - deriving (Eq, Show, Generic, Data, Typeable) +instance IsString Server where + fromString s = Server (fromString s) Nothing mempty + +-- | Holds a set of reusable objects for different aspects of the OAS. +-- All objects defined within the components object will have no effect on the API +-- unless they are explicitly referenced from properties outside the components object. +data Components = Components + { _componentsSchemas :: Definitions Schema + , _componentsResponses :: Definitions Response + , _componentsParameters :: Definitions Param + , _componentsExamples :: Definitions Example + , _componentsRequestBodies :: Definitions RequestBody + , _componentsHeaders :: Definitions Header + , _componentsSecuritySchemes :: Definitions SecurityScheme + , _componentsLinks :: Definitions Link + , _componentsCallbacks :: Definitions Callback + } 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 -- but they will not know which operations and parameters are available. data PathItem = PathItem - { -- | A definition of a GET operation on this path. - _pathItemGet :: Maybe Operation + { -- | An optional, string summary, intended to apply to all operations in this path. + _pathItemSummary :: Maybe Text + + -- | An optional, string description, intended to apply to all operations in this path. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. + , _pathItemDescription :: Maybe Text + + -- | A definition of a GET operation on this path. + , _pathItemGet :: Maybe Operation -- | A definition of a PUT operation on this path. , _pathItemPut :: Maybe Operation @@ -230,6 +233,12 @@ data PathItem = PathItem -- | A definition of a PATCH operation on this path. , _pathItemPatch :: Maybe Operation + -- | A definition of a TRACE operation on this path. + , _pathItemTrace :: Maybe Operation + + -- | An alternative server array to service all operations in this path. + , _pathItemServers :: [Server] + -- | A list of parameters that are applicable for all the operations described under this path. -- These parameters can be overridden at the operation level, but cannot be removed there. -- The list MUST NOT include duplicated parameters. @@ -248,7 +257,7 @@ data Operation = Operation , _operationSummary :: Maybe Text -- | A verbose explanation of the operation behavior. - -- GFM syntax can be used for rich text representation. + -- [CommonMark syntax](https://spec.commonmark.org/) can be used for rich text representation. , _operationDescription :: Maybe Text -- | Additional external documentation for this operation. @@ -256,20 +265,11 @@ data Operation = Operation -- | Unique string used to identify the operation. -- The id MUST be unique among all operations described in the API. - -- Tools and libraries MAY use the it to uniquely identify an operation, - -- therefore, it is recommended to follow common programming naming conventions. + -- The operationId value is **case-sensitive**. + -- Tools and libraries MAY use the operationId to uniquely identify an operation, therefore, + -- it is RECOMMENDED to follow common programming naming conventions. , _operationOperationId :: Maybe Text - -- | A list of MIME types the operation can consume. - -- This overrides the @'consumes'@. - -- @Just []@ MAY be used to clear the global definition. - , _operationConsumes :: Maybe MimeList - - -- | A list of MIME types the operation can produce. - -- This overrides the @'produces'@. - -- @Just []@ MAY be used to clear the global definition. - , _operationProduces :: Maybe MimeList - -- | A list of parameters that are applicable for this operation. -- If a parameter is already defined at the @'PathItem'@, -- the new definition will override it, but can never remove it. @@ -277,12 +277,21 @@ data Operation = Operation -- A unique parameter is defined by a combination of a name and location. , _operationParameters :: [Referenced Param] + -- | The request body applicable for this operation. + -- The requestBody is only supported in HTTP methods where the HTTP 1.1 + -- specification [RFC7231](https://tools.ietf.org/html/rfc7231#section-4.3.1) + -- has explicitly defined semantics for request bodies. + -- In other cases where the HTTP spec is vague, requestBody SHALL be ignored by consumers. + , _operationRequestBody :: Maybe (Referenced RequestBody) + -- | The list of possible responses as they are returned from executing this operation. , _operationResponses :: Responses - -- | The transfer protocol for the operation. - -- The value overrides @'schemes'@. - , _operationSchemes :: Maybe [Scheme] + -- | A map of possible out-of band callbacks related to the parent operation. + -- The key is a unique identifier for the 'Callback' Object. + -- Each value in the map is a 'Callback' Object that describes a request + -- that may be initiated by the API provider and the expected responses. + , _operationCallbacks :: InsOrdHashMap Text (Referenced Callback) -- | Declares this operation to be deprecated. -- Usage of the declared operation should be refrained. @@ -295,6 +304,126 @@ data Operation = Operation -- This definition overrides any declared top-level security. -- To remove a top-level security declaration, @Just []@ can be used. , _operationSecurity :: [SecurityRequirement] + + -- | An alternative server array to service this operation. + -- If an alternative server object is specified at the 'PathItem' Object or Root level, + -- it will be overridden by this value. + , _operationServers :: [Server] + } deriving (Eq, Show, Generic, Data, Typeable) + +-- This instance should be in @http-media@. +instance Data MediaType where + gunfold k z c = case constrIndex c of + 1 -> k (k (k (z (\main sub params -> foldl (/:) (main // sub) (Map.toList params))))) + _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MediaType." + + toConstr _ = mediaTypeConstr + + dataTypeOf _ = mediaTypeData + +mediaTypeConstr = mkConstr mediaTypeData "MediaType" [] Prefix +mediaTypeData = mkDataType "MediaType" [mediaTypeConstr] + +instance Hashable MediaType where + hashWithSalt salt mt = salt `hashWithSalt` show mt + +-- | Describes a single request body. +data RequestBody = RequestBody + { -- | A brief description of the request body. This could contain examples of use. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. + _requestBodyDescription :: Maybe Text + + -- | The content of the request body. + -- The key is a media type or media type range and the value describes it. + -- For requests that match multiple keys, only the most specific key is applicable. + -- e.g. @text/plain@ overrides @text/*@ + , _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject + + -- | Determines if the request body is required in the request. + -- Defaults to 'False'. + , _requestBodyRequired :: Maybe Bool + } deriving (Eq, Show, Generic, Data, Typeable) + +-- | Each Media Type Object provides schema and examples for the media type identified by its key. +data MediaTypeObject = MediaTypeObject + { _mediaTypeObjectSchema :: Maybe (Referenced Schema) + + -- | Example of the media type. + -- The example object SHOULD be in the correct format as specified by the media type. + , _mediaTypeObjectExample :: Maybe Value + + -- | Examples of the media type. + -- Each example object SHOULD match the media type and specified schema if present. + , _mediaTypeObjectExamples :: InsOrdHashMap Text (Referenced Example) + + -- | A map between a property name and its encoding information. + -- The key, being the property name, MUST exist in the schema as a property. + -- The encoding object SHALL only apply to 'RequestBody' objects when the media type + -- is @multipart@ or @application/x-www-form-urlencoded@. + , _mediaTypeObjectEncoding :: InsOrdHashMap Text Encoding + } deriving (Eq, Show, Generic, Data, Typeable) + +-- | In order to support common ways of serializing simple parameters, a set of style values are defined. +data Style + = StyleMatrix + -- ^ Path-style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + | StyleLabel + -- ^ Label style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + | StyleForm + -- ^ Form style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + -- This option replaces @collectionFormat@ with a @csv@ (when @explode@ is false) or @multi@ + -- (when explode is true) value from OpenAPI 2.0. + | StyleSimple + -- ^ Simple style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7). + -- This option replaces @collectionFormat@ with a @csv@ value from OpenAPI 2.0. + | StyleSpaceDelimited + -- ^ Space separated array values. + -- This option replaces @collectionFormat@ equal to @ssv@ from OpenAPI 2.0. + | StylePipeDelimited + -- ^ Pipe separated array values. + -- This option replaces @collectionFormat@ equal to @pipes@ from OpenAPI 2.0. + | StyleDeepObject + -- ^ Provides a simple way of rendering nested objects using form parameters. + deriving (Eq, Show, Generic, Data, Typeable) + +data Encoding = Encoding + { -- | The Content-Type for encoding a specific property. + -- Default value depends on the property type: for @string@ + -- with format being @binary@ – @application/octet-stream@; + -- for other primitive types – @text/plain@; for object - @application/json@; + -- for array – the default is defined based on the inner type. + -- The value can be a specific media type (e.g. @application/json@), + -- a wildcard media type (e.g. @image/*@), or a comma-separated list of the two types. + _encodingContentType :: Maybe MediaType + + -- | A map allowing additional information to be provided as headers, + -- for example @Content-Disposition@. @Content-Type@ is described separately + -- and SHALL be ignored in this section. + -- This property SHALL be ignored if the request body media type is not a @multipart@. + , _encodingHeaders :: InsOrdHashMap Text (Referenced Header) + + -- | Describes how a specific property value will be serialized depending on its type. + -- See 'Param' Object for details on the style property. + -- The behavior follows the same values as query parameters, including default values. + -- This property SHALL be ignored if the request body media type + -- is not @application/x-www-form-urlencoded@. + , _encodingStyle :: Maybe Style + + -- | When this is true, property values of type @array@ or @object@ generate + -- separate parameters for each value of the array, + -- or key-value-pair of the map. + -- For other types of properties this property has no effect. + -- When style is form, the default value is @true@. For all other styles, + -- the default value is @false@. This property SHALL be ignored + -- if the request body media type is not @application/x-www-form-urlencoded@. + , _encodingExplode :: Maybe Bool + + -- | Determines whether the parameter value SHOULD allow reserved characters, + -- as defined by [RFC3986](https://tools.ietf.org/html/rfc3986#section-2.2) + -- @:/?#[]@!$&'()*+,;=@ to be included without percent-encoding. + -- The default value is @false@. This property SHALL be ignored if the request body media type + -- is not @application/x-www-form-urlencoded@. + , _encodingAllowReserved :: Maybe Bool } deriving (Eq, Show, Generic, Data, Typeable) newtype MimeList = MimeList { getMimeList :: [MediaType] } @@ -322,7 +451,7 @@ data Param = Param -- | A brief description of the parameter. -- This could contain examples of use. - -- GFM syntax can be used for rich text representation. + -- CommonMark syntax MAY be used for rich text representation. , _paramDescription :: Maybe Text -- | Determines whether this parameter is mandatory. @@ -330,159 +459,141 @@ data Param = Param -- Otherwise, the property MAY be included and its default value is @False@. , _paramRequired :: Maybe Bool - -- | Parameter schema. - , _paramSchema :: ParamAnySchema - } deriving (Eq, Show, Generic, Data, Typeable) + -- | Specifies that a parameter is deprecated and SHOULD be transitioned out of usage. + -- Default value is @false@. + , _paramDeprecated :: Maybe Bool -data ParamAnySchema - = ParamBody (Referenced Schema) - | ParamOther ParamOtherSchema - deriving (Eq, Show, Generic, Data, Typeable) - -data ParamOtherSchema = ParamOtherSchema - { -- | The location of the parameter. - _paramOtherSchemaIn :: ParamLocation + -- | The location of the parameter. + , _paramIn :: ParamLocation -- | Sets the ability to pass empty-valued parameters. - -- This is valid only for either @'ParamQuery'@ or @'ParamFormData'@ - -- and allows you to send a parameter with a name only or an empty value. - -- Default value is @False@. - , _paramOtherSchemaAllowEmptyValue :: Maybe Bool + -- This is valid only for 'ParamQuery' parameters and allows sending + -- a parameter with an empty value. Default value is @false@. + , _paramAllowEmptyValue :: Maybe Bool + + -- | Determines whether the parameter value SHOULD allow reserved characters, + -- as defined by [RFC3986](https://tools.ietf.org/html/rfc3986#section-2.2) + -- @:/?#[]@!$&'()*+,;=@ to be included without percent-encoding. + -- This property only applies to parameters with an '_paramIn' value of 'ParamQuery'. + -- The default value is 'False'. + , _paramAllowReserved :: Maybe Bool + + -- | Parameter schema. + , _paramSchema :: Maybe (Referenced Schema) + + -- | Describes how the parameter value will be serialized depending + -- on the type of the parameter value. Default values (based on value of '_paramIn'): + -- for 'ParamQuery' - 'StyleForm'; for 'ParamPath' - 'StyleSimple'; for 'ParamHeader' - 'StyleSimple'; + -- for 'ParamCookie' - 'StyleForm'. + , _paramStyle :: Maybe Style + + -- | When this is true, parameter values of type @array@ or @object@ + -- generate separate parameters for each value of the array or key-value pair of the map. + -- For other types of parameters this property has no effect. + -- When style is @form@, the default value is true. For all other styles, the default value is false. + , _paramExplode :: Maybe Bool + + -- | Example of the parameter's potential value. + -- The example SHOULD match the specified schema and encoding properties if present. + -- The '_paramExample' field is mutually exclusive of the '_paramExamples' field. + -- Furthermore, if referencing a schema that contains an example, the example value + -- SHALL override the example provided by the schema. To represent examples of media types + -- that cannot naturally be represented in JSON or YAML, a string value can contain + -- the example with escaping where necessary. + , _paramExample :: Maybe Value + + -- | Examples of the parameter's potential value. + -- Each example SHOULD contain a value in the correct format as specified + -- in the parameter encoding. The '_paramExamples' field is mutually exclusive of the '_paramExample' field. + -- Furthermore, if referencing a schema that contains an example, + -- the examples value SHALL override the example provided by the schema. + , _paramExamples :: InsOrdHashMap Text (Referenced Example) + + -- TODO + -- _paramContent :: InsOrdHashMap MediaType MediaTypeObject + -- should be singleton. mutually exclusive with _paramSchema. + } deriving (Eq, Show, Generic, Data, Typeable) + +data Example = Example + { -- | Short description for the example. + _exampleSummary :: Maybe Text + + -- | Long description for the example. + -- CommonMark syntax MAY be used for rich text representation. + , _exampleDescription :: Maybe Text + + -- | Embedded literal example. + -- The '_exampleValue' field and '_exampleExternalValue' field are mutually exclusive. + -- + -- To represent examples of media types that cannot naturally represented in JSON or YAML, + -- use a string value to contain the example, escaping where necessary. + , _exampleValue :: Maybe Value + + -- | A URL that points to the literal example. + -- This provides the capability to reference examples that cannot easily be included + -- in JSON or YAML documents. The '_exampleValue' field + -- and '_exampleExternalValue' field are mutually exclusive. + , _exampleExternalValue :: Maybe URL + } deriving (Eq, Show, Generic, Typeable, Data) - , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema +data ExpressionOrValue + = Expression Text + | Value Value + deriving (Eq, Show, Generic, Typeable, Data) + +-- | The Link object represents a possible design-time link for a response. +-- The presence of a link does not guarantee the caller's ability to successfully invoke it, +-- rather it provides a known relationship and traversal mechanism between responses and other operations. +data Link = Link + { -- | A relative or absolute URI reference to an OAS operation. + -- This field is mutually exclusive of the '_linkOperationId' field, + -- and MUST point to an 'Operation' Object. Relative '_linkOperationRef' + -- values MAY be used to locate an existing 'Operation' Object in the OpenAPI definition. + _linkOperationRef :: Maybe Text + + -- | The name of an /existing/, resolvable OAS operation, as defined with a unique + -- '_operationOperationId'. This field is mutually exclusive of the '_linkOperationRef' field. + , _linkOperationId :: Maybe Text + + -- | A map representing parameters to pass to an operation as specified with '_linkOperationId' + -- or identified via '_linkOperationRef'. The key is the parameter name to be used, whereas + -- the value can be a constant or an expression to be evaluated and passed to the linked operation. + -- The parameter name can be qualified using the parameter location @[{in}.]{name}@ + -- for operations that use the same parameter name in different locations (e.g. path.id). + , _linkParameters :: InsOrdHashMap Text ExpressionOrValue + + -- | A literal value or @{expression}@ to use as a request body when calling the target operation. + , _linkRequestBody :: Maybe ExpressionOrValue + + -- | A description of the link. + , _linkDescription :: Maybe Text + + -- | A server object to be used by the target operation. + , _linkServer :: Maybe Server } deriving (Eq, Show, Generic, Typeable, Data) -- | Items for @'SwaggerArray'@ schemas. -- --- @'SwaggerItemsPrimitive'@ should be used only for query params, headers and path pieces. --- The @'CollectionFormat' t@ parameter specifies how elements of an array should be displayed. --- Note that @fmt@ in @'SwaggerItemsPrimitive' fmt schema@ specifies format for elements of type @schema@. --- This is different from the original Swagger's . +-- __Warning__: OpenAPI 3.0 does not support tuple arrays. However, OpenAPI 3.1 will, as +-- it will incorporate Json Schema mostly verbatim. -- -- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s. -- -- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s. -data SwaggerItems t where - SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k - SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema - SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema - deriving (Typeable) - -deriving instance Eq (SwaggerItems t) -deriving instance Show (SwaggerItems t) ---deriving instance Typeable (SwaggerItems t) - -swaggerItemsPrimitiveConstr :: Constr -swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix - -swaggerItemsObjectConstr :: Constr -swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix - -swaggerItemsArrayConstr :: Constr -swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix - -swaggerItemsDataType :: DataType -swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr] - --- Note: unfortunately we have to write these Data instances by hand, --- to get better contexts / avoid duplicate name when using standalone deriving - -instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where - -- TODO: define gfoldl - 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)." - toConstr _ = swaggerItemsPrimitiveConstr - dataTypeOf _ = swaggerItemsDataType - --- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only -instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where - -- TODO: define gfoldl - 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 SwaggerKindParamOtherSchema)." - toConstr _ = swaggerItemsPrimitiveConstr - dataTypeOf _ = swaggerItemsDataType - -instance Data (SwaggerItems 'SwaggerKindSchema) where - gfoldl _ _ (SwaggerItemsPrimitive _ _) = error " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema" - gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref - gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref - - gunfold k z c = case constrIndex c of - 2 -> k (z SwaggerItemsObject) - 3 -> k (z SwaggerItemsArray) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)." - - toConstr (SwaggerItemsPrimitive _ _) = error "Not supported" - toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr - toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr - - dataTypeOf _ = swaggerItemsDataType - --- | Type used as a kind to avoid overlapping instances. -data SwaggerKind t - = SwaggerKindNormal t - | SwaggerKindParamOtherSchema - | SwaggerKindSchema - deriving (Typeable) - -deriving instance Typeable 'SwaggerKindNormal -deriving instance Typeable 'SwaggerKindParamOtherSchema -deriving instance Typeable 'SwaggerKindSchema - -type family SwaggerKindType (k :: SwaggerKind *) :: * -type instance SwaggerKindType ('SwaggerKindNormal t) = t -type instance SwaggerKindType 'SwaggerKindSchema = Schema -type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema - -data SwaggerType t where - SwaggerString :: SwaggerType t - SwaggerNumber :: SwaggerType t - SwaggerInteger :: SwaggerType t - SwaggerBoolean :: SwaggerType t - SwaggerArray :: SwaggerType t - SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema - SwaggerNull :: SwaggerType 'SwaggerKindSchema - SwaggerObject :: SwaggerType 'SwaggerKindSchema - deriving (Typeable) - -deriving instance Eq (SwaggerType t) -deriving instance Show (SwaggerType t) - -swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr -swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix - -swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType -swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs - -swaggerCommonTypes :: [SwaggerType k] -swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray] - -swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema] -swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile] - -swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema] -swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject] - -swaggerTypeConstrs :: [Constr] -swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema]) - ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject] - -instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where - gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes - toConstr = swaggerTypeConstr - dataTypeOf = swaggerTypeDataType - -instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where - gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes - toConstr = swaggerTypeConstr - dataTypeOf = swaggerTypeDataType - -instance Data (SwaggerType 'SwaggerKindSchema) where - gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes - toConstr = swaggerTypeConstr - dataTypeOf = swaggerTypeDataType +data SwaggerItems where + SwaggerItemsObject :: Referenced Schema -> SwaggerItems + SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems + deriving (Eq, Show, Typeable, Data) + +data SwaggerType where + SwaggerString :: SwaggerType + SwaggerNumber :: SwaggerType + SwaggerInteger :: SwaggerType + SwaggerBoolean :: SwaggerType + SwaggerArray :: SwaggerType + SwaggerNull :: SwaggerType + SwaggerObject :: SwaggerType + deriving (Eq, Show, Typeable, Generic, Data) data ParamLocation = -- | Parameters that are appended to the URL. @@ -494,54 +605,12 @@ data ParamLocation -- This does not include the host or base path of the API. -- For example, in @/items/{itemId}@, the path parameter is @itemId@. | ParamPath - -- | Used to describe the payload of an HTTP request when either @application/x-www-form-urlencoded@ - -- or @multipart/form-data@ are used as the content type of the request - -- (in Swagger's definition, the @consumes@ property of an operation). - -- This is the only parameter type that can be used to send files, thus supporting the @'ParamFile'@ type. - -- Since form parameters are sent in the payload, they cannot be declared together with a body parameter for the same operation. - -- Form parameters have a different format based on the content-type used - -- (for further details, consult ). - | ParamFormData + -- | Used to pass a specific cookie value to the API. + | ParamCookie deriving (Eq, Show, Generic, Data, Typeable) type Format = Text --- | Determines the format of the array. -data CollectionFormat t where - -- Comma separated values: @foo,bar@. - CollectionCSV :: CollectionFormat t - -- Space separated values: @foo bar@. - CollectionSSV :: CollectionFormat t - -- Tab separated values: @foo\\tbar@. - CollectionTSV :: CollectionFormat t - -- Pipe separated values: @foo|bar@. - CollectionPipes :: CollectionFormat t - -- Corresponds to multiple parameter instances - -- instead of multiple values for a single instance @foo=bar&foo=baz@. - -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@. - CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema - deriving (Typeable) - -deriving instance Eq (CollectionFormat t) -deriving instance Show (CollectionFormat t) - -collectionFormatConstr :: CollectionFormat t -> Constr -collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix - -collectionFormatDataType :: DataType -collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $ - map collectionFormatConstr collectionCommonFormats - -collectionCommonFormats :: [CollectionFormat t] -collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ] - -instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where - gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats - toConstr = collectionFormatConstr - dataTypeOf _ = collectionFormatDataType - -deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema) - type ParamName = Text data Schema = Schema @@ -549,20 +618,58 @@ data Schema = Schema , _schemaDescription :: Maybe Text , _schemaRequired :: [ParamName] + , _schemaNullable :: Maybe Bool , _schemaAllOf :: Maybe [Referenced Schema] + , _schemaOneOf :: Maybe [Referenced Schema] + , _schemaNot :: Maybe (Referenced Schema) + , _schemaAnyOf :: Maybe [Referenced Schema] , _schemaProperties :: InsOrdHashMap Text (Referenced Schema) , _schemaAdditionalProperties :: Maybe AdditionalProperties - , _schemaDiscriminator :: Maybe Text + , _schemaDiscriminator :: Maybe Discriminator , _schemaReadOnly :: Maybe Bool + , _schemaWriteOnly :: Maybe Bool , _schemaXml :: Maybe Xml , _schemaExternalDocs :: Maybe ExternalDocs , _schemaExample :: Maybe Value + , _schemaDeprecated :: Maybe Bool , _schemaMaxProperties :: Maybe Integer , _schemaMinProperties :: Maybe Integer - , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema + , -- | Declares the value of the parameter that the server will use if none is provided, + -- for example a @"count"@ to control the number of results per page might default to @100@ + -- if not supplied by the client in the request. + -- (Note: "default" has no meaning for required parameters.) + -- Unlike JSON Schema this value MUST conform to the defined type for this parameter. + _schemaDefault :: Maybe Value + + , _schemaType :: Maybe SwaggerType + , _schemaFormat :: Maybe Format + , _schemaItems :: Maybe SwaggerItems + , _schemaMaximum :: Maybe Scientific + , _schemaExclusiveMaximum :: Maybe Bool + , _schemaMinimum :: Maybe Scientific + , _schemaExclusiveMinimum :: Maybe Bool + , _schemaMaxLength :: Maybe Integer + , _schemaMinLength :: Maybe Integer + , _schemaPattern :: Maybe Pattern + , _schemaMaxItems :: Maybe Integer + , _schemaMinItems :: Maybe Integer + , _schemaUniqueItems :: Maybe Bool + , _schemaEnum :: Maybe [Value] + , _schemaMultipleOf :: Maybe Scientific + } deriving (Eq, Show, Generic, Data, Typeable) + +-- | Regex pattern for @string@ type. +type Pattern = Text + +data Discriminator = Discriminator + { -- | The name of the property in the payload that will hold the discriminator value. + _discriminatorPropertyName :: Text + + -- | An object to hold mappings between payload values and schema names or references. + , _discriminatorMapping :: InsOrdHashMap Text Text } deriving (Eq, Show, Generic, Data, Typeable) -- | A @'Schema'@ with an optional name. @@ -572,36 +679,6 @@ data NamedSchema = NamedSchema , _namedSchemaSchema :: Schema } deriving (Eq, Show, Generic, Data, Typeable) --- | Regex pattern for @string@ type. -type Pattern = Text - -data ParamSchema (t :: SwaggerKind *) = ParamSchema - { -- | Declares the value of the parameter that the server will use if none is provided, - -- for example a @"count"@ to control the number of results per page might default to @100@ - -- if not supplied by the client in the request. - -- (Note: "default" has no meaning for required parameters.) - -- Unlike JSON Schema this value MUST conform to the defined type for this parameter. - _paramSchemaDefault :: Maybe Value - - , _paramSchemaType :: Maybe (SwaggerType t) - , _paramSchemaFormat :: Maybe Format - , _paramSchemaItems :: Maybe (SwaggerItems t) - , _paramSchemaMaximum :: Maybe Scientific - , _paramSchemaExclusiveMaximum :: Maybe Bool - , _paramSchemaMinimum :: Maybe Scientific - , _paramSchemaExclusiveMinimum :: Maybe Bool - , _paramSchemaMaxLength :: Maybe Integer - , _paramSchemaMinLength :: Maybe Integer - , _paramSchemaPattern :: Maybe Pattern - , _paramSchemaMaxItems :: Maybe Integer - , _paramSchemaMinItems :: Maybe Integer - , _paramSchemaUniqueItems :: Maybe Bool - , _paramSchemaEnum :: Maybe [Value] - , _paramSchemaMultipleOf :: Maybe Scientific - } deriving (Eq, Show, Generic, Typeable) - -deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k) - data Xml = Xml { -- | Replaces the name of the element/attribute used for the described schema property. -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list. @@ -650,55 +727,59 @@ type HttpStatusCode = Int -- | Describes a single response from an API Operation. data Response = Response { -- | A short description of the response. - -- GFM syntax can be used for rich text representation. + -- [CommonMark syntax](https://spec.commonmark.org/) can be used for rich text representation. _responseDescription :: Text - -- | A definition of the response structure. - -- It can be a primitive, an array or an object. - -- If this field does not exist, it means no content is returned as part of the response. - -- As an extension to the Schema Object, its root type value may also be "file". - -- This SHOULD be accompanied by a relevant produces mime-type. - , _responseSchema :: Maybe (Referenced Schema) + -- | A map containing descriptions of potential response payloads. + -- The key is a media type or media type range and the value describes it. + -- For responses that match multiple keys, only the most specific key is applicable. + -- e.g. @text/plain@ overrides @text/*@. + , _responseContent :: InsOrdHashMap MediaType MediaTypeObject - -- | A list of headers that are sent with the response. - , _responseHeaders :: InsOrdHashMap HeaderName Header + -- | Maps a header name to its definition. + , _responseHeaders :: InsOrdHashMap HeaderName (Referenced Header) - -- | An example of the response message. - , _responseExamples :: Maybe Example + -- | A map of operations links that can be followed from the response. + -- The key of the map is a short name for the link, following the naming + -- constraints of the names for 'Component' Objects. + , _responseLinks :: InsOrdHashMap Text (Referenced Link) } deriving (Eq, Show, Generic, Data, Typeable) instance IsString Response where - fromString s = Response (fromString s) Nothing mempty Nothing + fromString s = Response (fromString s) mempty mempty mempty + +-- | A map of possible out-of band callbacks related to the parent operation. +-- Each value in the map is a 'PathItem' Object that describes a set of requests that +-- may be initiated by the API provider and the expected responses. +-- The key value used to identify the path item object is an expression, evaluated at runtime, +-- that identifies a URL to use for the callback operation. +newtype Callback = Callback (InsOrdHashMap Text PathItem) + deriving (Eq, Show, Generic, Data, Typeable) type HeaderName = Text +-- | Header fields have the same meaning as for 'Param'. +-- +-- Style is always treated as 'StyleSimple', as it is the only value allowed for headers. data Header = Header { -- | A short description of the header. - _headerDescription :: Maybe Text - - , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header) - } deriving (Eq, Show, Generic, Data, Typeable) + _headerDescription :: Maybe HeaderName -data Example = Example { getExample :: Map MediaType Value } - deriving (Eq, Show, Generic, Typeable) + , _headerRequired :: Maybe Bool + , _headerDeprecated :: Maybe Bool + , _headerAllowEmptyValue :: Maybe Bool + , _headerExplode :: Maybe Bool + , _headerExample :: Maybe Value + , _headerExamples :: InsOrdHashMap Text (Referenced Example) -exampleConstr :: Constr -exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix - -exampleDataType :: DataType -exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr] - -instance Data Example where - gunfold k z c = case constrIndex c of - 1 -> k (z (\m -> Example (Map.mapKeys fromString m))) - _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Example." - toConstr (Example _) = exampleConstr - dataTypeOf _ = exampleDataType + , _headerSchema :: Maybe (Referenced Schema) + } deriving (Eq, Show, Generic, Data, Typeable) -- | The location of the API key. data ApiKeyLocation = ApiKeyQuery | ApiKeyHeader + | ApiKeyCookie deriving (Eq, Show, Generic, Data, Typeable) data ApiKeyParams = ApiKeyParams @@ -715,25 +796,54 @@ type AuthorizationURL = Text -- | The token URL to be used for OAuth2 flow. This SHOULD be in the form of a URL. type TokenURL = Text -data OAuth2Flow - = OAuth2Implicit AuthorizationURL - | OAuth2Password TokenURL - | OAuth2Application TokenURL - | OAuth2AccessCode AuthorizationURL TokenURL - deriving (Eq, Show, Generic, Data, Typeable) +data OAuth2ImplicitFlow = OAuth2ImplicitFlow + { _oAuth2ImplicitFlowAuthorizationUrl :: AuthorizationURL + } deriving (Eq, Show, Generic, Data, Typeable) + +data OAuth2PasswordFlow = OAuth2PasswordFlow + { _oAuth2PasswordFlowTokenUrl :: TokenURL + } deriving (Eq, Show, Generic, Data, Typeable) + +data OAuth2ClientCredentialsFlow = OAuth2ClientCredentialsFlow + { _oAuth2ClientCredentialsFlowTokenUrl :: TokenURL + } deriving (Eq, Show, Generic, Data, Typeable) -data OAuth2Params = OAuth2Params - { -- | The flow used by the OAuth2 security scheme. - _oauth2Flow :: OAuth2Flow +data OAuth2AuthorizationCodeFlow = OAuth2AuthorizationCodeFlow + { _oAuth2AuthorizationCodeFlowAuthorizationUrl :: AuthorizationURL + , _oAuth2AuthorizationCodeFlowTokenUrl :: TokenURL + } deriving (Eq, Show, Generic, Data, Typeable) + +data OAuth2Flow p = OAuth2Flow + { _oAuth2Params :: p + + -- | The URL to be used for obtaining refresh tokens. + , _oAath2RefreshUrl :: Maybe URL -- | The available scopes for the OAuth2 security scheme. - , _oauth2Scopes :: InsOrdHashMap Text Text + -- A map between the scope name and a short description for it. + -- The map MAY be empty. + , _oAuth2Scopes :: InsOrdHashMap Text Text + } deriving (Eq, Show, Generic, Data, Typeable) + +data OAuth2Flows = OAuth2Flows + { -- | Configuration for the OAuth Implicit flow + _oAuth2FlowsImplicit :: Maybe (OAuth2Flow OAuth2ImplicitFlow) + + -- | Configuration for the OAuth Resource Owner Password flow + , _oAuth2FlowsPassword :: Maybe (OAuth2Flow OAuth2PasswordFlow) + + -- | Configuration for the OAuth Client Credentials flow + , _oAuth2FlowsClientCredentials :: Maybe (OAuth2Flow OAuth2ClientCredentialsFlow) + + -- | Configuration for the OAuth Authorization Code flow + , _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow) } deriving (Eq, Show, Generic, Data, Typeable) data SecuritySchemeType - = SecuritySchemeBasic + = SecuritySchemeHttp | SecuritySchemeApiKey ApiKeyParams - | SecuritySchemeOAuth2 OAuth2Params + | SecuritySchemeOAuth2 OAuth2Flows + | SecuritySchemeOpenIdConnect URL deriving (Eq, Show, Generic, Data, Typeable) data SecurityScheme = SecurityScheme @@ -744,18 +854,6 @@ data SecurityScheme = SecurityScheme , _securitySchemeDescription :: Maybe Text } deriving (Eq, Show, Generic, Data, Typeable) - --- | merge scopes of two OAuth2 security schemes when their flows are identical. --- In other case returns first security scheme -mergeSecurityScheme :: SecurityScheme -> SecurityScheme -> SecurityScheme -mergeSecurityScheme s1@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 scopes1)) desc) - s2@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow2 scopes2)) _) - = if flow1 == flow2 then - SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 (scopes1 <> scopes2))) desc - else - s1 -mergeSecurityScheme s1 _ = s1 - newtype SecurityDefinitions = SecurityDefinitions (Definitions SecurityScheme) deriving (Eq, Show, Generic, Data, Typeable) @@ -777,7 +875,7 @@ data Tag = Tag _tagName :: TagName -- | A short description for the tag. - -- GFM syntax can be used for rich text representation. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. , _tagDescription :: Maybe Text -- | Additional external documentation for this tag. @@ -792,7 +890,7 @@ instance IsString Tag where -- | Allows referencing an external resource for extended documentation. data ExternalDocs = ExternalDocs { -- | A short description of the target documentation. - -- GFM syntax can be used for rich text representation. + -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. _externalDocsDescription :: Maybe Text -- | The URL for the target documentation. @@ -825,18 +923,24 @@ data AdditionalProperties -- Generic instances ------------------------------------------------------------------------------- +deriveGeneric ''Server +deriveGeneric ''Components deriveGeneric ''Header -deriveGeneric ''OAuth2Params +deriveGeneric ''OAuth2Flow +deriveGeneric ''OAuth2Flows deriveGeneric ''Operation deriveGeneric ''Param -deriveGeneric ''ParamOtherSchema deriveGeneric ''PathItem deriveGeneric ''Response +deriveGeneric ''RequestBody +deriveGeneric ''MediaTypeObject deriveGeneric ''Responses deriveGeneric ''SecurityScheme deriveGeneric ''Schema -deriveGeneric ''ParamSchema deriveGeneric ''Swagger +deriveGeneric ''Example +deriveGeneric ''Encoding +deriveGeneric ''Link -- ======================================================================= -- Monoid instances @@ -860,21 +964,21 @@ instance Monoid Contact where mempty = genericMempty mappend = (<>) -instance Semigroup PathItem where +instance Semigroup Components where (<>) = genericMappend -instance Monoid PathItem where +instance Monoid Components where mempty = genericMempty mappend = (<>) -instance Semigroup Schema where +instance Semigroup PathItem where (<>) = genericMappend -instance Monoid Schema where +instance Monoid PathItem where mempty = genericMempty mappend = (<>) -instance Semigroup (ParamSchema t) where +instance Semigroup Schema where (<>) = genericMappend -instance Monoid (ParamSchema t) where +instance Monoid Schema where mempty = genericMempty mappend = (<>) @@ -884,12 +988,6 @@ instance Monoid Param where mempty = genericMempty mappend = (<>) -instance Semigroup ParamOtherSchema where - (<>) = genericMappend -instance Monoid ParamOtherSchema where - mempty = genericMempty - mappend = (<>) - instance Semigroup Header where (<>) = genericMappend instance Monoid Header where @@ -908,6 +1006,18 @@ instance Monoid Response where mempty = genericMempty mappend = (<>) +instance Semigroup MediaTypeObject where + (<>) = genericMappend +instance Monoid MediaTypeObject where + mempty = genericMempty + mappend = (<>) + +instance Semigroup Encoding where + (<>) = genericMappend +instance Monoid Encoding where + mempty = genericMempty + mappend = (<>) + instance Semigroup ExternalDocs where (<>) = genericMappend instance Monoid ExternalDocs where @@ -920,14 +1030,29 @@ instance Monoid Operation where mempty = genericMempty mappend = (<>) -instance Semigroup Example where - (<>) = genericMappend -instance Monoid Example where +instance Semigroup (OAuth2Flow p) where + l@OAuth2Flow{ _oAath2RefreshUrl = lUrl, _oAuth2Scopes = lScopes } + <> OAuth2Flow { _oAath2RefreshUrl = rUrl, _oAuth2Scopes = rScopes } = + l { _oAath2RefreshUrl = swaggerMappend lUrl rUrl, _oAuth2Scopes = lScopes <> rScopes } + +-- swaggerMappend has First-like semantics, and here we need mappend'ing under Maybes. +instance Semigroup OAuth2Flows where + l <> r = OAuth2Flows + { _oAuth2FlowsImplicit = _oAuth2FlowsImplicit l <> _oAuth2FlowsImplicit r + , _oAuth2FlowsPassword = _oAuth2FlowsPassword l <> _oAuth2FlowsPassword r + , _oAuth2FlowsClientCredentials = _oAuth2FlowsClientCredentials l <> _oAuth2FlowsClientCredentials r + , _oAuth2FlowsAuthorizationCode = _oAuth2FlowsAuthorizationCode l <> _oAuth2FlowsAuthorizationCode r + } + +instance Monoid OAuth2Flows where mempty = genericMempty mappend = (<>) instance Semigroup SecurityScheme where - (<>) = mergeSecurityScheme + SecurityScheme (SecuritySchemeOAuth2 lFlows) lDesc + <> SecurityScheme (SecuritySchemeOAuth2 rFlows) rDesc = + SecurityScheme (SecuritySchemeOAuth2 $ lFlows <> rFlows) (swaggerMappend lDesc rDesc) + l <> _ = l instance Semigroup SecurityDefinitions where (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) = @@ -937,27 +1062,31 @@ instance Monoid SecurityDefinitions where mempty = SecurityDefinitions InsOrdHashMap.empty mappend = (<>) +instance Semigroup RequestBody where + (<>) = genericMappend +instance Monoid RequestBody where + mempty = genericMempty + mappend = (<>) + -- ======================================================================= -- SwaggerMonoid helper instances -- ======================================================================= instance SwaggerMonoid Info +instance SwaggerMonoid Components instance SwaggerMonoid PathItem instance SwaggerMonoid Schema -instance SwaggerMonoid (ParamSchema t) instance SwaggerMonoid Param -instance SwaggerMonoid ParamOtherSchema instance SwaggerMonoid Responses instance SwaggerMonoid Response instance SwaggerMonoid ExternalDocs instance SwaggerMonoid Operation -instance SwaggerMonoid SecurityDefinitions instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a) instance SwaggerMonoid MimeList deriving instance SwaggerMonoid URL -instance SwaggerMonoid (SwaggerType t) where +instance SwaggerMonoid SwaggerType where swaggerMempty = SwaggerString swaggerMappend _ y = y @@ -974,16 +1103,16 @@ instance Monoid a => SwaggerMonoid (Referenced a) where swaggerMappend (Inline x) (Inline y) = Inline (mappend x y) swaggerMappend _ y = y -instance SwaggerMonoid ParamAnySchema where - swaggerMempty = ParamOther swaggerMempty - swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y) - swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y) - swaggerMappend _ y = y - -- ======================================================================= -- Simple Generic-based ToJSON instances -- ======================================================================= +instance ToJSON Style where + toJSON = genericToJSON (jsonPrefix "Style") + +instance ToJSON SwaggerType where + toJSON = genericToJSON (jsonPrefix "Swagger") + instance ToJSON ParamLocation where toJSON = genericToJSON (jsonPrefix "Param") @@ -996,15 +1125,15 @@ instance ToJSON Contact where instance ToJSON License where toJSON = genericToJSON (jsonPrefix "License") +instance ToJSON ServerVariable where + toJSON = genericToJSON (jsonPrefix "ServerVariable") + instance ToJSON ApiKeyLocation where toJSON = genericToJSON (jsonPrefix "ApiKey") instance ToJSON ApiKeyParams where toJSON = genericToJSON (jsonPrefix "apiKey") -instance ToJSON Scheme where - toJSON = genericToJSON (jsonPrefix "") - instance ToJSON Tag where toJSON = genericToJSON (jsonPrefix "Tag") @@ -1014,10 +1143,31 @@ instance ToJSON ExternalDocs where instance ToJSON Xml where toJSON = genericToJSON (jsonPrefix "Xml") +instance ToJSON Discriminator where + toJSON = genericToJSON (jsonPrefix "Discriminator") + +instance ToJSON OAuth2ImplicitFlow where + toJSON = genericToJSON (jsonPrefix "OAuth2ImplicitFlow") + +instance ToJSON OAuth2PasswordFlow where + toJSON = genericToJSON (jsonPrefix "OAuth2PasswordFlow") + +instance ToJSON OAuth2ClientCredentialsFlow where + toJSON = genericToJSON (jsonPrefix "OAuth2ClientCredentialsFlow") + +instance ToJSON OAuth2AuthorizationCodeFlow where + toJSON = genericToJSON (jsonPrefix "OAuth2AuthorizationCodeFlow") + -- ======================================================================= -- Simple Generic-based FromJSON instances -- ======================================================================= +instance FromJSON Style where + parseJSON = genericParseJSON (jsonPrefix "Style") + +instance FromJSON SwaggerType where + parseJSON = genericParseJSON (jsonPrefix "Swagger") + instance FromJSON ParamLocation where parseJSON = genericParseJSON (jsonPrefix "Param") @@ -1030,53 +1180,69 @@ instance FromJSON Contact where instance FromJSON License where parseJSON = genericParseJSON (jsonPrefix "License") +instance FromJSON ServerVariable where + parseJSON = genericParseJSON (jsonPrefix "ServerVariable") + instance FromJSON ApiKeyLocation where parseJSON = genericParseJSON (jsonPrefix "ApiKey") instance FromJSON ApiKeyParams where parseJSON = genericParseJSON (jsonPrefix "apiKey") -instance FromJSON Scheme where - parseJSON = genericParseJSON (jsonPrefix "") - instance FromJSON Tag where parseJSON = genericParseJSON (jsonPrefix "Tag") instance FromJSON ExternalDocs where parseJSON = genericParseJSON (jsonPrefix "ExternalDocs") +instance FromJSON Discriminator where + parseJSON = genericParseJSON (jsonPrefix "Discriminator") + +instance FromJSON OAuth2ImplicitFlow where + parseJSON = genericParseJSON (jsonPrefix "OAuth2ImplicitFlow") + +instance FromJSON OAuth2PasswordFlow where + parseJSON = genericParseJSON (jsonPrefix "OAuth2PasswordFlow") + +instance FromJSON OAuth2ClientCredentialsFlow where + parseJSON = genericParseJSON (jsonPrefix "OAuth2ClientCredentialsFlow") + +instance FromJSON OAuth2AuthorizationCodeFlow where + parseJSON = genericParseJSON (jsonPrefix "OAuth2AuthorizationCodeFlow") + -- ======================================================================= -- Manual ToJSON instances -- ======================================================================= -instance ToJSON OAuth2Flow where - toJSON (OAuth2Implicit authUrl) = object - [ "flow" .= ("implicit" :: Text) - , "authorizationUrl" .= authUrl ] - toJSON (OAuth2Password tokenUrl) = object - [ "flow" .= ("password" :: Text) - , "tokenUrl" .= tokenUrl ] - toJSON (OAuth2Application tokenUrl) = object - [ "flow" .= ("application" :: Text) - , "tokenUrl" .= tokenUrl ] - toJSON (OAuth2AccessCode authUrl tokenUrl) = object - [ "flow" .= ("accessCode" :: Text) - , "authorizationUrl" .= authUrl - , "tokenUrl" .= tokenUrl ] - -instance ToJSON OAuth2Params where +instance ToJSON MediaType where + toJSON = toJSON . show + toEncoding = toEncoding . show + +instance ToJSONKey MediaType where + toJSONKey = JSON.toJSONKeyText (Text.pack . show) + +instance (Eq p, ToJSON p, AesonDefaultValue p) => ToJSON (OAuth2Flow p) where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON OAuth2Flows where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding instance ToJSON SecuritySchemeType where - toJSON SecuritySchemeBasic - = object [ "type" .= ("basic" :: Text) ] + toJSON SecuritySchemeHttp + = object [ "type" .= ("http" :: Text) ] toJSON (SecuritySchemeApiKey params) = toJSON params <+> object [ "type" .= ("apiKey" :: Text) ] - toJSON (SecuritySchemeOAuth2 params) - = toJSON params - <+> object [ "type" .= ("oauth2" :: Text) ] + toJSON (SecuritySchemeOAuth2 params) = object + [ "type" .= ("oauth2" :: Text) + , "flows" .= toJSON params + ] + toJSON (SecuritySchemeOpenIdConnect url) = object + [ "type" .= ("openIdConnect" :: Text) + , "openIdConnectUrl" .= url + ] instance ToJSON Swagger where toJSON a = sopSwaggerGenericToJSON a & @@ -1085,14 +1251,18 @@ instance ToJSON Swagger where else id toEncoding = sopSwaggerGenericToEncoding -instance ToJSON SecurityScheme where +instance ToJSON Server where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding -instance ToJSON Schema where +instance ToJSON SecurityScheme where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON Schema where + toJSON = sopSwaggerGenericToJSONWithOpts $ + mkSwaggerAesonOptions "schema" & saoSubObject ?~ "items" + instance ToJSON Header where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding @@ -1103,10 +1273,7 @@ instance ToJSON Header where -- >>> encode (SwaggerItemsArray []) -- "{\"example\":[],\"items\":{},\"maxItems\":0}" -- -instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where - toJSON (SwaggerItemsPrimitive fmt schema) = object - [ "collectionFormat" .= fmt - , "items" .= schema ] +instance ToJSON SwaggerItems where toJSON (SwaggerItemsObject x) = object [ "items" .= x ] toJSON (SwaggerItemsArray []) = object [ "items" .= object [] @@ -1115,11 +1282,9 @@ instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where ] toJSON (SwaggerItemsArray x) = object [ "items" .= x ] -instance ToJSON Host where - toJSON (Host host mport) = toJSON $ - case mport of - Nothing -> host - Just port -> host ++ ":" ++ show port +instance ToJSON Components where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding instance ToJSON MimeList where toJSON (MimeList xs) = toJSON (map show xs) @@ -1128,14 +1293,6 @@ instance ToJSON Param where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding -instance ToJSON ParamAnySchema where - toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ] - toJSON (ParamOther s) = toJSON s - -instance ToJSON ParamOtherSchema where - toJSON = sopSwaggerGenericToJSON - toEncoding = sopSwaggerGenericToEncoding - instance ToJSON Responses where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding @@ -1152,8 +1309,25 @@ instance ToJSON PathItem where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON RequestBody where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON MediaTypeObject where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON Example where - toJSON = toJSON . Map.mapKeys show . getExample + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON Encoding where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON Link where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding instance ToJSON SecurityDefinitions where toJSON (SecurityDefinitions sd) = toJSON sd @@ -1165,120 +1339,85 @@ referencedToJSON :: ToJSON a => Text -> Referenced a -> Value referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ] referencedToJSON _ (Inline x) = toJSON x -instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/definitions/" -instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/parameters/" -instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/responses/" - -instance ToJSON (SwaggerType t) where - toJSON SwaggerArray = "array" - toJSON SwaggerString = "string" - toJSON SwaggerInteger = "integer" - toJSON SwaggerNumber = "number" - toJSON SwaggerBoolean = "boolean" - toJSON SwaggerFile = "file" - toJSON SwaggerNull = "null" - toJSON SwaggerObject = "object" - -instance ToJSON (CollectionFormat t) where - toJSON CollectionCSV = "csv" - toJSON CollectionSSV = "ssv" - toJSON CollectionTSV = "tsv" - toJSON CollectionPipes = "pipes" - toJSON CollectionMulti = "multi" - -instance ToJSON (ParamSchema k) where - -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`? - toJSON = sopSwaggerGenericToJSONWithOpts $ - mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" +instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/components/schemas/" +instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/components/parameters/" +instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/components/responses/" +instance ToJSON (Referenced RequestBody) where toJSON = referencedToJSON "#/components/requestBodies/" +instance ToJSON (Referenced Example) where toJSON = referencedToJSON "#/components/examples/" +instance ToJSON (Referenced Header) where toJSON = referencedToJSON "#/components/headers/" +instance ToJSON (Referenced Link) where toJSON = referencedToJSON "#/components/links/" +instance ToJSON (Referenced Callback) where toJSON = referencedToJSON "#/components/callbacks/" instance ToJSON AdditionalProperties where toJSON (AdditionalPropertiesAllowed b) = toJSON b toJSON (AdditionalPropertiesSchema s) = toJSON s +instance ToJSON ExpressionOrValue where + toJSON (Expression expr) = toJSON expr + toJSON (Value val) = toJSON val + +instance ToJSON Callback where + toJSON (Callback ps) = toJSON ps + -- ======================================================================= -- Manual FromJSON instances -- ======================================================================= -instance FromJSON OAuth2Flow where - parseJSON (Object o) = do - (flow :: Text) <- o .: "flow" - case flow of - "implicit" -> OAuth2Implicit <$> o .: "authorizationUrl" - "password" -> OAuth2Password <$> o .: "tokenUrl" - "application" -> OAuth2Application <$> o .: "tokenUrl" - "accessCode" -> OAuth2AccessCode - <$> o .: "authorizationUrl" - <*> o .: "tokenUrl" - _ -> empty - parseJSON _ = empty +instance FromJSON MediaType where + parseJSON = withText "MediaType" $ \str -> + maybe (fail $ "Invalid media type literal " <> Text.unpack str) pure $ parseAccept $ encodeUtf8 str + +instance FromJSONKey MediaType where + fromJSONKey = FromJSONKeyTextParser (parseJSON . String) -instance FromJSON OAuth2Params where +instance (Eq p, FromJSON p, AesonDefaultValue p) => FromJSON (OAuth2Flow p) where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON OAuth2Flows where parseJSON = sopSwaggerGenericParseJSON instance FromJSON SecuritySchemeType where parseJSON js@(Object o) = do (t :: Text) <- o .: "type" case t of - "basic" -> pure SecuritySchemeBasic + "http" -> pure SecuritySchemeHttp "apiKey" -> SecuritySchemeApiKey <$> parseJSON js - "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js + "oauth2" -> SecuritySchemeOAuth2 <$> (o .: "flows") + "openIdConnect" -> SecuritySchemeOpenIdConnect <$> (o .: "openIdConnectUrl") _ -> empty parseJSON _ = empty instance FromJSON Swagger where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON Server where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON SecurityScheme where parseJSON = sopSwaggerGenericParseJSON instance FromJSON Schema where parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON where nullaryCleanup :: Schema -> Schema - nullaryCleanup s@Schema{_schemaParamSchema=ps} = - if _paramSchemaItems ps == Just (SwaggerItemsArray []) + nullaryCleanup s = + if _schemaItems s == Just (SwaggerItemsArray []) then s { _schemaExample = Nothing - , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } } + , _schemaMaxItems = Nothing + } else s instance FromJSON Header where parseJSON = sopSwaggerGenericParseJSON -instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where - parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive - <$> o .:? "collectionFormat" - <*> (o .: "items" >>= parseJSON) - -instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where - parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive - <$> o .:? "collectionFormat" - <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o)) - --- | --- --- >>> decode "{}" :: Maybe (SwaggerItems 'SwaggerKindSchema) --- Just (SwaggerItemsArray []) --- --- >>> eitherDecode "{\"$ref\":\"#/definitions/example\"}" :: Either String (SwaggerItems 'SwaggerKindSchema) --- Right (SwaggerItemsObject (Ref (Reference {getReference = "example"}))) --- --- >>> eitherDecode "[{\"$ref\":\"#/definitions/example\"}]" :: Either String (SwaggerItems 'SwaggerKindSchema) --- Right (SwaggerItemsArray [Ref (Reference {getReference = "example"})]) --- -instance FromJSON (SwaggerItems 'SwaggerKindSchema) where +instance FromJSON SwaggerItems where parseJSON js@(Object obj) | null obj = pure $ SwaggerItemsArray [] -- Nullary schema. | otherwise = SwaggerItemsObject <$> parseJSON js parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js parseJSON _ = empty -instance FromJSON Host where - parseJSON (String s) = case map Text.unpack $ Text.split (== ':') s of - [host] -> return $ Host host Nothing - [host, port] -> case readMaybe port of - Nothing -> fail $ "Invalid port `" ++ port ++ "'" - Just p -> return $ Host host (Just (fromInteger p)) - _ -> fail $ "Invalid host `" ++ Text.unpack s ++ "'" - parseJSON _ = empty +instance FromJSON Components where + parseJSON = sopSwaggerGenericParseJSON instance FromJSON MimeList where parseJSON js = (MimeList . map fromString) <$> parseJSON js @@ -1286,19 +1425,6 @@ instance FromJSON MimeList where instance FromJSON Param where parseJSON = sopSwaggerGenericParseJSON -instance FromJSON ParamAnySchema where - parseJSON js@(Object o) = do - (i :: Text) <- o .: "in" - case i of - "body" -> do - schema <- o .: "schema" - ParamBody <$> parseJSON schema - _ -> ParamOther <$> parseJSON js - parseJSON _ = empty - -instance FromJSON ParamOtherSchema where - parseJSON = sopSwaggerGenericParseJSON - instance FromJSON Responses where parseJSON (Object o) = Responses <$> o .:? "default" @@ -1306,9 +1432,7 @@ instance FromJSON Responses where parseJSON _ = empty instance FromJSON Example where - parseJSON js = do - m <- parseJSON js - pure $ Example (Map.mapKeys fromString m) + parseJSON = sopSwaggerGenericParseJSON instance FromJSON Response where parseJSON = sopSwaggerGenericParseJSON @@ -1322,6 +1446,18 @@ instance FromJSON PathItem where instance FromJSON SecurityDefinitions where parseJSON js = SecurityDefinitions <$> parseJSON js +instance FromJSON RequestBody where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON MediaTypeObject where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON Encoding where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON Link where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON Reference where parseJSON (Object o) = Reference <$> o .: "$ref" parseJSON _ = empty @@ -1339,57 +1475,52 @@ referencedParseJSON prefix js@(Object o) = do 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/" -instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/responses/" +instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/components/schemas/" +instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/components/parameters/" +instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/components/responses/" +instance FromJSON (Referenced RequestBody) where parseJSON = referencedParseJSON "#/components/requestBodies/" +instance FromJSON (Referenced Example) where parseJSON = referencedParseJSON "#/components/examples/" +instance FromJSON (Referenced Header) where parseJSON = referencedParseJSON "#/components/headers/" +instance FromJSON (Referenced Link) where parseJSON = referencedParseJSON "#/components/links/" +instance FromJSON (Referenced Callback) where parseJSON = referencedParseJSON "#/components/callbacks/" instance FromJSON Xml where parseJSON = genericParseJSON (jsonPrefix "xml") -instance FromJSON (SwaggerType 'SwaggerKindSchema) where - parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject] - -instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where - parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile] - -instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where - parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray] - -instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where - parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] - --- NOTE: There aren't collections of 'Schema' ---instance FromJSON (CollectionFormat (SwaggerKindSchema)) where --- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes] - -instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where - parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti] - -instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where - parseJSON = sopSwaggerGenericParseJSON -instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where - parseJSON = sopSwaggerGenericParseJSON -instance FromJSON (ParamSchema 'SwaggerKindSchema) where - parseJSON = sopSwaggerGenericParseJSON - instance FromJSON AdditionalProperties where parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b parseJSON js = AdditionalPropertiesSchema <$> parseJSON js +-- | All strings are parsed as expressions +instance FromJSON ExpressionOrValue where + parseJSON (String expr) = pure $ Expression expr + parseJSON v = pure $ Value v + +instance FromJSON Callback where + parseJSON = fmap Callback . parseJSON + +instance HasSwaggerAesonOptions Server where + swaggerAesonOptions _ = mkSwaggerAesonOptions "server" +instance HasSwaggerAesonOptions Components where + swaggerAesonOptions _ = mkSwaggerAesonOptions "components" instance HasSwaggerAesonOptions Header where - swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema" -instance HasSwaggerAesonOptions OAuth2Params where - swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow" + swaggerAesonOptions _ = mkSwaggerAesonOptions "header" +instance AesonDefaultValue p => HasSwaggerAesonOptions (OAuth2Flow p) where + swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "params" +instance HasSwaggerAesonOptions OAuth2Flows where + swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows" instance HasSwaggerAesonOptions Operation where swaggerAesonOptions _ = mkSwaggerAesonOptions "operation" instance HasSwaggerAesonOptions Param where - swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject ?~ "schema" -instance HasSwaggerAesonOptions ParamOtherSchema where - swaggerAesonOptions _ = mkSwaggerAesonOptions "paramOtherSchema" & saoSubObject ?~ "paramSchema" + swaggerAesonOptions _ = mkSwaggerAesonOptions "param" instance HasSwaggerAesonOptions PathItem where swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" instance HasSwaggerAesonOptions Response where swaggerAesonOptions _ = mkSwaggerAesonOptions "response" +instance HasSwaggerAesonOptions RequestBody where + swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody" +instance HasSwaggerAesonOptions MediaTypeObject where + swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaTypeObject" instance HasSwaggerAesonOptions Responses where swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses" instance HasSwaggerAesonOptions SecurityScheme where @@ -1397,23 +1528,26 @@ instance HasSwaggerAesonOptions SecurityScheme where instance HasSwaggerAesonOptions Schema where swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" instance HasSwaggerAesonOptions Swagger where - swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")] - -instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where - swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" -instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where - swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items" --- NOTE: Schema doesn't have 'items' sub object! -instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where - swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" - -instance AesonDefaultValue (ParamSchema s) -instance AesonDefaultValue OAuth2Flow + swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")] +instance HasSwaggerAesonOptions Example where + swaggerAesonOptions _ = mkSwaggerAesonOptions "example" +instance HasSwaggerAesonOptions Encoding where + swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" + +instance HasSwaggerAesonOptions Link where + swaggerAesonOptions _ = mkSwaggerAesonOptions "link" + +instance AesonDefaultValue Server +instance AesonDefaultValue Components +instance AesonDefaultValue OAuth2ImplicitFlow +instance AesonDefaultValue OAuth2PasswordFlow +instance AesonDefaultValue OAuth2ClientCredentialsFlow +instance AesonDefaultValue OAuth2AuthorizationCodeFlow +instance AesonDefaultValue p => AesonDefaultValue (OAuth2Flow p) instance AesonDefaultValue Responses -instance AesonDefaultValue ParamAnySchema instance AesonDefaultValue SecuritySchemeType -instance AesonDefaultValue (SwaggerType a) +instance AesonDefaultValue SwaggerType instance AesonDefaultValue MimeList where defaultValue = Just mempty instance AesonDefaultValue Info instance AesonDefaultValue ParamLocation -instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty +instance AesonDefaultValue Link diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs index b927fb6f..30818bf2 100644 --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -50,25 +50,31 @@ import qualified Data.ByteString.Lazy as BSL import GHC.TypeLits (TypeError, ErrorMessage(..)) -- | Default schema for binary data (any sequence of octets). -binaryParamSchema :: ParamSchema t -binaryParamSchema = mempty +binarySchema :: Schema +binarySchema = mempty & type_ ?~ SwaggerString & format ?~ "binary" -- | Default schema for binary data (base64 encoded). -byteParamSchema :: ParamSchema t -byteParamSchema = mempty +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. -passwordParamSchema :: ParamSchema t -passwordParamSchema = mempty +passwordSchema :: Schema +passwordSchema = mempty & type_ ?~ SwaggerString & format ?~ "password" --- | Convert a type into a plain @'ParamSchema'@. +-- | Convert a type into a plain @'Schema'@. +-- +-- In previous versions of the package there was a separate type called @ParamSchema@, which was +-- included in a greater 'Schema'. Now this is a single class, but distinction for schema generators +-- for "simple" types is preserved. +-- +-- 'ToParamSchema' is suited only for primitive-like types without nested fields and such. -- -- An example type and instance: -- @@ -108,8 +114,8 @@ class ToParamSchema a where -- -- >>> encode $ toParamSchema (Proxy :: Proxy Integer) -- "{\"type\":\"integer\"}" - toParamSchema :: Proxy a -> ParamSchema t - default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t + toParamSchema :: Proxy a -> Schema + default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> Schema toParamSchema = genericToParamSchema defaultSchemaOptions instance {-# OVERLAPPING #-} ToParamSchema String where @@ -151,7 +157,7 @@ instance ToParamSchema Word64 where -- -- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8) -- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}" -toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t +toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema toParamSchemaBoundedIntegral _ = mempty & type_ ?~ SwaggerInteger & minimum_ ?~ fromInteger (toInteger (minBound :: a)) @@ -181,7 +187,7 @@ instance ToParamSchema Float where & type_ ?~ SwaggerNumber & format ?~ "float" -timeParamSchema :: String -> ParamSchema t +timeParamSchema :: String -> Schema timeParamSchema fmt = mempty & type_ ?~ SwaggerString & format ?~ T.pack fmt @@ -236,7 +242,7 @@ type family ToParamSchemaByteStringError bs where ToParamSchemaByteStringError bs = TypeError ( 'Text "Impossible to have an instance " :<>: ShowType (ToParamSchema bs) :<>: Text "." :$$: 'Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead." - :$$: 'Text "Consider using byteParamSchema or binaryParamSchema templates." ) + :$$: 'Text "Consider using byteParamSchema or binaryParamSchemaemplates." ) instance ToParamSchemaByteStringError BS.ByteString => ToParamSchema BS.ByteString where toParamSchema = error "impossible" instance ToParamSchemaByteStringError BSL.ByteString => ToParamSchema BSL.ByteString where toParamSchema = error "impossible" @@ -254,7 +260,7 @@ instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = t instance ToParamSchema a => ToParamSchema [a] where toParamSchema _ = mempty & type_ ?~ SwaggerArray - & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a)) + & items ?~ SwaggerItemsObject (Inline $ 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]) @@ -281,17 +287,17 @@ instance ToParamSchema UUID where & type_ ?~ SwaggerString & format ?~ "uuid" --- | A configurable generic @'ParamSchema'@ creator. +-- | A configurable generic @'Schema'@ creator. -- -- >>> :set -XDeriveGeneric -- >>> data Color = Red | Blue deriving Generic -- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color) -- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}" -genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t +genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty class GToParamSchema (f :: * -> *) where - gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t + gtoParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema instance GToParamSchema f => GToParamSchema (D1 d f) where gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f) @@ -309,7 +315,7 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g)) class GEnumParamSchema (f :: * -> *) where - genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t + genumParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g) diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index 210cc856..0e5df74d 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -22,12 +22,13 @@ module Data.Swagger.Internal.Schema where import Prelude () import Prelude.Compat -import Control.Lens +import Control.Lens hiding (allOf) import Data.Data.Lens (template) import Control.Monad import Control.Monad.Writer -import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..)) +import Data.Aeson (Object (..), SumEncoding (..), ToJSON (..), ToJSONKey (..), + ToJSONKeyFunction (..), Value (..)) import Data.Char import Data.Data (Data) import Data.Foldable (traverse_) @@ -41,6 +42,7 @@ import Data.IntSet (IntSet) import Data.IntMap (IntMap) import Data.List.NonEmpty.Compat (NonEmpty) import Data.Map (Map) +import Data.Maybe (fromMaybe) import Data.Proxy import Data.Scientific (Scientific) import Data.Fixed (Fixed, HasResolution, Pico) @@ -67,7 +69,7 @@ import Data.Swagger.SchemaOptions import Data.Swagger.Internal.TypeShape import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL import GHC.TypeLits (TypeError, ErrorMessage(..)) unnamed :: Schema -> NamedSchema @@ -135,7 +137,7 @@ class ToSchema a where -- 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 Schema) NamedSchema - default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") => + default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => Proxy a -> Declare (Definitions Schema) NamedSchema declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions @@ -151,13 +153,13 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema -- -- >>> toNamedSchema (Proxy :: Proxy String) ^. name -- Nothing --- >>> encode (toNamedSchema (Proxy :: Proxy String) ^. schema) --- "{\"type\":\"string\"}" +-- >>> BSL.putStrLn $ encode (toNamedSchema (Proxy :: Proxy String) ^. schema) +-- {"type":"string"} -- -- >>> toNamedSchema (Proxy :: Proxy Day) ^. name -- Just "Day" --- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema) --- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}" +-- >>> BSL.putStrLn $ encode (toNamedSchema (Proxy :: Proxy Day) ^. schema) +-- {"example":"2016-07-22","format":"date","type":"string"} toNamedSchema :: ToSchema a => Proxy a -> NamedSchema toNamedSchema = undeclare . declareNamedSchema @@ -173,22 +175,22 @@ schemaName = _namedSchemaName . toNamedSchema -- | Convert a type into a schema. -- --- >>> encode $ toSchema (Proxy :: Proxy Int8) --- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}" +-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy Int8) +-- {"maximum":127,"minimum":-128,"type":"integer"} -- --- >>> encode $ toSchema (Proxy :: Proxy [Day]) --- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}" +-- >>> BSL.putStrLn $ encode $ toSchema (Proxy :: Proxy [Day]) +-- {"items":{"$ref":"#/components/schemas/Day"},"type":"array"} toSchema :: ToSchema a => Proxy a -> Schema toSchema = _namedSchemaSchema . toNamedSchema -- | Convert a type into a referenced schema if possible. -- Only named schemas can be referenced, nameless schemas are inlined. -- --- >>> encode $ toSchemaRef (Proxy :: Proxy Integer) --- "{\"type\":\"integer\"}" +-- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Integer) +-- {"type":"integer"} -- --- >>> encode $ toSchemaRef (Proxy :: Proxy Day) --- "{\"$ref\":\"#/definitions/Day\"}" +-- >>> BSL.putStrLn $ encode $ toSchemaRef (Proxy :: Proxy Day) +-- {"$ref":"#/components/schemas/Day"} toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema toSchemaRef = undeclare . declareSchemaRef @@ -256,8 +258,8 @@ inlineAllSchemas = inlineSchemasWhen (const True) -- | Convert a type into a schema without references. -- --- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day]) --- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}" +-- >>> BSL.putStrLn $ encode $ toInlinedSchema (Proxy :: Proxy [Day]) +-- {"items":{"example":"2016-07-22","format":"date","type":"string"},"type":"array"} -- -- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema -- when inlining recursive schemas. @@ -287,41 +289,22 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs traverse_ usedNames (InsOrdHashMap.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\"}" +-- >>> BSL.putStrLn $ encode $ sketchSchema "hello" +-- {"example":"hello","type":"string"} -- --- >>> encode $ sketchSchema (1, 2, 3) --- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}" +-- >>> BSL.putStrLn $ 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\"}" +-- >>> BSL.putStrLn $ 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) --- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}" +-- >>> BSL.putStrLn $ 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 @@ -353,19 +336,19 @@ sketchSchema = sketch . toJSON -- | 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\"]}" +-- >>> BSL.putStrLn $ 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]]}" +-- >>> BSL.putStrLn $ 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]]}" +-- >>> BSL.putStrLn $ 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) --- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}},\"maxProperties\":2,\"minProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}]}" +-- >>> BSL.putStrLn $ 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 @@ -443,7 +426,9 @@ instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain instance ToSchema a => ToSchema (Maybe a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a) -instance (ToSchema a, ToSchema b) => ToSchema (Either a b) +instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where + -- To match Aeson instance + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField } instance ToSchema () where declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema) @@ -565,8 +550,8 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar -- | Default schema for @'Bounded'@, @'Integral'@ types. -- --- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16) --- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}" +-- >>> BSL.putStrLn $ encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16) +-- {"maximum":32767,"minimum":-32768,"type":"integer"} toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema toSchemaBoundedIntegral _ = mempty & type_ ?~ SwaggerInteger @@ -598,8 +583,8 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> -- >>> instance ToSchema ButtonState -- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show) -- >>> type ImageUrl = T.Text --- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) --- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}" +-- >>> BSL.putStrLn $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) +-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}} -- -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. @@ -626,8 +611,8 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o -- >>> instance ToSchema ButtonState -- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show) -- >>> type ImageUrl = T.Text --- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) --- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}" +-- >>> BSL.putStrLn $ encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl)) +-- {"type":"object","properties":{"Focus":{"type":"string"},"Disabled":{"type":"string"},"Active":{"type":"string"},"Neutral":{"type":"string"},"Hover":{"type":"string"}}} -- -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. @@ -637,32 +622,17 @@ toSchemaBoundedEnumKeyMapping :: forall map key value. toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping -- | A configurable generic @'Schema'@ creator. -genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") => +genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema -genericDeclareSchema = genericDeclareSchemaUnrestricted +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 :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") => +genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema -genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted - --- | A configurable generic @'Schema'@ creator. --- --- Unlike 'genericDeclareSchema' also works for mixed sum types. --- Use with care since some Swagger tools do not support well schemas for mixed sum types. -genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema -genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy - --- | A configurable generic @'NamedSchema'@ creator. --- --- Unlike 'genericDeclareNamedSchema' also works for mixed sum types. --- Use with care since some Swagger tools do not support well schemas for mixed sum types. -genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) => - SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema -genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty +genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty -- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'. genericNameSchema :: forall a d f. @@ -678,14 +648,14 @@ gdatatypeSchemaName opts _ = case orig of orig = datatypeName (Proxy3 :: Proxy3 d f a) name = datatypeNameModifier opts orig --- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@. +-- | Construct 'NamedSchema' usinng 'ToParamSchema'. paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) => SchemaOptions -> Proxy a -> NamedSchema paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy) --- | Lift a plain @'ParamSchema'@ into a model @'Schema'@. +-- | Construct 'Schema' usinng 'ToParamSchema'. paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema -paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy +paramSchemaToSchema = toParamSchema nullarySchema :: Schema nullarySchema = mempty @@ -748,7 +718,7 @@ gdeclareSchemaRef opts proxy = do return $ Ref (Reference name) _ -> Inline <$> gdeclareSchema opts proxy -appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema) +appendItem :: Referenced Schema -> Maybe SwaggerItems -> Maybe SwaggerItems appendItem x Nothing = Just (SwaggerItemsArray [x]) appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x])) appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject" @@ -791,56 +761,98 @@ instance ( GSumToSchema f , GSumToSchema g ) => GToSchema (f :+: g) where - gdeclareNamedSchema = gdeclareNamedSumSchema + -- Aeson does not unwrap unary record in sum types. + gdeclareNamedSchema opts p s = gdeclareNamedSumSchema (opts { unwrapUnaryRecords = False } )p s 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 +gdeclareNamedSumSchema opts proxy _ + | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchemas) + | otherwise = do + (schemas, _) <- runWriterT declareSumSchema + return $ unnamed $ mempty + & type_ ?~ SwaggerObject + & oneOf ?~ (snd <$> schemas) where - declareSumSchema = gsumToSchema opts proxy s - (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema) + declareSumSchema = gsumToSchema opts proxy + (sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema) - toStringTag schema = mempty + toStringTag schemas = mempty & type_ ?~ SwaggerString - & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex) + & enum_ ?~ map (String . fst) sumSchemas type AllNullary = All class GSumToSchema (f :: * -> *) where - gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema + gsumToSchema :: SchemaOptions -> Proxy f -> WriterT AllNullary (Declare (Definitions Schema)) [(T.Text, Referenced Schema)] instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where - gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g) + gsumToSchema opts _ = + (<>) <$> gsumToSchema opts (Proxy :: Proxy f) <*> gsumToSchema opts (Proxy :: Proxy g) +-- | Convert one component of the sum to schema, to be later combined with @oneOf@. gsumConToSchemaWith :: forall c f. (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 + Maybe (Referenced Schema) -> SchemaOptions -> Proxy (C1 c f) -> (T.Text, Referenced Schema) +gsumConToSchemaWith ref opts _ = (tag, schema) where + schema = case sumEncoding opts of + TaggedObject tagField contentsField -> + case ref of + -- If subschema is an object and constructor is a record, we add tag directly + -- to the record, as Aeson does it. + Just (Inline sub) | sub ^. type_ == Just SwaggerObject && isRecord -> Inline $ sub + & required <>~ [T.pack tagField] + & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag]) + + -- If it is not a record, we need to put subschema into "contents" field. + _ | not isRecord -> Inline $ mempty + & type_ ?~ SwaggerObject + & required .~ [T.pack tagField] + & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag]) + -- If constructor is nullary, there is no content. + & case ref of + Just r -> (properties . at (T.pack contentsField) ?~ r) . (required <>~ [T.pack contentsField]) + Nothing -> id + + -- In the remaining cases we combine "tag" object and "contents" object using allOf. + _ -> Inline $ mempty + & type_ ?~ SwaggerObject + & allOf ?~ [Inline $ mempty + & type_ ?~ SwaggerObject + & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField]) + & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag])] + & if isRecord + then allOf . _Just <>~ [refOrNullary] + else allOf . _Just <>~ [Inline $ mempty & type_ ?~ SwaggerObject & properties . at (T.pack contentsField) ?~ refOrNullary] + UntaggedValue -> refOrEnum -- Aeson encodes nullary constructors as strings in this case. + ObjectWithSingleField -> Inline $ mempty + & type_ ?~ SwaggerObject + & required .~ [tag] + & properties . at tag ?~ refOrNullary + TwoElemArray -> error "unrepresentable in OpenAPI 3" + tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p))) + isRecord = conIsRecord (Proxy3 :: Proxy3 c f p) + refOrNullary = fromMaybe (Inline nullarySchema) ref + refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ SwaggerString & enum_ ?~ [String tag]) ref gsumConToSchema :: (GToSchema (C1 c f), Constructor c) => - SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema -gsumConToSchema opts proxy schema = do + SchemaOptions -> Proxy (C1 c f) -> Declare (Definitions Schema) [(T.Text, Referenced Schema)] +gsumConToSchema opts proxy = do ref <- gdeclareSchemaRef opts proxy - return $ gsumConToSchemaWith ref opts proxy schema + return [gsumConToSchemaWith (Just ref) opts proxy] instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where - gsumToSchema opts proxy schema = do + gsumToSchema opts proxy = do tell (All False) - lift $ gsumConToSchema opts proxy schema + lift $ gsumConToSchema opts proxy instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where - gsumToSchema opts proxy schema = do + gsumToSchema opts proxy = do tell (All False) - lift $ gsumConToSchema opts proxy schema + lift $ gsumConToSchema opts proxy instance Constructor c => GSumToSchema (C1 c U1) where - gsumToSchema opts proxy = pure . gsumConToSchemaWith (Inline nullarySchema) opts proxy + gsumToSchema opts proxy = pure $ (:[]) $ gsumConToSchemaWith Nothing opts proxy data Proxy2 a b = Proxy2 diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs index 39fd03a5..9c926b5e 100644 --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -12,6 +12,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module: Data.Swagger.Internal.Schema.Validation -- Copyright: (c) 2015 GetShopTV @@ -26,8 +27,8 @@ import Prelude () import Prelude.Compat import Control.Applicative -import Control.Lens -import Control.Monad (when) +import Control.Lens hiding (allOf) +import Control.Monad (forM, forM_, when) import Data.Aeson hiding (Result) import Data.Aeson.Encode.Pretty (encodePretty) @@ -37,6 +38,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import qualified "unordered-containers" Data.HashSet as HashSet +import Data.Maybe (fromMaybe) import Data.Proxy import Data.Scientific (Scientific, isInteger) import Data.Text (Text) @@ -108,7 +110,7 @@ validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checke -- "type": "object", -- "properties": { -- "phone": { --- "$ref": "#/definitions/Phone" +-- "$ref": "#/components/schemas/Phone" -- }, -- "name": { -- "type": "string" @@ -203,7 +205,7 @@ instance Monad Result where -- | Validation configuration. data Config = Config - { -- | Pattern checker for @'_paramSchemaPattern'@ validation. + { -- | Pattern checker for @'_schemaPattern'@ validation. configPatternChecker :: Pattern -> Text -> Bool -- | Schema definitions in scope to resolve references. , configDefinitions :: Definitions Schema @@ -296,23 +298,17 @@ 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 +validateWithSchema val = do + validateSchemaType val + validateEnum val --- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@. -validateWithParamSchema :: Value -> Validation (ParamSchema t) () -validateWithParamSchema value = do - validateParamSchemaType value - validateEnum value - -validateInteger :: Scientific -> Validation (ParamSchema t) () +validateInteger :: Scientific -> Validation Schema () validateInteger n = do when (not (isInteger n)) $ invalid ("not an integer") validateNumber n -validateNumber :: Scientific -> Validation (ParamSchema t) () +validateNumber :: Scientific -> Validation Schema () validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do let exMax = Just True == sch ^. exclusiveMaximum exMin = Just True == sch ^. exclusiveMinimum @@ -329,7 +325,7 @@ validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do when (not (isInteger (n / k))) $ invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n) -validateString :: Text -> Validation (ParamSchema t) () +validateString :: Text -> Validation Schema () validateString s = do check maxLength $ \n -> when (len > fromInteger n) $ @@ -346,7 +342,7 @@ validateString s = do where len = Text.length s -validateArray :: Vector Value -> Validation (ParamSchema t) () +validateArray :: Vector Value -> Validation Schema () validateArray xs = do check maxItems $ \n -> when (len > fromInteger n) $ @@ -357,7 +353,6 @@ validateArray xs = do 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) $ @@ -374,8 +369,11 @@ validateArray xs = do validateObject :: HashMap Text Value -> Validation Schema () validateObject o = withSchema $ \sch -> case sch ^. discriminator of - Just pname -> case fromJSON <$> HashMap.lookup pname o of - Just (Success ref) -> validateWithSchemaRef ref (Object o) + Just (Discriminator pname types) -> case fromJSON <$> HashMap.lookup pname o of + Just (Success pvalue) -> + let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types + -- TODO ref may be name or reference + in validateWithSchemaRef (Ref (Reference 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 @@ -414,11 +412,11 @@ validateObject o = withSchema $ \sch -> unknownProperty pname = invalid $ "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema" -validateEnum :: Value -> Validation (ParamSchema t) () -validateEnum value = do +validateEnum :: Value -> Validation Schema () +validateEnum val = do check enum_ $ \xs -> - when (value `notElem` xs) $ - invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value) + when (val `notElem` xs) $ + invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show val) -- | Infer schema type based on used properties. -- @@ -426,8 +424,8 @@ validateEnum value = do -- -- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}" -- Just [SwaggerObject] -inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema] -inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++ +inferSchemaTypes :: Schema -> [SwaggerType] +inferSchemaTypes sch = inferParamSchemaTypes sch ++ [ SwaggerObject | any ($ sch) [ has (additionalProperties._Just) , has (maxProperties._Just) @@ -448,7 +446,7 @@ inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++ -- -- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}" -- Just [SwaggerInteger] -inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t] +inferParamSchemaTypes :: Schema -> [SwaggerType] inferParamSchemaTypes sch = concat [ [ SwaggerArray | any ($ sch) [ has (items._Just) @@ -468,27 +466,42 @@ inferParamSchemaTypes sch = concat ] validateSchemaType :: Value -> Validation Schema () -validateSchemaType value = withSchema $ \sch -> - case (sch ^. type_, value) of - (Just SwaggerNull, Null) -> valid - (Just SwaggerBoolean, Bool _) -> valid - (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n) - (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n) - (Just SwaggerString, String s) -> sub_ paramSchema (validateString s) - (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs) - (Just SwaggerObject, Object o) -> validateObject o - (Nothing, Null) -> valid - (Nothing, Bool _) -> valid - -- Number by default - (Nothing, Number n) -> sub_ paramSchema (validateNumber n) - (Nothing, String s) -> sub_ paramSchema (validateString s) - (Nothing, Array xs) -> sub_ paramSchema (validateArray xs) - (Nothing, Object o) -> validateObject o - bad -> invalid $ "expected JSON value of type " ++ showType bad - -validateParamSchemaType :: Value -> Validation (ParamSchema t) () -validateParamSchemaType value = withSchema $ \sch -> - case (sch ^. type_, value) of +validateSchemaType val = withSchema $ \sch -> + case sch of + (view oneOf -> Just variants) -> do + res <- forM variants $ \var -> + (True <$ validateWithSchemaRef var val) <|> (return False) + case length $ filter id res of + 0 -> invalid $ "Value not valid under any of 'oneOf' schemas: " ++ show val + 1 -> valid + _ -> invalid $ "Value matches more than one of 'oneOf' schemas: " ++ show val + (view allOf -> Just variants) -> do + -- Default semantics for Validation Monad will abort when at least one + -- variant does not match. + forM_ variants $ \var -> + validateWithSchemaRef var val + + _ -> + case (sch ^. type_, val) of + (Just SwaggerNull, Null) -> valid + (Just SwaggerBoolean, Bool _) -> valid + (Just SwaggerInteger, Number n) -> validateInteger n + (Just SwaggerNumber, Number n) -> validateNumber n + (Just SwaggerString, String s) -> validateString s + (Just SwaggerArray, Array xs) -> validateArray xs + (Just SwaggerObject, Object o) -> validateObject o + (Nothing, Null) -> valid + (Nothing, Bool _) -> valid + -- Number by default + (Nothing, Number n) -> validateNumber n + (Nothing, String s) -> validateString s + (Nothing, Array xs) -> validateArray xs + (Nothing, Object o) -> validateObject o + bad -> invalid $ "expected JSON value of type " ++ showType bad + +validateParamSchemaType :: Value -> Validation Schema () +validateParamSchemaType val = withSchema $ \sch -> + case (sch ^. type_, val) of (Just SwaggerBoolean, Bool _) -> valid (Just SwaggerInteger, Number n) -> validateInteger n (Just SwaggerNumber, Number n) -> validateNumber n @@ -501,7 +514,7 @@ validateParamSchemaType value = withSchema $ \sch -> (Nothing, Array xs) -> validateArray xs bad -> invalid $ "expected JSON value of type " ++ showType bad -showType :: (Maybe (SwaggerType t), Value) -> String +showType :: (Maybe SwaggerType, Value) -> String showType (Just ty, _) = show ty showType (Nothing, Null) = "SwaggerNull" showType (Nothing, Bool _) = "SwaggerBoolean" diff --git a/src/Data/Swagger/Internal/Utils.hs b/src/Data/Swagger/Internal/Utils.hs index ca91d7b7..1a2eff21 100644 --- a/src/Data/Swagger/Internal/Utils.hs +++ b/src/Data/Swagger/Internal/Utils.hs @@ -44,6 +44,7 @@ swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer fixName' "maximum" = "maximum_" -- Prelude conflict fixName' "enum" = "enum_" -- Control.Lens conflict fixName' "head" = "head_" -- Prelude conflict + fixName' "not" = "not_" -- 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 diff --git a/src/Data/Swagger/Lens.hs b/src/Data/Swagger/Lens.hs index 6e859e89..20d269f0 100644 --- a/src/Data/Swagger/Lens.hs +++ b/src/Data/Swagger/Lens.hs @@ -27,30 +27,38 @@ import Data.Text (Text) -- * Classy lenses makeFields ''Swagger -makeFields ''Host +makeFields ''Components +makeFields ''Server +makeFields ''RequestBody +makeFields ''MediaTypeObject makeFields ''Info makeFields ''Contact makeFields ''License makeLensesWith swaggerFieldRules ''PathItem makeFields ''Tag makeFields ''Operation -makeFields ''Param -makeLensesWith swaggerFieldRules ''ParamOtherSchema +makeLensesWith swaggerFieldRules ''Param makeFields ''Header -makeFields ''Schema +makeLensesWith swaggerFieldRules ''Schema makeFields ''NamedSchema -makeLensesWith swaggerFieldRules ''ParamSchema makeFields ''Xml makeLensesWith swaggerFieldRules ''Responses makeFields ''Response makeLensesWith swaggerFieldRules ''SecurityScheme makeFields ''ApiKeyParams -makeFields ''OAuth2Params +makeFields ''OAuth2ImplicitFlow +makeFields ''OAuth2PasswordFlow +makeFields ''OAuth2ClientCredentialsFlow +makeFields ''OAuth2AuthorizationCodeFlow +makeFields ''OAuth2Flow +makeFields ''OAuth2Flows makeFields ''ExternalDocs +makeFields ''Encoding +makeFields ''Example +makeFields ''Discriminator +makeFields ''Link -- * Prisms --- ** 'ParamAnySchema' prisms -makePrisms ''ParamAnySchema -- ** 'SecuritySchemeType' prisms makePrisms ''SecuritySchemeType -- ** 'Referenced' prisms @@ -58,7 +66,7 @@ makePrisms ''Referenced -- ** 'SwaggerItems' prisms -_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema] +_SwaggerItemsArray :: Review SwaggerItems [Referenced Schema] _SwaggerItemsArray = unto (\x -> SwaggerItemsArray x) {- \x -> case x of @@ -67,7 +75,7 @@ _SwaggerItemsArray SwaggerItemsArray a -> Right a -} -_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema) +_SwaggerItemsObject :: Review SwaggerItems (Referenced Schema) _SwaggerItemsObject = unto (\x -> SwaggerItemsObject x) {- \x -> case x of @@ -76,9 +84,6 @@ _SwaggerItemsObject SwaggerItemsArray a -> Left (SwaggerItemsArray a) -} -_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) - -- ============================================================= -- More helpful instances for easier access to schema properties @@ -94,85 +99,68 @@ instance At Responses where at n = responses . at n instance Ixed Operation where ix n = responses . ix n instance At Operation where at n = responses . at n -type instance Index SecurityDefinitions = Text -type instance IxValue SecurityDefinitions = SecurityScheme - -instance Ixed SecurityDefinitions where ix n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). ix n -instance At SecurityDefinitions where at n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). at n - -instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema - --- HasType instances -instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_ -instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_ -instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_ -instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_ - --- 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_ +instance HasType NamedSchema (Maybe SwaggerType) where type_ = schema.type_ -- OVERLAPPABLE instances instance {-# OVERLAPPABLE #-} - HasParamSchema s (ParamSchema t) + HasSchema s Schema => HasFormat s (Maybe Format) where - format = paramSchema.format + format = schema.format instance {-# OVERLAPPABLE #-} - HasParamSchema s (ParamSchema t) - => HasItems s (Maybe (SwaggerItems t)) where - items = paramSchema.items + HasSchema s Schema + => HasItems s (Maybe SwaggerItems) where + items = schema.items instance {-# OVERLAPPABLE #-} - HasParamSchema s (ParamSchema t) + HasSchema s Schema => HasMaximum s (Maybe Scientific) where - maximum_ = paramSchema.maximum_ + maximum_ = schema.maximum_ -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasExclusiveMaximum s (Maybe Bool) where - exclusiveMaximum = paramSchema.exclusiveMaximum + exclusiveMaximum = schema.exclusiveMaximum -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMinimum s (Maybe Scientific) where - minimum_ = paramSchema.minimum_ + minimum_ = schema.minimum_ -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasExclusiveMinimum s (Maybe Bool) where - exclusiveMinimum = paramSchema.exclusiveMinimum + exclusiveMinimum = schema.exclusiveMinimum -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMaxLength s (Maybe Integer) where - maxLength = paramSchema.maxLength + maxLength = schema.maxLength -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMinLength s (Maybe Integer) where - minLength = paramSchema.minLength + minLength = schema.minLength -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasPattern s (Maybe Text) where - pattern = paramSchema.pattern + pattern = schema.pattern -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMaxItems s (Maybe Integer) where - maxItems = paramSchema.maxItems + maxItems = schema.maxItems -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMinItems s (Maybe Integer) where - minItems = paramSchema.minItems + minItems = schema.minItems -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasUniqueItems s (Maybe Bool) where - uniqueItems = paramSchema.uniqueItems + uniqueItems = schema.uniqueItems -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasEnum s (Maybe [Value]) where - enum_ = paramSchema.enum_ + enum_ = schema.enum_ -instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t) +instance {-# OVERLAPPABLE #-} HasSchema s Schema => HasMultipleOf s (Maybe Scientific) where - multipleOf = paramSchema.multipleOf + multipleOf = schema.multipleOf diff --git a/src/Data/Swagger/Operation.hs b/src/Data/Swagger/Operation.hs index 607dc992..3a926c79 100644 --- a/src/Data/Swagger/Operation.hs +++ b/src/Data/Swagger/Operation.hs @@ -39,6 +39,8 @@ import Data.List.Compat import Data.Maybe (mapMaybe) import Data.Proxy import qualified Data.Set as Set +import Data.Text (Text) +import Network.HTTP.Media (MediaType) import Data.Swagger.Declare import Data.Swagger.Internal @@ -52,13 +54,14 @@ import qualified Data.HashSet.InsOrd as InsOrdHS -- >>> import Data.Aeson -- >>> import Data.Proxy -- >>> import Data.Time +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL -- | 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\":{}}" +-- >>> BSL.putStrLn $ encode $ prependPath "user/{user_id}" api ^. paths +-- {"/user/{user_id}/info":{}} prependPath :: FilePath -> Swagger -> Swagger prependPath path = paths %~ InsOrdHashMap.mapKeys (path ) where @@ -79,10 +82,10 @@ allOperations = paths.traverse.template -- >>> 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\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" --- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found" --- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" +-- >>> BSL.putStrLn $ encode api +-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"200":{"description":"OK"}}},"post":{"responses":{"200":{"description":"OK"}}}}},"components":{}} +-- >>> BSL.putStrLn $ encode $ api & operationsOf sub . at 404 ?~ "Not found" +-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"Not found"},"200":{"description":"OK"}}},"post":{"responses":{"200":{"description":"OK"}}}}},"components":{}} operationsOf :: Swagger -> Traversal' Swagger Operation operationsOf sub = paths.itraversed.withIndex.subops where @@ -118,12 +121,14 @@ applyTagsFor ops ts swag = swag -- | Construct a response with @'Schema'@ while declaring all -- necessary schema definitions. -- --- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty --- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]" -declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response -declareResponse proxy = do +-- FIXME doc +-- +-- >>> BSL.putStrLn $ encode $ runDeclare (declareResponse "application/json" (Proxy :: Proxy Day)) mempty +-- [{"Day":{"example":"2016-07-22","format":"date","type":"string"}},{"description":"","content":{"application/json":{"schema":{"$ref":"#/components/schemas/Day"}}}}] +declareResponse :: ToSchema a => MediaType -> Proxy a -> Declare (Definitions Schema) Response +declareResponse cType proxy = do s <- declareSchemaRef proxy - return (mempty & schema ?~ s) + return (mempty & content.at cType ?~ (mempty & schema ?~ s)) -- | Set response for all operations. -- This will also update global schema definitions. @@ -137,9 +142,9 @@ declareResponse proxy = do -- 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\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}" +-- >>> let res = declareResponse "application/json" (Proxy :: Proxy Day) +-- >>> BSL.putStrLn $ encode $ api & setResponse 200 res +-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/Day"}}},"description":""}}}}},"components":{"schemas":{"Day":{"example":"2016-07-22","format":"date","type":"string"}}}} -- -- See also @'setResponseWith'@. setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger @@ -167,7 +172,7 @@ setResponseWith = setResponseForWith allOperations -- See also @'setResponseForWith'@. setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger setResponseFor ops code dres swag = swag - & definitions %~ (<> defs) + & components.schemas %~ (<> defs) & ops . at code ?~ Inline res where (defs, res) = runDeclare dres mempty @@ -181,12 +186,12 @@ setResponseFor ops code dres swag = swag -- 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) + & components.schemas %~ (<> defs) & ops . at code %~ Just . Inline . combine where (defs, new) = runDeclare dres mempty - combine (Just (Ref (Reference n))) = case swag ^. responses.at n of + combine (Just (Ref (Reference n))) = case swag ^. components.responses.at n 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 diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs index 07819c7f..b108e050 100644 --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -17,51 +17,42 @@ -- >>> import Data.Aeson -- >>> import Optics.Core -- >>> :set -XOverloadedLabels +-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL -- -- Example from the "Data.Swagger" module using @optics@: -- -- >>> :{ --- encode $ (mempty :: Swagger) --- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ] +-- BSL.putStrLn $ encode $ (mempty :: Swagger) +-- & #components % #schemas .~ [ ("User", mempty & #type ?~ SwaggerString) ] -- & #paths .~ -- [ ("/user", mempty & #get ?~ (mempty --- & #produces ?~ MimeList ["application/json"] --- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User")) +-- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User"))) -- & at 404 ?~ "User info not found")) ] -- :} --- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}" +-- {"openapi":"3.0.0","info":{"version":"","title":""},"paths":{"/user":{"get":{"responses":{"404":{"description":"User info not found"},"200":{"content":{"application/json":{"schema":{"$ref":"#/components/schemas/User"}}},"description":"OK"}}}}},"components":{"schemas":{"User":{"type":"string"}}}} -- -- For convenience optics are defined as /labels/. 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\"}" +-- >>> BSL.putStrLn $ encode $ (mempty :: Response) & #description .~ "No content" +-- {"description":"No content"} -- >>> :{ --- encode $ (mempty :: Schema) +-- BSL.putStrLn $ encode $ (mempty :: Schema) -- & #type ?~ SwaggerBoolean -- & #description ?~ "To be or not to be" -- :} --- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}" --- --- @'ParamSchema'@ is basically the /base schema specification/ and many types --- contain it. 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\"}" +-- {"type":"boolean","description":"To be or not to be"} -- -- Additionally, to simplify working with @'Response'@, both @'Operation'@ and -- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example: -- -- >>> :{ --- encode $ (mempty :: Operation) +-- BSL.putStrLn $ encode $ (mempty :: Operation) -- & at 404 ?~ "Not found" -- :} --- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}" +-- {"responses":{"404":{"description":"Not found"}}} -- module Data.Swagger.Optics () where @@ -75,7 +66,11 @@ import Optics.TH -- Lenses makeFieldLabels ''Swagger -makeFieldLabels ''Host +makeFieldLabels ''Components +makeFieldLabels ''Server +makeFieldLabels ''ServerVariable +makeFieldLabels ''RequestBody +makeFieldLabels ''MediaTypeObject makeFieldLabels ''Info makeFieldLabels ''Contact makeFieldLabels ''License @@ -83,22 +78,28 @@ makeFieldLabels ''PathItem makeFieldLabels ''Tag makeFieldLabels ''Operation makeFieldLabels ''Param -makeFieldLabels ''ParamOtherSchema makeFieldLabels ''Header makeFieldLabels ''Schema makeFieldLabels ''NamedSchema -makeFieldLabels ''ParamSchema makeFieldLabels ''Xml makeFieldLabels ''Responses makeFieldLabels ''Response makeFieldLabels ''SecurityScheme makeFieldLabels ''ApiKeyParams -makeFieldLabels ''OAuth2Params +makeFieldLabels ''OAuth2ImplicitFlow +makeFieldLabels ''OAuth2PasswordFlow +makeFieldLabels ''OAuth2ClientCredentialsFlow +makeFieldLabels ''OAuth2AuthorizationCodeFlow +makeFieldLabels ''OAuth2Flow +makeFieldLabels ''OAuth2Flows makeFieldLabels ''ExternalDocs +makeFieldLabels ''Encoding +makeFieldLabels ''Example +makeFieldLabels ''Discriminator +makeFieldLabels ''Link -- Prisms -makePrismLabels ''ParamAnySchema makePrismLabels ''SecuritySchemeType makePrismLabels ''Referenced @@ -109,8 +110,8 @@ instance , b ~ [Referenced Schema] ) => LabelOptic "_SwaggerItemsArray" A_Review - (SwaggerItems 'SwaggerKindSchema) - (SwaggerItems 'SwaggerKindSchema) + SwaggerItems + SwaggerItems a b where labelOptic = unto (\x -> SwaggerItemsArray x) @@ -121,25 +122,13 @@ instance , b ~ Referenced Schema ) => LabelOptic "_SwaggerItemsObject" A_Review - (SwaggerItems 'SwaggerKindSchema) - (SwaggerItems 'SwaggerKindSchema) + SwaggerItems + SwaggerItems a b where labelOptic = unto (\x -> SwaggerItemsObject x) {-# INLINE labelOptic #-} -instance - ( a ~ (Maybe (CollectionFormat t), ParamSchema t) - , b ~ (Maybe (CollectionFormat t), ParamSchema t) - ) => LabelOptic "_SwaggerItemsPrimitive" - A_Review - (SwaggerItems t) - (SwaggerItems t) - a - b where - labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p) - {-# INLINE labelOptic #-} - -- ============================================================= -- More helpful instances for easier access to schema properties @@ -163,435 +152,132 @@ instance At Operation where at n = #responses % at n {-# INLINE at #-} --- #paramSchema - -instance - ( a ~ ParamSchema 'SwaggerKindSchema - , b ~ ParamSchema 'SwaggerKindSchema - ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where - labelOptic = #schema % #paramSchema - {-# INLINE labelOptic #-} - -- #type instance - ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header)) - , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header)) - ) => LabelOptic "type" A_Lens Header Header a b where - labelOptic = #paramSchema % #type - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe (SwaggerType 'SwaggerKindSchema) - , b ~ Maybe (SwaggerType 'SwaggerKindSchema) - ) => LabelOptic "type" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #type - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe (SwaggerType 'SwaggerKindSchema) - , b ~ Maybe (SwaggerType 'SwaggerKindSchema) + ( a ~ Maybe SwaggerType + , b ~ Maybe SwaggerType ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #type - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema) - , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema) - ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #type + labelOptic = #schema % #type {-# INLINE labelOptic #-} -- #default -instance - ( a ~ Maybe Value, b ~ Maybe Value - ) => LabelOptic "default" A_Lens Header Header a b where - labelOptic = #paramSchema % #default - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Value, b ~ Maybe Value - ) => LabelOptic "default" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #default - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Value, b ~ Maybe Value ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #default - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Value, b ~ Maybe Value - ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #default + labelOptic = #schema % #default {-# INLINE labelOptic #-} -- #format -instance - ( a ~ Maybe Format, b ~ Maybe Format - ) => LabelOptic "format" A_Lens Header Header a b where - labelOptic = #paramSchema % #format - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Format, b ~ Maybe Format - ) => LabelOptic "format" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #format - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Format, b ~ Maybe Format ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #format - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Format, b ~ Maybe Format - ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #format + labelOptic = #schema % #format {-# INLINE labelOptic #-} -- #items instance - ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header)) - , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header)) - ) => LabelOptic "items" A_Lens Header Header a b where - labelOptic = #paramSchema % #items - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema) - , b ~ Maybe (SwaggerItems 'SwaggerKindSchema) - ) => LabelOptic "items" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #items - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema) - , b ~ Maybe (SwaggerItems 'SwaggerKindSchema) + ( a ~ Maybe SwaggerItems + , b ~ Maybe SwaggerItems ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #items - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema) - , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema) - ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #items + labelOptic = #schema % #items {-# INLINE labelOptic #-} -- #maximum -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "maximum" A_Lens Header Header a b where - labelOptic = #paramSchema % #maximum - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "maximum" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #maximum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #maximum - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #maximum + labelOptic = #schema % #maximum {-# INLINE labelOptic #-} -- #exclusiveMaximum -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where - labelOptic = #paramSchema % #exclusiveMaximum - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #exclusiveMaximum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #exclusiveMaximum - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #exclusiveMaximum + labelOptic = #schema % #exclusiveMaximum {-# INLINE labelOptic #-} -- #minimum -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "minimum" A_Lens Header Header a b where - labelOptic = #paramSchema % #minimum - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "minimum" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #minimum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #minimum - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #minimum + labelOptic = #schema % #minimum {-# INLINE labelOptic #-} -- #exclusiveMinimum -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where - labelOptic = #paramSchema % #exclusiveMinimum - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #exclusiveMinimum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #exclusiveMinimum - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #exclusiveMinimum + labelOptic = #schema % #exclusiveMinimum {-# INLINE labelOptic #-} -- #maxLength -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxLength" A_Lens Header Header a b where - labelOptic = #paramSchema % #maxLength - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxLength" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #maxLength - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #maxLength - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #maxLength + labelOptic = #schema % #maxLength {-# INLINE labelOptic #-} -- #minLength -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minLength" A_Lens Header Header a b where - labelOptic = #paramSchema % #minLength - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minLength" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #minLength - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #minLength - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #minLength + labelOptic = #schema % #minLength {-# INLINE labelOptic #-} -- #pattern -instance - ( a ~ Maybe Text, b ~ Maybe Text - ) => LabelOptic "pattern" A_Lens Header Header a b where - labelOptic = #paramSchema % #pattern - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Text, b ~ Maybe Text - ) => LabelOptic "pattern" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #pattern - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Text, b ~ Maybe Text ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #pattern - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Text, b ~ Maybe Text - ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #pattern + labelOptic = #schema % #pattern {-# INLINE labelOptic #-} -- #maxItems -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxItems" A_Lens Header Header a b where - labelOptic = #paramSchema % #maxItems - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxItems" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #maxItems - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #maxItems - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #maxItems + labelOptic = #schema % #maxItems {-# INLINE labelOptic #-} -- #minItems -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minItems" A_Lens Header Header a b where - labelOptic = #paramSchema % #minItems - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minItems" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #minItems - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Integer, b ~ Maybe Integer ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #minItems - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Integer, b ~ Maybe Integer - ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #minItems + labelOptic = #schema % #minItems {-# INLINE labelOptic #-} -- #uniqueItems -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "uniqueItems" A_Lens Header Header a b where - labelOptic = #paramSchema % #uniqueItems - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #uniqueItems - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Bool, b ~ Maybe Bool ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #uniqueItems - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Bool, b ~ Maybe Bool - ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #uniqueItems + labelOptic = #schema % #uniqueItems {-# INLINE labelOptic #-} -- #enum -instance - ( a ~ Maybe [Value], b ~ Maybe [Value] - ) => LabelOptic "enum" A_Lens Header Header a b where - labelOptic = #paramSchema % #enum - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe [Value], b ~ Maybe [Value] - ) => LabelOptic "enum" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #enum - {-# INLINE labelOptic #-} - instance ( a ~ Maybe [Value], b ~ Maybe [Value] ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #enum - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe [Value], b ~ Maybe [Value] - ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #enum + labelOptic = #schema % #enum {-# INLINE labelOptic #-} -- #multipleOf -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "multipleOf" A_Lens Header Header a b where - labelOptic = #paramSchema % #multipleOf - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where - labelOptic = #paramSchema % #multipleOf - {-# INLINE labelOptic #-} - instance ( a ~ Maybe Scientific, b ~ Maybe Scientific ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where - labelOptic = #paramSchema % #multipleOf - {-# INLINE labelOptic #-} - -instance - ( a ~ Maybe Scientific, b ~ Maybe Scientific - ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where - labelOptic = #paramSchema % #multipleOf + labelOptic = #schema % #multipleOf {-# INLINE labelOptic #-} diff --git a/src/Data/Swagger/ParamSchema.hs b/src/Data/Swagger/ParamSchema.hs index a1f851d2..046e241b 100644 --- a/src/Data/Swagger/ParamSchema.hs +++ b/src/Data/Swagger/ParamSchema.hs @@ -13,9 +13,9 @@ module Data.Swagger.ParamSchema ( toParamSchemaBoundedIntegral, -- * Schema templates - passwordParamSchema, - binaryParamSchema, - byteParamSchema, + passwordSchema, + binarySchema, + byteSchema, -- * Generic encoding configuration SchemaOptions(..), diff --git a/src/Data/Swagger/Schema.hs b/src/Data/Swagger/Schema.hs index 1fa72b44..2ae55c94 100644 --- a/src/Data/Swagger/Schema.hs +++ b/src/Data/Swagger/Schema.hs @@ -32,15 +32,6 @@ module Data.Swagger.Schema ( paramSchemaToNamedSchema, paramSchemaToSchema, - -- ** Unrestricted versions - genericDeclareNamedSchemaUnrestricted, - genericDeclareSchemaUnrestricted, - - -- * Schema templates - passwordSchema, - binarySchema, - byteSchema, - -- * Sketching @'Schema'@s using @'ToJSON'@ sketchSchema, sketchStrictSchema, diff --git a/src/Data/Swagger/Schema/Generator.hs b/src/Data/Swagger/Schema/Generator.hs index a5cca577..7349a23e 100644 --- a/src/Data/Swagger/Schema/Generator.hs +++ b/src/Data/Swagger/Schema/Generator.hs @@ -29,7 +29,9 @@ import Test.QuickCheck.Property -- and cannot be inferred. schemaGen :: Definitions Schema -> Schema -> Gen Value schemaGen _ schema - | Just cases <- schema ^. paramSchema . enum_ = elements cases + | Just cases <- schema ^. enum_ = elements cases +schemaGen defns schema + | Just variants <- schema ^. oneOf = schemaGen defns =<< elements (dereference defns <$> variants) schemaGen defns schema = case schema ^. type_ of Nothing -> @@ -94,10 +96,10 @@ schemaGen defns schema = _ -> return [] x <- sequence $ gens <> additionalGens return . Object $ M.toHashMap x - where - dereference :: Definitions a -> Referenced a -> a - dereference _ (Inline a) = a - dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs + +dereference :: Definitions a -> Referenced a -> a +dereference _ (Inline a) = a +dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs genValue :: (ToSchema a) => Proxy a -> Gen Value genValue p = diff --git a/src/Data/Swagger/SchemaOptions.hs b/src/Data/Swagger/SchemaOptions.hs index 5abb9bdf..0f950225 100644 --- a/src/Data/Swagger/SchemaOptions.hs +++ b/src/Data/Swagger/SchemaOptions.hs @@ -22,6 +22,8 @@ data SchemaOptions = SchemaOptions , allNullaryToStringTag :: Bool -- | Hide the field name when a record constructor has only one field, like a newtype. , unwrapUnaryRecords :: Bool + -- | Specifies how to encode constructors of a sum datatype. + , sumEncoding :: Aeson.SumEncoding } -- | Default encoding @'SchemaOptions'@. @@ -33,6 +35,7 @@ data SchemaOptions = SchemaOptions -- , 'datatypeNameModifier' = id -- , 'allNullaryToStringTag' = True -- , 'unwrapUnaryRecords' = False +-- , 'sumEncoding' = 'Aeson.defaultTaggedObject' -- } -- @ defaultSchemaOptions :: SchemaOptions @@ -42,6 +45,7 @@ defaultSchemaOptions = SchemaOptions , datatypeNameModifier = id , allNullaryToStringTag = True , unwrapUnaryRecords = False + , sumEncoding = Aeson.defaultTaggedObject } -- | Convert 'Aeson.Options' to 'SchemaOptions'. @@ -56,7 +60,6 @@ defaultSchemaOptions = SchemaOptions -- Note that these fields have no effect on `SchemaOptions`: -- -- * 'Aeson.omitNothingFields' --- * 'Aeson.sumEncoding' -- * 'Aeson.tagSingleConstructors' -- -- The rest is defined as in 'defaultSchemaOptions'. @@ -69,4 +72,5 @@ fromAesonOptions opts = defaultSchemaOptions , constructorTagModifier = Aeson.constructorTagModifier opts , allNullaryToStringTag = Aeson.allNullaryToStringTag opts , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts + , sumEncoding = Aeson.sumEncoding opts } diff --git a/swagger2.cabal b/swagger2.cabal index a24d8761..f2a96ff3 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -23,11 +23,9 @@ extra-source-files: , CHANGELOG.md , examples/*.hs tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 + GHC ==8.4.4 || ==8.6.5 - || ==8.8.1 + || ==8.8.3 || ==8.10.1 custom-setup @@ -59,16 +57,16 @@ library -- GHC boot libraries build-depends: - base >=4.9 && <4.15 - , bytestring >=0.10.8.1 && <0.11 - , containers >=0.5.7.1 && <0.7 - , template-haskell >=2.11.1.0 && <2.17 - , time >=1.6.0.1 && <1.10 - , transformers >=0.5.2.0 && <0.6 + base >=4.11.1.0 && <4.15 + , bytestring >=0.10.8.2 && <0.11 + , containers >=0.5.11.0 && <0.7 + , template-haskell >=2.13.0.0 && <2.17 + , time >=1.8.0.2 && <1.10 + , transformers >=0.5.5.0 && <0.6 build-depends: mtl >=2.2.2 && <2.3 - , text >=1.2.3.0 && <1.3 + , text >=1.2.3.1 && <1.3 -- other dependencies build-depends: diff --git a/test/Data/Swagger/CommonTestTypes.hs b/test/Data/Swagger/CommonTestTypes.hs index a799c068..9b6c8a60 100644 --- a/test/Data/Swagger/CommonTestTypes.hs +++ b/test/Data/Swagger/CommonTestTypes.hs @@ -88,7 +88,7 @@ paintSchemaJSON = [aesonQQ| { "color": { - "$ref": "#/definitions/Color" + "$ref": "#/components/schemas/Color" } }, "required": ["color"] @@ -181,7 +181,7 @@ userGroupSchemaJSON :: Value userGroupSchemaJSON = [aesonQQ| { "type": "array", - "items": { "$ref": "#/definitions/UserId" }, + "items": { "$ref": "#/components/schemas/UserId" }, "uniqueItems": true } |] @@ -228,7 +228,7 @@ playerSchemaJSON = [aesonQQ| { "position": { - "$ref": "#/definitions/Point" + "$ref": "#/components/schemas/Point" } }, "required": ["position"] @@ -250,7 +250,7 @@ playersSchemaJSON = [aesonQQ| { "position": { - "$ref": "#/definitions/Point" + "$ref": "#/components/schemas/Point" } }, "required": ["position"] @@ -271,106 +271,192 @@ instance ToSchema Character characterSchemaJSON :: Value characterSchemaJSON = [aesonQQ| { - "type": "object", - "properties": + "oneOf": [ { - "PC": { "$ref": "#/definitions/Player" }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/definitions/Point" } - }, - "required": ["npcName", "npcPosition"] + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "PC" + ] + }, + "contents": { + "$ref": "#/components/schemas/Player" } + } }, - "maxProperties": 1, - "minProperties": 1 + { + "required": [ + "npcName", + "npcPosition", + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "NPC" + ] + }, + "npcPosition": { + "$ref": "#/components/schemas/Point" + }, + "npcName": { + "type": "string" + } + } + } + ], + "type": "object" } + |] characterInlinedSchemaJSON :: Value characterInlinedSchemaJSON = [aesonQQ| { - "type": "object", - "properties": + "oneOf": [ { - "PC": - { + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "PC" + ] + }, + "contents": { + "required": [ + "position" + ], "type": "object", - "properties": - { - "position": - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] + "properties": { + "position": { + "required": [ + "x", + "y" + ], + "type": "object", + "properties": { + "x": { + "format": "double", + "type": "number" + }, + "y": { + "format": "double", + "type": "number" } - }, - "required": ["position"] + } + } + } + } + } + }, + { + "required": [ + "npcName", + "npcPosition", + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "NPC" + ] }, - "NPC": - { + "npcPosition": { + "required": [ + "x", + "y" + ], "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] - } + "properties": { + "x": { + "format": "double", + "type": "number" }, - "required": ["npcName", "npcPosition"] + "y": { + "format": "double", + "type": "number" + } + } + }, + "npcName": { + "type": "string" } - }, - "maxProperties": 1, - "minProperties": 1 + } + } + ], + "type": "object" } |] characterInlinedPlayerSchemaJSON :: Value characterInlinedPlayerSchemaJSON = [aesonQQ| { - "type": "object", - "properties": + "oneOf": [ { - "PC": - { - "type": "object", - "properties": - { - "position": - { - "$ref": "#/definitions/Point" - } - }, - "required": ["position"] + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "PC" + ] }, - "NPC": - { + "contents": { + "required": [ + "position" + ], "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/definitions/Point" } - }, - "required": ["npcName", "npcPosition"] + "properties": { + "position": { + "$ref": "#/components/schemas/Point" + } + } } + } }, - "maxProperties": 1, - "minProperties": 1 + { + "required": [ + "npcName", + "npcPosition", + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "NPC" + ] + }, + "npcPosition": { + "$ref": "#/components/schemas/Point" + }, + "npcName": { + "type": "string" + } + } + } + ], + "type": "object" } |] @@ -482,7 +568,7 @@ myRoseTreeSchemaJSON = [aesonQQ| "type": "array", "items": { - "$ref": "#/definitions/RoseTree" + "$ref": "#/components/schemas/RoseTree" } } }, @@ -511,7 +597,7 @@ myRoseTreeSchemaJSON' = [aesonQQ| "type": "array", "items": { - "$ref": "#/definitions/myrosetree'" + "$ref": "#/components/schemas/myrosetree'" } } }, @@ -542,42 +628,169 @@ data Light deriving (Generic) instance ToSchema Light where - declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { unwrapUnaryRecords = True } lightSchemaJSON :: Value lightSchemaJSON = [aesonQQ| { - "type": "object", - "properties": + "oneOf": [ { - "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] }, - "LightFreq": { "type": "number", "format": "double" }, - "LightColor": { "$ref": "#/definitions/Color" }, - "LightWaveLength": { "type": "number", "format": "double" } + "required": [ + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "NoLight" + ] + } + } }, - "maxProperties": 1, - "minProperties": 1 + { + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightFreq" + ] + }, + "contents": { + "format": "double", + "type": "number" + } + } + }, + { + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightColor" + ] + }, + "contents": { + "$ref": "#/components/schemas/Color" + } + } + }, + { + "required": [ + "waveLength", + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightWaveLength" + ] + }, + "waveLength": { + "format": "double", + "type": "number" + } + } + } + ], + "type": "object" } |] lightInlinedSchemaJSON :: Value lightInlinedSchemaJSON = [aesonQQ| { - "type": "object", - "properties": + "oneOf": [ { - "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] }, - "LightFreq": { "type": "number", "format": "double" }, - "LightColor": - { + "required": [ + "tag" + ], + "type": "object", + "properties": { + "tag": { "type": "string", - "enum": ["Red", "Green", "Blue"] + "enum": [ + "NoLight" + ] + } + } + }, + { + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightFreq" + ] + }, + "contents": { + "format": "double", + "type": "number" + } + } + }, + { + "required": [ + "tag", + "contents" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightColor" + ] }, - "LightWaveLength": { "type": "number", "format": "double" } + "contents": { + "type": "string", + "enum": [ + "Red", + "Green", + "Blue" + ] + } + } }, - "maxProperties": 1, - "minProperties": 1 + { + "required": [ + "waveLength", + "tag" + ], + "type": "object", + "properties": { + "tag": { + "type": "string", + "enum": [ + "LightWaveLength" + ] + }, + "waveLength": { + "format": "double", + "type": "number" + } + } + } + ], + "type": "object" } |] diff --git a/test/Data/Swagger/ParamSchemaSpec.hs b/test/Data/Swagger/ParamSchemaSpec.hs index 07238641..49c820c0 100644 --- a/test/Data/Swagger/ParamSchemaSpec.hs +++ b/test/Data/Swagger/ParamSchemaSpec.hs @@ -13,7 +13,6 @@ import Data.Proxy import GHC.Generics import Data.Swagger -import Data.Swagger.Internal (SwaggerKind(..)) import Data.Swagger.CommonTestTypes import SpecCommon @@ -23,7 +22,7 @@ import Data.Time.LocalTime import qualified Data.HashMap.Strict as HM checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec -checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js +checkToParamSchema proxy js = (toParamSchema proxy :: Schema) <=> js spec :: Spec spec = do diff --git a/test/Data/Swagger/Schema/ValidationSpec.hs b/test/Data/Swagger/Schema/ValidationSpec.hs index beade4b3..5d06dd70 100644 --- a/test/Data/Swagger/Schema/ValidationSpec.hs +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -91,6 +91,8 @@ spec = do prop "Paint" $ shouldValidate (Proxy :: Proxy Paint) prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree) prop "Light" $ shouldValidate (Proxy :: Proxy Light) + prop "Light TaggedObject" $ shouldValidate (Proxy :: Proxy LightTaggedObject) + prop "Light UntaggedValue" $ shouldValidate (Proxy :: Proxy LightUntaggedValue) prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages) prop "Version" $ shouldValidate (Proxy :: Proxy Version) prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm) @@ -188,10 +190,10 @@ instance Arbitrary MyRoseTree where data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic) instance ToSchema Light where - declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { Data.Swagger.sumEncoding = ObjectWithSingleField } instance ToJSON Light where - toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField } + toJSON = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = ObjectWithSingleField } instance Arbitrary Light where arbitrary = oneof @@ -203,6 +205,34 @@ instance Arbitrary Light where invalidLightToJSON :: Light -> Value invalidLightToJSON = genericToJSON defaultOptions +-- Check all SumEncoding flavors. + +newtype LightTaggedObject = LightTaggedObject Light + deriving (Show) + +instance ToJSON LightTaggedObject where + toJSON (LightTaggedObject light) = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = defaultTaggedObject } light + +instance ToSchema LightTaggedObject where + declareNamedSchema _ = + genericDeclareNamedSchema defaultSchemaOptions { Data.Swagger.sumEncoding = defaultTaggedObject } (Proxy :: Proxy Light) + +instance Arbitrary LightTaggedObject where + arbitrary = LightTaggedObject <$> arbitrary + +newtype LightUntaggedValue = LightUntaggedValue Light + deriving (Show) + +instance ToJSON LightUntaggedValue where + toJSON (LightUntaggedValue light) = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = UntaggedValue } light + +instance ToSchema LightUntaggedValue where + declareNamedSchema _ = + genericDeclareNamedSchema defaultSchemaOptions { Data.Swagger.sumEncoding = UntaggedValue } (Proxy :: Proxy Light) + +instance Arbitrary LightUntaggedValue where + arbitrary = LightUntaggedValue <$> arbitrary + -- ======================================================================== -- ButtonImages (bounded enum key mapping) -- ======================================================================== diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs index 9750d1c6..8364e72e 100644 --- a/test/Data/Swagger/SchemaSpec.hs +++ b/test/Data/Swagger/SchemaSpec.hs @@ -24,37 +24,37 @@ import Test.Hspec import qualified Data.HashMap.Strict as HM import Data.Time.LocalTime -checkToSchema :: ToSchema a => Proxy a -> Value -> Spec +checkToSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec checkToSchema proxy js = toSchema proxy <=> js -checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec +checkSchemaName :: (HasCallStack, ToSchema a) => Maybe String -> Proxy a -> Spec checkSchemaName sname proxy = it ("schema name is " ++ show sname) $ schemaName proxy `shouldBe` fmap Text.pack sname -checkDefs :: ToSchema a => Proxy a -> [String] -> Spec +checkDefs :: (HasCallStack, ToSchema a) => Proxy a -> [String] -> Spec checkDefs proxy names = it ("uses these definitions " ++ show names) $ InsOrdHashMap.keys defs `shouldBe` map Text.pack names where defs = execDeclare (declareNamedSchema proxy) mempty -checkProperties :: ToSchema a => Proxy a -> [String] -> Spec +checkProperties :: (HasCallStack, ToSchema a) => Proxy a -> [String] -> Spec checkProperties proxy names = it ("has these fields in order " ++ show names) $ InsOrdHashMap.keys fields `shouldBe` map Text.pack names where fields = toSchema proxy ^. properties -checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec +checkInlinedSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec checkInlinedSchema proxy js = toInlinedSchema proxy <=> js -checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec +checkInlinedSchemas :: (HasCallStack, ToSchema a) => [String] -> Proxy a -> Value -> Spec checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js where (defs, s) = runDeclare (declareSchema proxy) mempty -checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec +checkInlinedRecSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js where (defs, s) = runDeclare (declareSchema proxy) mempty diff --git a/test/Data/SwaggerSpec.hs b/test/Data/SwaggerSpec.hs index 46ce52f7..517233b0 100644 --- a/test/Data/SwaggerSpec.hs +++ b/test/Data/SwaggerSpec.hs @@ -21,14 +21,6 @@ import Test.Hspec hiding (example) spec :: Spec spec = do - describe "host" $ do - it "can decode the host port" $ do - let h = Just $ Host "localhost" (Just (fromInteger 8000)) - swagger :: Swagger - swagger = swaggerExample - & host .~ h - parsed :: Swagger = either error id $ eitherDecode' $ encode swagger - parsed ^. host `shouldBe` h describe "License Object" $ licenseExample <=> licenseExampleJSON describe "Contact Object" $ contactExample <=> contactExampleJSON describe "Info Object" $ infoExample <=> infoExampleJSON @@ -48,9 +40,11 @@ spec = do describe "Swagger Object" $ do context "Example with no paths" $ emptyPathsFieldExample <=> emptyPathsFieldExampleJSON context "Todo Example" $ swaggerExample <=> swaggerExampleJSON - context "PetStore Example" $ + context "PetStore Example" $ do it "decodes successfully" $ do fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: Swagger) -> True; _ -> False) + it "roundtrips: fmap toJSON . fromJSON" $ do + (toJSON :: Swagger -> Value) <$> fromJSON petstoreExampleJSON `shouldBe` Success petstoreExampleJSON main :: IO () main = hspec spec @@ -133,34 +127,23 @@ operationExample = mempty & 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) - ] - + & parameters .~ [Inline (mempty + & name .~ "petId" + & description ?~ "ID of pet that needs to be updated" + & required ?~ True + & in_ .~ ParamPath + & schema ?~ Inline (mempty & type_ ?~ SwaggerString))] + & requestBody ?~ Inline ( + mempty & content . at "application/x-www-form-urlencoded" ?~ (mempty & schema ?~ (Inline (mempty + & properties . at "petId" ?~ Inline (mempty + & description ?~ "Updated name of the pet" + & type_ ?~ SwaggerString) + & properties . at "status" ?~ Inline (mempty + & description ?~ "Updated status of the pet" + & type_ ?~ SwaggerString))))) & at 200 ?~ "Pet updated." & at 405 ?~ "Invalid input" & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]] - where - stringSchema :: ParamLocation -> ParamOtherSchema - stringSchema loc = mempty - & in_ .~ loc - & type_ ?~ SwaggerString operationExampleJSON :: Value operationExampleJSON = [aesonQQ| @@ -171,36 +154,35 @@ operationExampleJSON = [aesonQQ| "summary": "Updates a pet in the store with form data", "description": "", "operationId": "updatePetWithForm", - "consumes": [ - "application/x-www-form-urlencoded" - ], - "produces": [ - "application/json", - "application/xml" - ], "parameters": [ { - "name": "petId", - "in": "path", - "description": "ID of pet that needs to be updated", "required": true, - "type": "string" - }, - { - "name": "name", - "in": "formData", - "description": "Updated name of the pet", - "required": false, - "type": "string" - }, - { - "name": "status", - "in": "formData", - "description": "Updated status of the pet", - "required": false, - "type": "string" + "schema": { + "type": "string" + }, + "in": "path", + "name": "petId", + "description": "ID of pet that needs to be updated" } ], + "requestBody": { + "content": { + "application/x-www-form-urlencoded": { + "schema": { + "properties": { + "petId": { + "type": "string", + "description": "Updated name of the pet" + }, + "status": { + "type": "string", + "description": "Updated status of the pet" + } + } + } + } + } + }, "responses": { "200": { "description": "Pet updated." @@ -251,24 +233,21 @@ schemaSimpleModelExample = mempty schemaSimpleModelExampleJSON :: Value schemaSimpleModelExampleJSON = [aesonQQ| -{ - "type": "object", - "required": [ - "name" - ], +{ "required": [ "name" ], "properties": { "name": { "type": "string" }, "address": { - "$ref": "#/definitions/Address" + "$ref": "#/components/schemas/Address" }, "age": { - "type": "integer", "format": "int32", - "minimum": 0 + "minimum": 0, + "type": "integer" } - } + }, + "type": "object" } |] @@ -401,16 +380,16 @@ paramsDefinitionExample = & name .~ "skip" & description ?~ "number of items to skip" & required ?~ True - & schema .~ ParamOther (mempty - & in_ .~ ParamQuery + & in_ .~ ParamQuery + & schema ?~ Inline (mempty & type_ ?~ SwaggerInteger & format ?~ "int32" )) , ("limitParam", mempty & name .~ "limit" & description ?~ "max records to return" & required ?~ True - & schema .~ ParamOther (mempty - & in_ .~ ParamQuery + & in_ .~ ParamQuery + & schema ?~ Inline (mempty & type_ ?~ SwaggerInteger & format ?~ "int32" )) ] @@ -422,16 +401,20 @@ paramsDefinitionExampleJSON = [aesonQQ| "in": "query", "description": "number of items to skip", "required": true, - "type": "integer", - "format": "int32" + "schema": { + "type": "integer", + "format": "int32" + } }, "limitParam": { "name": "limit", "in": "query", "description": "max records to return", "required": true, - "type": "integer", - "format": "int32" + "schema": { + "type": "integer", + "format": "int32" + } } } |] @@ -467,39 +450,45 @@ securityDefinitionsExample = SecurityDefinitions { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader) , _securitySchemeDescription = Nothing }) , ("petstore_auth", SecurityScheme - { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params - { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog" - , _oauth2Scopes = - [ ("write:pets", "modify pets in your account") - , ("read:pets", "read your pets") ] } ) + { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow + { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" + , _oAath2RefreshUrl = Nothing + , _oAuth2Scopes = + [ ("write:pets", "modify pets in your account") + , ("read:pets", "read your pets") ] } ) , _securitySchemeDescription = Nothing }) ] securityDefinitionsExampleJSON :: Value securityDefinitionsExampleJSON = [aesonQQ| { "api_key": { - "type": "apiKey", + "in": "header", "name": "api_key", - "in": "header" + "type": "apiKey" }, "petstore_auth": { "type": "oauth2", - "authorizationUrl": "http://swagger.io/api/oauth/dialog", - "flow": "implicit", - "scopes": { - "write:pets": "modify pets in your account", - "read:pets": "read your pets" + "flows": { + "implicit": { + "scopes": { + "write:pets": "modify pets in your account", + "read:pets": "read your pets" + }, + "authorizationUrl": "http://swagger.io/api/oauth/dialog" + } } } } + |] oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions oAuth2SecurityDefinitionsReadExample = SecurityDefinitions [ ("petstore_auth", SecurityScheme - { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params - { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog" - , _oauth2Scopes = + { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow + { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" + , _oAath2RefreshUrl = Nothing + , _oAuth2Scopes = [ ("read:pets", "read your pets") ] } ) , _securitySchemeDescription = Nothing }) ] @@ -507,10 +496,11 @@ oAuth2SecurityDefinitionsReadExample = SecurityDefinitions oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions [ ("petstore_auth", SecurityScheme - { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params - { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog" - , _oauth2Scopes = - [ ("write:pets", "modify pets in your account") ] } ) + { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow + { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" + , _oAath2RefreshUrl = Nothing + , _oAuth2Scopes = + [ ("write:pets", "modify pets in your account") ] } ) , _securitySchemeDescription = Nothing }) ] @@ -524,11 +514,14 @@ oAuth2SecurityDefinitionsExampleJSON = [aesonQQ| { "petstore_auth": { "type": "oauth2", - "authorizationUrl": "http://swagger.io/api/oauth/dialog", - "flow": "implicit", - "scopes": { - "write:pets": "modify pets in your account", - "read:pets": "read your pets" + "flows": { + "implicit": { + "scopes": { + "write:pets": "modify pets in your account", + "read:pets": "read your pets" + }, + "authorizationUrl": "http://swagger.io/api/oauth/dialog" + } } } } @@ -544,57 +537,54 @@ emptyPathsFieldExample = mempty emptyPathsFieldExampleJSON :: Value emptyPathsFieldExampleJSON = [aesonQQ| { - "swagger": "2.0", + "openapi": "3.0.0", "info": {"version": "", "title": ""}, - "paths": {} + "paths": {}, + "components": {} } |] swaggerExample :: Swagger swaggerExample = mempty - & basePath ?~ "/" - & schemes ?~ [Http] + -- & 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") + & description ?~ "This is an API that tests servant-swagger support for a Todo API") & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation) - & at 200 ?~ Inline (mempty + & responses . 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" ] + & content . at "application/json" ?~ (mempty + & 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))]))) & parameters .~ [ Inline $ mempty & required ?~ True & name .~ "id" & description ?~ "TodoId param" - & schema .~ ParamOther (mempty - & in_ .~ ParamPath + & in_ .~ ParamPath + & schema ?~ Inline (mempty & type_ ?~ SwaggerString ) ] & tags .~ InsOrdHS.fromList [ "todo" ] )) swaggerExampleJSON :: Value swaggerExampleJSON = [aesonQQ| { - "swagger": "2.0", - "basePath": "/", - "schemes": [ - "http" - ], + "openapi": "3.0.0", "info": { "version": "1.0", "title": "Todo API", @@ -602,1085 +592,326 @@ swaggerExampleJSON = [aesonQQ| "url": "http://mit.com", "name": "MIT" }, - "description": "This is a an API that tests servant-swagger support for a Todo API" + "description": "This is an API that tests servant-swagger support for a Todo API" }, "paths": { "/todo/{id}": { "get": { - "responses": { - "200": { - "schema": { - "example": { - "created": 100, - "description": "get milk" - }, - "type": "object", - "description": "This is some real Todo right here", - "properties": { - "created": { - "format": "int32", - "type": "integer" - }, - "description": { - "type": "string" - } - } - }, - "description": "OK" - } - }, - "produces": [ - "application/json" + "tags": [ + "todo" ], "parameters": [ { "required": true, + "schema": { + "type": "string" + }, "in": "path", "name": "id", - "type": "string", "description": "TodoId param" } ], - "tags": [ - "todo" - ] + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "example": { + "created": 100, + "description": "get milk" + }, + "type": "object", + "description": "This is some real Todo right here", + "properties": { + "created": { + "format": "int32", + "type": "integer" + }, + "description": { + "type": "string" + } + } + } + } + }, + "description": "OK" + } + } } } - } + }, + "components": {} } |] petstoreExampleJSON :: Value petstoreExampleJSON = [aesonQQ| { - "swagger":"2.0", - "info":{ - "description":"This is a sample server Petstore server. You can find out more about Swagger at [http://swagger.io](http://swagger.io) or on [irc.freenode.net, #swagger](http://swagger.io/irc/). For this sample, you can use the api key `special-key` to test the authorization filters.", - "version":"1.0.0", - "title":"Swagger Petstore", - "termsOfService":"http://swagger.io/terms/", - "contact":{ - "email":"apiteam@swagger.io" - }, - "license":{ - "name":"Apache 2.0", - "url":"http://www.apache.org/licenses/LICENSE-2.0.html" - } - }, - "host":"petstore.swagger.io", - "basePath":"/v2", - "tags":[ - { - "name":"pet", - "description":"Everything about your Pets", - "externalDocs":{ - "description":"Find out more", - "url":"http://swagger.io" - } - }, - { - "name":"store", - "description":"Access to Petstore orders" - }, - { - "name":"user", - "description":"Operations about user", - "externalDocs":{ - "description":"Find out more about our store", - "url":"http://swagger.io" - } - } - ], - "schemes":[ - "http" - ], - "paths":{ - "/pet":{ - "post":{ - "tags":[ - "pet" - ], - "summary":"Add a new pet to the store", - "description":"", - "operationId":"addPet", - "consumes":[ - "application/json", - "application/xml" - ], - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"Pet object that needs to be added to the store", - "required":true, - "schema":{ - "$ref":"#/definitions/Pet" - } - } - ], - "responses":{ - "405":{ - "description":"Invalid input" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - }, - "put":{ - "tags":[ - "pet" - ], - "summary":"Update an existing pet", - "description":"", - "operationId":"updatePet", - "consumes":[ - "application/json", - "application/xml" - ], - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"Pet object that needs to be added to the store", - "required":true, - "schema":{ - "$ref":"#/definitions/Pet" - } - } - ], - "responses":{ - "400":{ - "description":"Invalid ID supplied" - }, - "404":{ - "description":"Pet not found" - }, - "405":{ - "description":"Validation exception" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - } - }, - "/pet/findByStatus":{ - "get":{ - "tags":[ - "pet" - ], - "summary":"Finds Pets by status", - "description":"Multiple status values can be provided with comma seperated strings", - "operationId":"findPetsByStatus", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"status", - "in":"query", - "description":"Status values that need to be considered for filter", - "required":true, - "type":"array", - "items":{ - "type":"string", - "enum":[ - "available", - "pending", - "sold" - ], - "default":"available" - }, - "collectionFormat":"csv" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "type":"array", - "items":{ - "$ref":"#/definitions/Pet" - } - } - }, - "400":{ - "description":"Invalid status value" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - } - }, - "/pet/findByTags":{ - "get":{ - "tags":[ - "pet" - ], - "summary":"Finds Pets by tags", - "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.", - "operationId":"findPetsByTags", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"tags", - "in":"query", - "description":"Tags to filter by", - "required":true, - "type":"array", - "items":{ - "type":"string" - }, - "collectionFormat":"csv" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "type":"array", - "items":{ - "$ref":"#/definitions/Pet" - } - } - }, - "400":{ - "description":"Invalid tag value" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - } - }, - "/pet/{petId}":{ - "get":{ - "tags":[ - "pet" - ], - "summary":"Find pet by ID", - "description":"Returns a single pet", - "operationId":"getPetById", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"petId", - "in":"path", - "description":"ID of pet to return", - "required":true, - "type":"integer", - "format":"int64" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "$ref":"#/definitions/Pet" - } - }, - "400":{ - "description":"Invalid ID supplied" - }, - "404":{ - "description":"Pet not found" - } - }, - "security":[ - { - "api_key": [] - } - ] - }, - "post":{ - "tags":[ - "pet" - ], - "summary":"Updates a pet in the store with form data", - "description":"", - "operationId":"updatePetWithForm", - "consumes":[ - "application/x-www-form-urlencoded" - ], - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"petId", - "in":"path", - "description":"ID of pet that needs to be updated", - "required":true, - "type":"integer", - "format":"int64" - }, - { - "name":"name", - "in":"formData", - "description":"Updated name of the pet", - "required":false, - "type":"string" - }, - { - "name":"status", - "in":"formData", - "description":"Updated status of the pet", - "required":false, - "type":"string" - } - ], - "responses":{ - "405":{ - "description":"Invalid input" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - }, - "delete":{ - "tags":[ - "pet" - ], - "summary":"Deletes a pet", - "description":"", - "operationId":"deletePet", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"api_key", - "in":"header", - "required":false, - "type":"string" - }, - { - "name":"petId", - "in":"path", - "description":"Pet id to delete", - "required":true, - "type":"integer", - "format":"int64" - } - ], - "responses":{ - "400":{ - "description":"Invalid pet value" - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - } - }, - "/pet/{petId}/uploadImage":{ - "post":{ - "tags":[ - "pet" - ], - "summary":"uploads an image", - "description":"", - "operationId":"uploadFile", - "consumes":[ - "multipart/form-data" - ], - "produces":[ - "application/json" - ], - "parameters":[ - { - "name":"petId", - "in":"path", - "description":"ID of pet to update", - "required":true, - "type":"integer", - "format":"int64" - }, - { - "name":"additionalMetadata", - "in":"formData", - "description":"Additional data to pass to server", - "required":false, - "type":"string" - }, - { - "name":"file", - "in":"formData", - "description":"file to upload", - "required":false, - "type":"file" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "$ref":"#/definitions/ApiResponse" - } - } - }, - "security":[ - { - "petstore_auth":[ - "write:pets", - "read:pets" - ] - } - ] - } - }, - "/store/inventory":{ - "get":{ - "tags":[ - "store" - ], - "summary":"Returns pet inventories by status", - "description":"Returns a map of status codes to quantities", - "operationId":"getInventory", - "produces":[ - "application/json" - ], - "parameters": [], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "type":"object", - "additionalProperties":{ - "type":"integer", - "format":"int32" - } - } - } - }, - "security":[ - { - "api_key": [] - } - ] - } - }, - "/store/order":{ - "post":{ - "tags":[ - "store" - ], - "summary":"Place an order for a pet", - "description":"", - "operationId":"placeOrder", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"order placed for purchasing the pet", - "required":true, - "schema":{ - "$ref":"#/definitions/Order" - } - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "$ref":"#/definitions/Order" - } - }, - "400":{ - "description":"Invalid Order" - } - } - } - }, - "/store/order/{orderId}":{ - "get":{ - "tags":[ - "store" - ], - "summary":"Find purchase order by ID", - "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions", - "operationId":"getOrderById", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"orderId", - "in":"path", - "description":"ID of pet that needs to be fetched", - "required":true, - "type":"integer", - "maximum":5.0, - "minimum":1.0, - "format":"int64" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "$ref":"#/definitions/Order" - } - }, - "400":{ - "description":"Invalid ID supplied" - }, - "404":{ - "description":"Order not found" - } - } - }, - "delete":{ - "tags":[ - "store" - ], - "summary":"Delete purchase order by ID", - "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors", - "operationId":"deleteOrder", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"orderId", - "in":"path", - "description":"ID of the order that needs to be deleted", - "required":true, - "type":"string", - "minimum":1.0 - } - ], - "responses":{ - "400":{ - "description":"Invalid ID supplied" - }, - "404":{ - "description":"Order not found" - } - } - } - }, - "/user":{ - "post":{ - "tags":[ - "user" - ], - "summary":"Create user", - "description":"This can only be done by the logged in user.", - "operationId":"createUser", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"Created user object", - "required":true, - "schema":{ - "$ref":"#/definitions/User" - } - } - ], - "responses":{ - "default":{ - "description":"successful operation" - } + "openapi": "3.0.0", + "info": { + "version": "1.0.0", + "title": "Swagger Petstore", + "license": { + "name": "MIT" + } + }, + "servers": [ + { + "url": "http://petstore.swagger.io/v1" + } + ], + "paths": { + "/pets": { + "get": { + "summary": "List all pets", + "operationId": "listPets", + "tags": [ + "pets" + ], + "parameters": [ + { + "name": "limit", + "in": "query", + "description": "How many items to return at one time (max 100)", + "required": false, + "schema": { + "type": "integer", + "format": "int32" } - } - }, - "/user/createWithArray":{ - "post":{ - "tags":[ - "user" - ], - "summary":"Creates list of users with given input array", - "description":"", - "operationId":"createUsersWithArrayInput", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"List of user object", - "required":true, - "schema":{ - "type":"array", - "items":{ - "$ref":"#/definitions/User" - } + } + ], + "responses": { + "200": { + "description": "A paged array of pets", + "headers": { + "x-next": { + "description": "A link to the next page of responses", + "schema": { + "type": "string" + } + } + }, + "content": { + "application/json": { + "schema": { + "type": "array", + "items": { + "type": "object", + "required": [ + "id", + "name" + ], + "properties": { + "id": { + "type": "integer", + "format": "int64" + }, + "name": { + "type": "string" + }, + "tag": { + "type": "string" + } + } } - } - ], - "responses":{ - "default":{ - "description":"successful operation" - } + } + } } - } - }, - "/user/createWithList":{ - "post":{ - "tags":[ - "user" - ], - "summary":"Creates list of users with given input array", - "description":"", - "operationId":"createUsersWithListInput", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "in":"body", - "name":"body", - "description":"List of user object", - "required":true, - "schema":{ - "type":"array", - "items":{ - "$ref":"#/definitions/User" - } + }, + "default": { + "description": "unexpected error", + "content": { + "application/json": { + "schema": { + "type": "object", + "required": [ + "code", + "message" + ], + "properties": { + "code": { + "type": "integer", + "format": "int32" + }, + "message": { + "type": "string" + } } - } - ], - "responses":{ - "default":{ - "description":"successful operation" - } + } + } } - } + } + } }, - "/user/login":{ - "get":{ - "tags":[ - "user" - ], - "summary":"Logs user into the system", - "description":"", - "operationId":"loginUser", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"username", - "in":"query", - "description":"The user name for login", - "required":true, - "type":"string" - }, - { - "name":"password", - "in":"query", - "description":"The password for login in clear text", - "required":true, - "type":"string" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "type":"string" - }, - "headers":{ - "X-Rate-Limit":{ - "type":"integer", - "format":"int32", - "description":"calls per hour allowed by the user" - }, - "X-Expires-After":{ - "type":"string", - "format":"date-time", - "description":"date in UTC when toekn expires" - } + "post": { + "summary": "Create a pet", + "operationId": "createPets", + "tags": [ + "pets" + ], + "responses": { + "201": { + "description": "Null response" + }, + "default": { + "description": "unexpected error", + "content": { + "application/json": { + "schema": { + "type": "object", + "required": [ + "code", + "message" + ], + "properties": { + "code": { + "type": "integer", + "format": "int32" + }, + "message": { + "type": "string" + } } - }, - "400":{ - "description":"Invalid username/password supplied" - } + } + } } - } - }, - "/user/logout":{ - "get":{ - "tags":[ - "user" - ], - "summary":"Logs out current logged in user session", - "description":"", - "operationId":"logoutUser", - "produces":[ - "application/xml", - "application/json" - ], - "parameters": [], - "responses":{ - "default":{ - "description":"successful operation" - } + } + } + } + }, + "/pets/{petId}": { + "get": { + "summary": "Info for a specific pet", + "operationId": "showPetById", + "tags": [ + "pets" + ], + "parameters": [ + { + "name": "petId", + "in": "path", + "required": true, + "description": "The id of the pet to retrieve", + "schema": { + "type": "string" } - } - }, - "/user/{username}":{ - "get":{ - "tags":[ - "user" - ], - "summary":"Get user by user name", - "description":"", - "operationId":"getUserByName", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"username", - "in":"path", - "description":"The name that needs to be fetched. Use user1 for testing. ", - "required":true, - "type":"string" - } - ], - "responses":{ - "200":{ - "description":"successful operation", - "schema":{ - "$ref":"#/definitions/User" + } + ], + "responses": { + "200": { + "description": "Expected response to a valid request", + "content": { + "application/json": { + "schema": { + "type": "object", + "required": [ + "id", + "name" + ], + "properties": { + "id": { + "type": "integer", + "format": "int64" + }, + "name": { + "type": "string" + }, + "tag": { + "type": "string" + } } - }, - "400":{ - "description":"Invalid username supplied" - }, - "404":{ - "description":"User not found" - } + } + } } - }, - "put":{ - "tags":[ - "user" - ], - "summary":"Updated user", - "description":"This can only be done by the logged in user.", - "operationId":"updateUser", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"username", - "in":"path", - "description":"name that need to be deleted", - "required":true, - "type":"string" - }, - { - "in":"body", - "name":"body", - "description":"Updated user object", - "required":true, - "schema":{ - "$ref":"#/definitions/User" + }, + "default": { + "description": "unexpected error", + "content": { + "application/json": { + "schema": { + "type": "object", + "required": [ + "code", + "message" + ], + "properties": { + "code": { + "type": "integer", + "format": "int32" + }, + "message": { + "type": "string" + } } - } - ], - "responses":{ - "400":{ - "description":"Invalid user supplied" - }, - "404":{ - "description":"User not found" - } + } + } } - }, - "delete":{ - "tags":[ - "user" - ], - "summary":"Delete user", - "description":"This can only be done by the logged in user.", - "operationId":"deleteUser", - "produces":[ - "application/xml", - "application/json" - ], - "parameters":[ - { - "name":"username", - "in":"path", - "description":"The name that needs to be deleted", - "required":true, - "type":"string" - } - ], - "responses":{ - "400":{ - "description":"Invalid username supplied" - }, - "404":{ - "description":"User not found" - } - } - } - } - }, - "securityDefinitions":{ - "petstore_auth":{ - "type":"oauth2", - "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog", - "flow":"implicit", - "scopes":{ - "write:pets":"modify pets in your account", - "read:pets":"read your pets" - } - }, - "api_key":{ - "type":"apiKey", - "name":"api_key", - "in":"header" + } + } } - }, - "definitions":{ - "Order":{ - "type":"object", - "properties":{ - "id":{ - "type":"integer", - "format":"int64" - }, - "petId":{ - "type":"integer", - "format":"int64" - }, - "quantity":{ - "type":"integer", - "format":"int32" - }, - "shipDate":{ - "type":"string", - "format":"date-time" - }, - "status":{ - "type":"string", - "description":"Order Status", - "enum":[ - "placed", - "approved", - "delivered" - ] - }, - "complete":{ - "type":"boolean", - "default":false - } - }, - "xml":{ - "name":"Order" - } - }, - "Category":{ - "type":"object", - "properties":{ - "id":{ - "type":"integer", - "format":"int64" - }, - "name":{ - "type":"string" - } - }, - "xml":{ - "name":"Category" - } - }, - "User":{ - "type":"object", - "properties":{ - "id":{ - "type":"integer", - "format":"int64" - }, - "username":{ - "type":"string" - }, - "firstName":{ - "type":"string" - }, - "lastName":{ - "type":"string" - }, - "email":{ - "type":"string" - }, - "password":{ - "type":"string" - }, - "phone":{ - "type":"string" - }, - "userStatus":{ - "type":"integer", - "format":"int32", - "description":"User Status" - } - }, - "xml":{ - "name":"User" - } - }, - "Tag":{ - "type":"object", - "properties":{ - "id":{ - "type":"integer", - "format":"int64" - }, - "name":{ - "type":"string" - } - }, - "xml":{ - "name":"Tag" - } + } + }, + "components": { + "schemas": { + "Pet": { + "type": "object", + "required": [ + "id", + "name" + ], + "properties": { + "id": { + "type": "integer", + "format": "int64" + }, + "name": { + "type": "string" + }, + "tag": { + "type": "string" + } + } }, - "Pet":{ - "type":"object", - "required":[ - "name", - "photoUrls" - ], - "properties":{ - "id":{ - "type":"integer", - "format":"int64" - }, - "category":{ - "$ref":"#/definitions/Category" - }, - "name":{ - "type":"string", - "example":"doggie" + "Pets": { + "type": "array", + "items": { + "type": "object", + "required": [ + "id", + "name" + ], + "properties": { + "id": { + "type": "integer", + "format": "int64" }, - "photoUrls":{ - "type":"array", - "xml":{ - "name":"photoUrl", - "wrapped":true - }, - "items":{ - "type":"string" - } + "name": { + "type": "string" }, - "tags":{ - "type":"array", - "xml":{ - "name":"tag", - "wrapped":true - }, - "items":{ - "$ref":"#/definitions/Tag" - } - }, - "status":{ - "type":"string", - "description":"pet status in the store", - "enum":[ - "available", - "pending", - "sold" - ] + "tag": { + "type": "string" } - }, - "xml":{ - "name":"Pet" - } + } + } }, - "ApiResponse":{ - "type":"object", - "properties":{ - "code":{ - "type":"integer", - "format":"int32" - }, - "type":{ - "type":"string" - }, - "message":{ - "type":"string" - } - } + "Error": { + "type": "object", + "required": [ + "code", + "message" + ], + "properties": { + "code": { + "type": "integer", + "format": "int32" + }, + "message": { + "type": "string" + } + } } - }, - "externalDocs":{ - "description":"Find out more about Swagger", - "url":"http://swagger.io" - } + } + } } |] @@ -1702,7 +933,7 @@ compositionSchemaExampleJSON = [aesonQQ| "type": "object", "allOf": [ { - "$ref": "#/definitions/Other" + "$ref": "#/components/schemas/Other" }, { "type": "object", diff --git a/test/SpecCommon.hs b/test/SpecCommon.hs index c8c2e960..e944091c 100644 --- a/test/SpecCommon.hs +++ b/test/SpecCommon.hs @@ -16,7 +16,7 @@ isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys) isSubJSON x y = x == y -(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec +(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec x <=> js = do it "encodes correctly" $ do toJSON x `shouldBe` js