From 1fabcac31593a39f83d72681139294427f8490c9 Mon Sep 17 00:00:00 2001 From: Magesh Date: Mon, 8 Feb 2021 20:18:27 +0530 Subject: [PATCH] Extension support for OpenAPI Info Contact License Server ServerVariable PathItem Operation RequestBody MediaType Encoding Example Link Response Tag --- src/Data/OpenApi.hs | 1 + src/Data/OpenApi/Internal.hs | 176 ++++++++++++++++++++++++++--------- 2 files changed, 133 insertions(+), 44 deletions(-) diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs index fcd7e302..fd0453f2 100644 --- a/src/Data/OpenApi.hs +++ b/src/Data/OpenApi.hs @@ -118,6 +118,7 @@ module Data.OpenApi ( -- ** Miscellaneous MimeList(..), URL(..), + SpecificationExtensions(..), ) where import Data.OpenApi.Lens diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index ad193bc7..62f133a5 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -29,6 +29,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.HashSet.InsOrd (InsOrdHashSet) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (catMaybes) import Data.Monoid (Monoid (..)) import Data.Scientific (Scientific) import Data.Semigroup.Compat (Semigroup (..)) @@ -97,6 +98,9 @@ data OpenApi = OpenApi -- | Additional external documentation. , _openApiExternalDocs :: Maybe ExternalDocs + + -- | Specification Extensions + , _openApiExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | The object provides metadata about the API. @@ -122,6 +126,9 @@ data Info = Info -- | The version of the OpenAPI document (which is distinct from the -- OpenAPI Specification version or the API implementation version). , _infoVersion :: Text + + -- | Specification Extensions + , _infoExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | Contact information for the exposed API. @@ -134,6 +141,9 @@ data Contact = Contact -- | The email address of the contact person/organization. , _contactEmail :: Maybe Text + + -- | Specification Extensions + , _contactExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | License information for the exposed API. @@ -143,10 +153,13 @@ data License = License -- | A URL to the license used for the API. , _licenseUrl :: Maybe URL + + -- | Specification Extensions + , _licenseExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) instance IsString License where - fromString s = License (fromString s) Nothing + fromString s = License (fromString s) Nothing mempty -- | An object representing a Server. data Server = Server @@ -163,6 +176,9 @@ data Server = Server -- | 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 + + -- | Specification Extensions + , _serverExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) data ServerVariable = ServerVariable @@ -179,10 +195,13 @@ data ServerVariable = ServerVariable -- | An optional description for the server variable. -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation. , _serverVariableDescription :: Maybe Text + + -- | Specification Extensions + , _serverVariableExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) instance IsString Server where - fromString s = Server (fromString s) Nothing mempty + fromString s = Server (fromString s) Nothing mempty 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 @@ -243,6 +262,9 @@ data PathItem = PathItem -- The list MUST NOT include duplicated parameters. -- A unique parameter is defined by a combination of a name and location. , _pathItemParameters :: [Referenced Param] + + -- | Specification Extensions + , _pathItemExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | Describes a single API operation on a path. @@ -308,6 +330,9 @@ data Operation = Operation -- If an alternative server object is specified at the 'PathItem' Object or Root level, -- it will be overridden by this value. , _operationServers :: [Server] + + -- | Specification Extensions + , _operationExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- This instance should be in @http-media@. @@ -341,6 +366,9 @@ data RequestBody = RequestBody -- | Determines if the request body is required in the request. -- Defaults to 'False'. , _requestBodyRequired :: Maybe Bool + + -- | Specification Extensions + , _requestBodyExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | Each Media Type Object provides schema and examples for the media type identified by its key. @@ -360,6 +388,9 @@ data MediaTypeObject = MediaTypeObject -- 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 + + -- | Specification Extensions + , _mediaTypeObjectExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | In order to support common ways of serializing simple parameters, a set of style values are defined. @@ -423,6 +454,9 @@ data Encoding = 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 + + -- | Specification Extensions + , _encodingExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) newtype MimeList = MimeList { getMimeList :: [MediaType] } @@ -533,6 +567,9 @@ data Example = Example -- in JSON or YAML documents. The '_exampleValue' field -- and '_exampleExternalValue' field are mutually exclusive. , _exampleExternalValue :: Maybe URL + + -- | Specification Extensions + , _exampleExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Typeable, Data) data ExpressionOrValue @@ -569,6 +606,9 @@ data Link = Link -- | A server object to be used by the target operation. , _linkServer :: Maybe Server + + -- | Specification Extensions + , _linkExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Typeable, Data) -- | Items for @'OpenApiArray'@ schemas. @@ -742,10 +782,13 @@ data Response = 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) + + -- | Specification Extensions + , _responseExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) instance IsString Response where - fromString s = Response (fromString s) mempty mempty mempty + fromString s = Response (fromString s) mempty 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 @@ -879,12 +922,15 @@ data Tag = Tag -- | Additional external documentation for this tag. , _tagExternalDocs :: Maybe ExternalDocs - } deriving (Eq, Ord, Show, Generic, Data, Typeable) + + -- | Specification Extensions + , _tagExtensions :: SpecificationExtensions + } deriving (Eq, Show, Generic, Data, Typeable) instance Hashable Tag instance IsString Tag where - fromString s = Tag (fromString s) Nothing Nothing + fromString s = Tag (fromString s) Nothing Nothing mempty -- | Allows referencing an external resource for extended documentation. data ExternalDocs = ExternalDocs @@ -918,6 +964,10 @@ data AdditionalProperties | AdditionalPropertiesSchema (Referenced Schema) deriving (Eq, Show, Data, Typeable) +newtype SpecificationExtensions = SpecificationExtensions { getSpecificationExtensions :: Definitions Value} + deriving (Eq, Show, Hashable, Data, Typeable, Semigroup, Monoid, SwaggerMonoid, AesonDefaultValue) + + ------------------------------------------------------------------------------- -- Generic instances ------------------------------------------------------------------------------- @@ -940,6 +990,11 @@ deriveGeneric ''OpenApi deriveGeneric ''Example deriveGeneric ''Encoding deriveGeneric ''Link +deriveGeneric ''Info +deriveGeneric ''Contact +deriveGeneric ''License +deriveGeneric ''ServerVariable +deriveGeneric ''Tag -- ======================================================================= -- Monoid instances @@ -1115,27 +1170,12 @@ instance ToJSON OpenApiType where instance ToJSON ParamLocation where toJSON = genericToJSON (jsonPrefix "Param") -instance ToJSON Info where - toJSON = genericToJSON (jsonPrefix "Info") - -instance ToJSON Contact where - toJSON = genericToJSON (jsonPrefix "Contact") - -instance ToJSON License where - toJSON = genericToJSON (jsonPrefix "License") - -instance ToJSON ServerVariable where - toJSON = genericToJSON (jsonPrefix "ServerVariable") - instance ToJSON ApiKeyLocation where toJSON = genericToJSON (jsonPrefix "ApiKey") instance ToJSON ApiKeyParams where toJSON = genericToJSON (jsonPrefix "apiKey") -instance ToJSON Tag where - toJSON = genericToJSON (jsonPrefix "Tag") - instance ToJSON ExternalDocs where toJSON = genericToJSON (jsonPrefix "ExternalDocs") @@ -1170,27 +1210,12 @@ instance FromJSON OpenApiType where instance FromJSON ParamLocation where parseJSON = genericParseJSON (jsonPrefix "Param") -instance FromJSON Info where - parseJSON = genericParseJSON (jsonPrefix "Info") - -instance FromJSON Contact where - parseJSON = genericParseJSON (jsonPrefix "Contact") - -instance FromJSON License where - parseJSON = genericParseJSON (jsonPrefix "License") - -instance FromJSON ServerVariable where - parseJSON = genericParseJSON (jsonPrefix "ServerVariable") - instance FromJSON ApiKeyLocation where parseJSON = genericParseJSON (jsonPrefix "ApiKey") instance FromJSON ApiKeyParams where parseJSON = genericParseJSON (jsonPrefix "apiKey") -instance FromJSON Tag where - parseJSON = genericParseJSON (jsonPrefix "Tag") - instance FromJSON ExternalDocs where parseJSON = genericParseJSON (jsonPrefix "ExternalDocs") @@ -1250,10 +1275,26 @@ instance ToJSON OpenApi where else id toEncoding = sopSwaggerGenericToEncoding +instance ToJSON Info where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON Contact where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON License where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON Server where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON ServerVariable where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON SecurityScheme where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding @@ -1328,6 +1369,10 @@ instance ToJSON Link where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON Tag where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON SecurityDefinitions where toJSON (SecurityDefinitions sd) = toJSON sd @@ -1358,6 +1403,12 @@ instance ToJSON ExpressionOrValue where instance ToJSON Callback where toJSON (Callback ps) = toJSON ps +instance ToJSON SpecificationExtensions where + toJSON = toJSON . addExtPrefix . getSpecificationExtensions + where + addExtPrefix = InsOrdHashMap.mapKeys ("x-" <>) + + -- ======================================================================= -- Manual FromJSON instances -- ======================================================================= @@ -1389,9 +1440,21 @@ instance FromJSON SecuritySchemeType where instance FromJSON OpenApi where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON Info where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON Contact where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON License where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON Server where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON ServerVariable where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON SecurityScheme where parseJSON = sopSwaggerGenericParseJSON @@ -1457,6 +1520,9 @@ instance FromJSON Encoding where instance FromJSON Link where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON Tag where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON Reference where parseJSON (Object o) = Reference <$> o .: "$ref" parseJSON _ = empty @@ -1498,8 +1564,14 @@ instance FromJSON ExpressionOrValue where instance FromJSON Callback where parseJSON = fmap Callback . parseJSON +instance FromJSON SpecificationExtensions where + parseJSON = withObject "SpecificationExtensions" extFieldsParser + where + extFieldsParser = pure . SpecificationExtensions . InsOrdHashMap.fromList . catMaybes . filterExtFields + filterExtFields = fmap (\(k,v) -> fmap (\k' -> (k',v)) $ Text.stripPrefix "x-" k) . HashMap.toList + instance HasSwaggerAesonOptions Server where - swaggerAesonOptions _ = mkSwaggerAesonOptions "server" + swaggerAesonOptions _ = mkSwaggerAesonOptions "server" & saoSubObject ?~ "extensions" instance HasSwaggerAesonOptions Components where swaggerAesonOptions _ = mkSwaggerAesonOptions "components" instance HasSwaggerAesonOptions Header where @@ -1509,17 +1581,17 @@ instance AesonDefaultValue p => HasSwaggerAesonOptions (OAuth2Flow p) where instance HasSwaggerAesonOptions OAuth2Flows where swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows" instance HasSwaggerAesonOptions Operation where - swaggerAesonOptions _ = mkSwaggerAesonOptions "operation" + swaggerAesonOptions _ = mkSwaggerAesonOptions "operation" & saoSubObject ?~ "extensions" instance HasSwaggerAesonOptions Param where swaggerAesonOptions _ = mkSwaggerAesonOptions "param" instance HasSwaggerAesonOptions PathItem where - swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" + swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" & saoSubObject ?~ "extensions" instance HasSwaggerAesonOptions Response where - swaggerAesonOptions _ = mkSwaggerAesonOptions "response" + swaggerAesonOptions _ = mkSwaggerAesonOptions "response" & saoSubObject ?~ "extensions" instance HasSwaggerAesonOptions RequestBody where - swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody" + swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody" & saoSubObject ?~ "extensions" instance HasSwaggerAesonOptions MediaTypeObject where - swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaTypeObject" + swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaTypeObject" & saoSubObject ?~ "extensions" instance HasSwaggerAesonOptions Responses where swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses" instance HasSwaggerAesonOptions SecurityScheme where @@ -1528,13 +1600,29 @@ instance HasSwaggerAesonOptions Schema where swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" instance HasSwaggerAesonOptions OpenApi where swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")] + & saoSubObject ?~ "extensions" instance HasSwaggerAesonOptions Example where - swaggerAesonOptions _ = mkSwaggerAesonOptions "example" + swaggerAesonOptions _ = mkSwaggerAesonOptions "example" & saoSubObject ?~ "extensions" instance HasSwaggerAesonOptions Encoding where - swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" + swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding" & saoSubObject ?~ "extensions" instance HasSwaggerAesonOptions Link where - swaggerAesonOptions _ = mkSwaggerAesonOptions "link" + swaggerAesonOptions _ = mkSwaggerAesonOptions "link" & saoSubObject ?~ "extensions" + +instance HasSwaggerAesonOptions Info where + swaggerAesonOptions _ = mkSwaggerAesonOptions "info" & saoSubObject ?~ "extensions" + +instance HasSwaggerAesonOptions Contact where + swaggerAesonOptions _ = mkSwaggerAesonOptions "contact" & saoSubObject ?~ "extensions" + +instance HasSwaggerAesonOptions License where + swaggerAesonOptions _ = mkSwaggerAesonOptions "license" & saoSubObject ?~ "extensions" + +instance HasSwaggerAesonOptions ServerVariable where + swaggerAesonOptions _ = mkSwaggerAesonOptions "serverVariable" & saoSubObject ?~ "extensions" + +instance HasSwaggerAesonOptions Tag where + swaggerAesonOptions _ = mkSwaggerAesonOptions "tag" & saoSubObject ?~ "extensions" instance AesonDefaultValue Server instance AesonDefaultValue Components