diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs index a9ce8f3d..a9cea484 100644 --- a/src/Data/OpenApi.hs +++ b/src/Data/OpenApi.hs @@ -119,6 +119,7 @@ module Data.OpenApi ( -- ** Miscellaneous MimeList(..), URL(..), + SpecificationExtensions(..), ) where import Data.OpenApi.Lens @@ -187,7 +188,6 @@ import Data.OpenApi.Internal -- "title": "Todo API", -- "version": "1.0" -- } - -- -- This can be useful for combining specifications of endpoints into a whole API specification: -- @@ -416,7 +416,6 @@ import Data.OpenApi.Internal -- } -- ] -- } - -- $manipulation -- Sometimes you have to work with an imported or generated @'Swagger'@. -- For instance, generates basic @'Swagger'@ diff --git a/src/Data/OpenApi/Aeson/Compat.hs b/src/Data/OpenApi/Aeson/Compat.hs index c516a4e1..7e967152 100644 --- a/src/Data/OpenApi/Aeson/Compat.hs +++ b/src/Data/OpenApi/Aeson/Compat.hs @@ -43,6 +43,10 @@ lookupKey = KeyMap.lookup . Key.fromText hasKey :: T.Text -> KeyMap.KeyMap a -> Bool hasKey = KeyMap.member . Key.fromText + +filterWithKey :: (Key -> v -> Bool) -> KeyMap.KeyMap v -> KeyMap.KeyMap v +filterWithKey = KeyMap.filterWithKey + #else deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v deleteKey = HM.delete @@ -73,4 +77,7 @@ lookupKey = HM.lookup hasKey :: T.Text -> HM.HashMap T.Text a -> Bool hasKey = HM.member + +filterWithKey :: (T.Text -> v -> Bool) -> HM.HashMap T.Text v -> HM.HashMap T.Text v +filterWithKey = HM.filterWithKey #endif diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index b9be5292..46bae488 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -24,6 +24,7 @@ import Control.Lens ((&), (.~), (?~)) import Data.Aeson hiding (Encoding) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Aeson.Key as KeyMap #endif import qualified Data.Aeson.Types as JSON import Data.Data (Constr, Data (..), DataType, Fixity (..), Typeable, @@ -33,6 +34,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 (..)) @@ -48,12 +50,14 @@ import Text.Read (readMaybe) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap -import Data.OpenApi.Aeson.Compat (deleteKey) +import Data.OpenApi.Aeson.Compat (deleteKey, keyToText, filterWithKey, objectToList) import Data.OpenApi.Internal.AesonUtils (AesonDefaultValue (..), HasSwaggerAesonOptions (..), mkSwaggerAesonOptions, saoAdditionalPairs, saoSubObject, sopSwaggerGenericParseJSON, sopSwaggerGenericToEncoding, sopSwaggerGenericToJSON, sopSwaggerGenericToJSONWithOpts) import Data.OpenApi.Internal.Utils +import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToEncoding + ,sopSwaggerGenericToEncodingWithOpts) import Generics.SOP.TH (deriveGeneric) import Data.Version import Control.Monad (unless) @@ -102,8 +106,12 @@ data OpenApi = OpenApi -- | Additional external documentation. , _openApiExternalDocs :: Maybe ExternalDocs + -- | Specification Extensions + , _openApiExtensions :: SpecificationExtensions + , -- | The spec of OpenApi this spec adheres to. Must be between 'lowerOpenApiSpecVersion' and 'upperOpenApiSpecVersion' _openApiOpenapi :: OpenApiSpecVersion + } deriving (Eq, Show, Generic, Data, Typeable) -- | This is the lower version of the OpenApi Spec this library can parse or produce @@ -137,6 +145,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. @@ -149,6 +160,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. @@ -158,10 +172,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 @@ -178,6 +195,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 @@ -194,10 +214,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 @@ -258,6 +281,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. @@ -323,6 +349,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@. @@ -356,6 +385,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. @@ -375,6 +407,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. @@ -438,6 +473,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] } @@ -548,6 +586,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 @@ -584,6 +625,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. @@ -673,6 +717,9 @@ data Schema = Schema , _schemaUniqueItems :: Maybe Bool , _schemaEnum :: Maybe [Value] , _schemaMultipleOf :: Maybe Scientific + + -- | Specification Extensions + , _schemaExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | Regex pattern for @string@ type. @@ -719,6 +766,9 @@ data Xml = Xml -- Default value is @False@. -- The definition takes effect only when defined alongside type being array (outside the items). , _xmlWrapped :: Maybe Bool + + -- | Specification Extensions + , _xmlExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | A container for the expected responses of an operation. @@ -734,6 +784,9 @@ data Responses = Responses -- | Any HTTP status code can be used as the property name (one property per HTTP status code). -- Describes the expected response for those HTTP status codes. , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response) + + -- | Specification Extensions + , _responsesExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) type HttpStatusCode = Int @@ -757,10 +810,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 @@ -837,6 +893,9 @@ data OAuth2Flow p = OAuth2Flow -- A map between the scope name and a short description for it. -- The map MAY be empty. , _oAuth2Scopes :: InsOrdHashMap Text Text + + -- | Specification Extensions + , _oAuth2Extensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) data OAuth2Flows = OAuth2Flows @@ -851,6 +910,9 @@ data OAuth2Flows = OAuth2Flows -- | Configuration for the OAuth Authorization Code flow , _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow) + + -- | Specification Extensions + , _oAuth2FlowsExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) type BearerFormat = Text @@ -908,6 +970,9 @@ data SecurityScheme = SecurityScheme -- | A short description for security scheme. , _securitySchemeDescription :: Maybe Text + + -- | Specification Extensions + , _securitySchemeExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) newtype SecurityDefinitions @@ -936,12 +1001,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 @@ -951,7 +1019,10 @@ data ExternalDocs = ExternalDocs -- | The URL for the target documentation. , _externalDocsUrl :: URL - } deriving (Eq, Ord, Show, Generic, Data, Typeable) + + -- | Specification Extensions + , _externalDocsExtensions :: SpecificationExtensions + } deriving (Eq, Show, Generic, Data, Typeable) instance Hashable ExternalDocs @@ -968,13 +1039,16 @@ data Referenced a instance IsString a => IsString (Referenced a) where fromString = Inline . fromString -newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable) +newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable, AesonDefaultValue) data AdditionalProperties = AdditionalPropertiesAllowed Bool | AdditionalPropertiesSchema (Referenced Schema) deriving (Eq, Show, Data, Typeable) +newtype SpecificationExtensions = SpecificationExtensions { getSpecificationExtensions :: Definitions Value} + deriving (Eq, Show, Hashable, Data, Typeable, Semigroup, Monoid, SwaggerMonoid, AesonDefaultValue) + newtype OpenApiSpecVersion = OpenApiSpecVersion {getVersion :: Version} deriving (Eq, Show, Generic, Data, Typeable) ------------------------------------------------------------------------------- @@ -999,6 +1073,13 @@ deriveGeneric ''OpenApi deriveGeneric ''Example deriveGeneric ''Encoding deriveGeneric ''Link +deriveGeneric ''Info +deriveGeneric ''Contact +deriveGeneric ''License +deriveGeneric ''ServerVariable +deriveGeneric ''Tag +deriveGeneric ''Xml +deriveGeneric ''ExternalDocs deriveGeneric ''OpenApiSpecVersion -- ======================================================================= @@ -1108,6 +1189,7 @@ instance Semigroup OAuth2Flows where , _oAuth2FlowsPassword = _oAuth2FlowsPassword l <> _oAuth2FlowsPassword r , _oAuth2FlowsClientCredentials = _oAuth2FlowsClientCredentials l <> _oAuth2FlowsClientCredentials r , _oAuth2FlowsAuthorizationCode = _oAuth2FlowsAuthorizationCode l <> _oAuth2FlowsAuthorizationCode r + , _oAuth2FlowsExtensions = _oAuth2FlowsExtensions l <> _oAuth2FlowsExtensions r } instance Monoid OAuth2Flows where @@ -1115,9 +1197,9 @@ instance Monoid OAuth2Flows where mappend = (<>) instance Semigroup SecurityScheme where - SecurityScheme (SecuritySchemeOAuth2 lFlows) lDesc - <> SecurityScheme (SecuritySchemeOAuth2 rFlows) rDesc = - SecurityScheme (SecuritySchemeOAuth2 $ lFlows <> rFlows) (swaggerMappend lDesc rDesc) + SecurityScheme (SecuritySchemeOAuth2 lFlows) lDesc lExt + <> SecurityScheme (SecuritySchemeOAuth2 rFlows) rDesc rExt = + SecurityScheme (SecuritySchemeOAuth2 $ lFlows <> rFlows) (swaggerMappend lDesc rDesc) (lExt <> rExt) l <> _ = l instance Semigroup SecurityDefinitions where @@ -1184,33 +1266,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") - -instance ToJSON Xml where - toJSON = genericToJSON (jsonPrefix "Xml") - instance ToJSON Discriminator where toJSON = genericToJSON (jsonPrefix "Discriminator") @@ -1239,30 +1300,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") - instance FromJSON Discriminator where parseJSON = genericParseJSON (jsonPrefix "Discriminator") @@ -1336,17 +1379,35 @@ 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 instance ToJSON Schema where toJSON = sopSwaggerGenericToJSONWithOpts $ - mkSwaggerAesonOptions "schema" & saoSubObject ?~ "items" + mkSwaggerAesonOptions "schema" & saoSubObject .~ ["items", "extensions"] + toEncoding = sopSwaggerGenericToEncodingWithOpts $ + mkSwaggerAesonOptions "schema" & saoSubObject .~ ["items", "extensions"] instance ToJSON Header where toJSON = sopSwaggerGenericToJSON @@ -1371,6 +1432,15 @@ instance ToJSON OpenApiItems where ] toJSON (OpenApiItemsArray x) = object [ "items" .= x ] + toEncoding (OpenApiItemsObject x) = pairs ("items" .= x ) + toEncoding (OpenApiItemsArray []) = pairs + ( + "items" .= JSON.emptyObject + <> "maxItems" .= (0 :: Int) + <> "example" .= JSON.emptyArray + ) + toEncoding (OpenApiItemsArray x) = pairs ( "items" .= x ) + instance ToJSON Components where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding @@ -1418,20 +1488,43 @@ instance ToJSON Link where toJSON = sopSwaggerGenericToJSON toEncoding = sopSwaggerGenericToEncoding +instance ToJSON Tag where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON Xml where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + +instance ToJSON ExternalDocs where + toJSON = sopSwaggerGenericToJSON + toEncoding = sopSwaggerGenericToEncoding + instance ToJSON SecurityDefinitions where toJSON (SecurityDefinitions sd) = toJSON sd instance ToJSON Reference where toJSON (Reference ref) = object [ "$ref" .= ref ] + toEncoding (Reference ref) = pairs ("$ref" .= ref) 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 "#/components/schemas/" +referencedToEncoding :: ToJSON a => Text -> Referenced a -> JSON.Encoding +referencedToEncoding prefix (Ref (Reference ref)) = pairs ("$ref" .= (prefix <> ref) ) +referencedToEncoding _ (Inline x) = toEncoding x + +instance ToJSON (Referenced Schema) where + toJSON = referencedToJSON "#/components/schemas/" + toEncoding = referencedToEncoding "#/components/schemas/" + +instance ToJSON (Referenced RequestBody) where + toJSON = referencedToJSON "#/components/requestBodies/" + toEncoding = referencedToEncoding "#/components/requestBodies/" + 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/" @@ -1448,6 +1541,15 @@ 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-" <>) + toEncoding = toEncoding . addExtPrefix . getSpecificationExtensions + where + addExtPrefix = InsOrdHashMap.mapKeys ("x-" <>) + + -- ======================================================================= -- Manual FromJSON instances -- ======================================================================= @@ -1500,9 +1602,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 @@ -1538,9 +1652,15 @@ instance FromJSON Param where instance FromJSON Responses where parseJSON (Object o) = Responses <$> o .:? "default" - <*> parseJSON (Object (deleteKey "default" o)) + <*> parseJSON (Object (filterWithKey (\k _ -> not $ isExt k) + $ deleteKey "default" o)) + <*> case filterWithKey (\k _ -> isExt k) o of + exts | null exts -> pure (SpecificationExtensions mempty) + | otherwise -> parseJSON (Object exts) parseJSON _ = empty +isExt = Text.isPrefixOf "x-" . keyToText + instance FromJSON Example where parseJSON = sopSwaggerGenericParseJSON @@ -1568,6 +1688,15 @@ instance FromJSON Encoding where instance FromJSON Link where parseJSON = sopSwaggerGenericParseJSON +instance FromJSON Tag where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON Xml where + parseJSON = sopSwaggerGenericParseJSON + +instance FromJSON ExternalDocs where + parseJSON = sopSwaggerGenericParseJSON + instance FromJSON Reference where parseJSON (Object o) = Reference <$> o .: "$ref" parseJSON _ = empty @@ -1594,9 +1723,6 @@ instance FromJSON (Referenced Header) where parseJSON = referencedParseJSON "# 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 AdditionalProperties where parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b parseJSON js = AdditionalPropertiesSchema <$> parseJSON js @@ -1609,45 +1735,73 @@ 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-" $ keyToText k) . objectToList + instance HasSwaggerAesonOptions Server where - swaggerAesonOptions _ = mkSwaggerAesonOptions "server" + swaggerAesonOptions _ = mkSwaggerAesonOptions "server" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Components where swaggerAesonOptions _ = mkSwaggerAesonOptions "components" instance HasSwaggerAesonOptions Header where swaggerAesonOptions _ = mkSwaggerAesonOptions "header" instance AesonDefaultValue p => HasSwaggerAesonOptions (OAuth2Flow p) where - swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "params" + swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject .~ ["params", "extensions"] instance HasSwaggerAesonOptions OAuth2Flows where - swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows" + swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows" & saoSubObject .~ ["extensions"] 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" + swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject .~ ["responses", "extensions"] instance HasSwaggerAesonOptions SecurityScheme where - swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type" + swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject .~ ["type", "extensions"] instance HasSwaggerAesonOptions Schema where - swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema" + swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject .~ ["paramSchema", "extensions"] +instance HasSwaggerAesonOptions OpenApi where + swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")] + & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions OpenApiSpecVersion where swaggerAesonOptions _ = mkSwaggerAesonOptions "openapi" -instance HasSwaggerAesonOptions OpenApi where - swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" 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 HasSwaggerAesonOptions Xml where + swaggerAesonOptions _ = mkSwaggerAesonOptions "xml" & saoSubObject .~ ["extensions"] + +instance HasSwaggerAesonOptions ExternalDocs where + swaggerAesonOptions _ = mkSwaggerAesonOptions "externalDocs" & saoSubObject .~ ["extensions"] instance AesonDefaultValue Version where defaultValue = Just (makeVersion [3,0,0]) diff --git a/src/Data/OpenApi/Internal/AesonUtils.hs b/src/Data/OpenApi/Internal/AesonUtils.hs index 3804ab32..a699f3e2 100644 --- a/src/Data/OpenApi/Internal/AesonUtils.hs +++ b/src/Data/OpenApi/Internal/AesonUtils.hs @@ -11,6 +11,7 @@ module Data.OpenApi.Internal.AesonUtils ( sopSwaggerGenericToJSON, sopSwaggerGenericToEncoding, sopSwaggerGenericToJSONWithOpts, + sopSwaggerGenericToEncodingWithOpts, sopSwaggerGenericParseJSON, -- * Options HasSwaggerAesonOptions(..), @@ -49,13 +50,13 @@ import Data.OpenApi.Aeson.Compat (keyToString, objectToList, stringToKey) data SwaggerAesonOptions = SwaggerAesonOptions { _saoPrefix :: String , _saoAdditionalPairs :: [Pair] - , _saoSubObject :: Maybe String + , _saoSubObject :: [String] } mkSwaggerAesonOptions :: String -- ^ prefix -> SwaggerAesonOptions -mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing +mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] [] makeLenses ''SwaggerAesonOptions @@ -154,7 +155,7 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair] go Nil Nil Nil = [] go (I x :* xs) (FieldInfo name :* names) (def :* defs) - | Just name' == sub = case json of + | name' `elem` sub = case json of Object m -> objectToList m ++ rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json @@ -227,7 +228,7 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys) go Nil Nil = pure Nil go (FieldInfo name :* names) (def :* defs) - | Just name' == sub = + | name' `elem` sub = -- Note: we might strip fields of outer structure. cons <$> (withDef $ parseJSON $ Object obj) <*> rest | otherwise = case def of @@ -268,6 +269,24 @@ sopSwaggerGenericToEncoding x = proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy +sopSwaggerGenericToEncodingWithOpts + :: forall a xs. + ( HasDatatypeInfo a + , HasSwaggerAesonOptions a + , All2 ToJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) + => SwaggerAesonOptions + -> a + -> Encoding +sopSwaggerGenericToEncodingWithOpts opts x = + let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) defs + in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps) + where + proxy = Proxy :: Proxy a + defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue + pairsToSeries :: [Pair] -> Series pairsToSeries = foldMap (\(k, v) -> (k .= v)) @@ -294,7 +313,7 @@ sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series go Nil Nil Nil = mempty go (I x :* xs) (FieldInfo name :* names) (def :* defs) - | Just name' == sub = case toJSON x of + | name' `elem` sub = case toJSON x of Object m -> pairsToSeries (objectToList m) <> rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x) diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index da56acf0..2b421871 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -390,6 +390,16 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs -- ], -- "type": "object" -- } +-- >>> BSL.putStrLn $ encode $ sketchSchema (1, 2, 3) +-- {"example":[1,2,3],"type":"array","items":{"type":"number"}} +-- +-- >>> BSL.putStrLn $ encode $ sketchSchema ("Jack", 25) +-- {"example":["Jack",25],"type":"array","items":[{"type":"string"},{"type":"number"}]} +-- +-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) +-- >>> instance ToJSON Person +-- >>> BSL.putStrLn $ encode $ sketchSchema (Person "Jack" 25) +-- {"required":["age","name"],"properties":{"age":{"type":"number"},"name":{"type":"string"}},"example":{"age":25,"name":"Jack"},"type":"object"} sketchSchema :: ToJSON a => a -> Schema sketchSchema = sketch . toJSON where diff --git a/src/Data/OpenApi/Operation.hs b/src/Data/OpenApi/Operation.hs index cb8a07e0..08ac020f 100644 --- a/src/Data/OpenApi/Operation.hs +++ b/src/Data/OpenApi/Operation.hs @@ -143,6 +143,7 @@ allOperations = paths.traverse.template -- } -- } -- } + operationsOf :: OpenApi -> Traversal' OpenApi Operation operationsOf sub = paths.itraversed.withIndex.subops where diff --git a/test/Data/OpenApiSpec.hs b/test/Data/OpenApiSpec.hs index cb860747..de6e52cc 100644 --- a/test/Data/OpenApiSpec.hs +++ b/test/Data/OpenApiSpec.hs @@ -13,6 +13,7 @@ import Data.Aeson import Data.Aeson.QQ.Simple import Data.HashMap.Strict (HashMap) import qualified Data.HashSet.InsOrd as InsOrdHS +import qualified Data.HashMap.Strict.InsOrd as InsOrdHM import Data.Text (Text) import Data.OpenApi @@ -152,6 +153,7 @@ operationExample = mempty & at 200 ?~ "Pet updated." & at 405 ?~ "Invalid input" & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]] + & extensions .~ SpecificationExtensions (InsOrdHM.fromList [("ext1", toJSON True)]) operationExampleJSON :: Value operationExampleJSON = [aesonQQ| @@ -206,7 +208,8 @@ operationExampleJSON = [aesonQQ| "read:pets" ] } - ] + ], + "x-ext1": true } |] @@ -238,6 +241,7 @@ schemaSimpleModelExample = mempty & minimum_ ?~ 0 & type_ ?~ OpenApiInteger & format ?~ "int32" ) ] + & extensions .~ SpecificationExtensions (InsOrdHM.fromList [("ext1", toJSON True)]) schemaSimpleModelExampleJSON :: Value schemaSimpleModelExampleJSON = [aesonQQ| @@ -255,7 +259,8 @@ schemaSimpleModelExampleJSON = [aesonQQ| "type": "integer" } }, - "type": "object" + "type": "object", + "x-ext1": true } |] @@ -456,15 +461,18 @@ securityDefinitionsExample :: SecurityDefinitions securityDefinitionsExample = SecurityDefinitions [ ("api_key", SecurityScheme { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader) - , _securitySchemeDescription = Nothing }) + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = mempty}) , ("petstore_auth", SecurityScheme { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" , _oAath2RefreshUrl = Nothing + , _oAuth2Extensions = mempty , _oAuth2Scopes = [ ("write:pets", "modify pets in your account") , ("read:pets", "read your pets") ] } ) - , _securitySchemeDescription = Nothing }) ] + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = SpecificationExtensions (InsOrdHM.fromList [("ext1", toJSON True)])}) ] securityDefinitionsExampleJSON :: Value securityDefinitionsExampleJSON = [aesonQQ| @@ -484,7 +492,8 @@ securityDefinitionsExampleJSON = [aesonQQ| }, "authorizationUrl": "http://swagger.io/api/oauth/dialog" } - } + }, + "x-ext1": true } } @@ -496,9 +505,11 @@ oAuth2SecurityDefinitionsReadExample = SecurityDefinitions { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" , _oAath2RefreshUrl = Nothing + , _oAuth2Extensions = mempty , _oAuth2Scopes = [ ("read:pets", "read your pets") ] } ) - , _securitySchemeDescription = Nothing }) + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = mempty }) ] oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions @@ -507,9 +518,12 @@ oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" , _oAath2RefreshUrl = Nothing + , _oAuth2Extensions = mempty , _oAuth2Scopes = [ ("write:pets", "modify pets in your account") ] } ) - , _securitySchemeDescription = Nothing }) + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = mempty + }) ] oAuth2SecurityDefinitionsEmptyExample :: SecurityDefinitions