From 662b2b510d4712015ac191bd09fcba7da97fef6a Mon Sep 17 00:00:00 2001 From: Avery Date: Wed, 16 Mar 2022 11:56:37 +0100 Subject: [PATCH 1/9] tests pass --- src/Data/OpenApi.hs | 1 + src/Data/OpenApi/Aeson/Compat.hs | 6 + src/Data/OpenApi/Internal.hs | 184 +++++++++++++++++++----- src/Data/OpenApi/Internal/AesonUtils.hs | 32 ++++- test/Data/OpenApiSpec.hs | 68 ++++++--- 5 files changed, 230 insertions(+), 61 deletions(-) diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs index a9ce8f3d..9ece120a 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 diff --git a/src/Data/OpenApi/Aeson/Compat.hs b/src/Data/OpenApi/Aeson/Compat.hs index c516a4e1..ca5d441e 100644 --- a/src/Data/OpenApi/Aeson/Compat.hs +++ b/src/Data/OpenApi/Aeson/Compat.hs @@ -14,6 +14,9 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import qualified Data.Text as T #if MIN_VERSION_aeson(2,0,0) +filterWithKey :: (T.Text -> v -> Bool) -> KeyMap.KeyMap v -> KeyMap.KeyMap v +filterWithKey p = KeyMap.filterWithKey (\k v -> p (keyToText k) v) + deleteKey :: Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v deleteKey = KeyMap.delete @@ -44,6 +47,9 @@ lookupKey = KeyMap.lookup . Key.fromText hasKey :: T.Text -> KeyMap.KeyMap a -> Bool hasKey = KeyMap.member . Key.fromText #else +filterWithKey :: (T.Text -> v -> Bool) -> HM.HashMap T.Text v -> HM.HashMap T.Text v +filterWithKey = HM.filterWithKey + deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v deleteKey = HM.delete diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index b9be5292..3a63aeef 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -48,7 +48,7 @@ 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, filterWithKey, objectToList, keyToText) import Data.OpenApi.Internal.AesonUtils (AesonDefaultValue (..), HasSwaggerAesonOptions (..), mkSwaggerAesonOptions, saoAdditionalPairs, saoSubObject, sopSwaggerGenericParseJSON, sopSwaggerGenericToEncoding, @@ -58,6 +58,7 @@ import Generics.SOP.TH (deriveGeneric) import Data.Version import Control.Monad (unless) import Text.ParserCombinators.ReadP (readP_to_S) +import Data.Maybe (catMaybes) -- $setup -- >>> :seti -XDataKinds @@ -104,6 +105,8 @@ data OpenApi = OpenApi , -- | The spec of OpenApi this spec adheres to. Must be between 'lowerOpenApiSpecVersion' and 'upperOpenApiSpecVersion' _openApiOpenapi :: OpenApiSpecVersion + -- | Specification Extensions + , _openApiExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | This is the lower version of the OpenApi Spec this library can parse or produce @@ -137,6 +140,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 +155,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 +167,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 +190,8 @@ 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 +208,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 +275,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 +343,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 +379,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 +401,8 @@ 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 +466,8 @@ 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 +578,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 +617,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 +709,8 @@ 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 +757,8 @@ 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 +774,8 @@ 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 +799,12 @@ 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 +881,8 @@ 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 +897,8 @@ 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 +956,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 +987,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 +1005,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,7 +1025,8 @@ 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 @@ -977,6 +1035,9 @@ data AdditionalProperties newtype OpenApiSpecVersion = OpenApiSpecVersion {getVersion :: Version} deriving (Eq, Show, Generic, Data, Typeable) +newtype SpecificationExtensions = SpecificationExtensions {getSpecificationExtensions :: Definitions Value} + deriving (Eq, Show, Hashable, Data, Typeable, Semigroup, Monoid, SwaggerMonoid, AesonDefaultValue) + ------------------------------------------------------------------------------- -- Generic instances ------------------------------------------------------------------------------- @@ -1000,18 +1061,25 @@ deriveGeneric ''Example deriveGeneric ''Encoding deriveGeneric ''Link deriveGeneric ''OpenApiSpecVersion +deriveGeneric ''Info +deriveGeneric ''Contact +deriveGeneric ''License +deriveGeneric ''ServerVariable +deriveGeneric ''Tag +deriveGeneric ''Xml +deriveGeneric ''ExternalDocs -- ======================================================================= -- Monoid instances -- ======================================================================= instance Semigroup OpenApiSpecVersion where - (<>) (OpenApiSpecVersion a) (OpenApiSpecVersion b) = OpenApiSpecVersion $ max a b - + (<>) (OpenApiSpecVersion a) (OpenApiSpecVersion b) = OpenApiSpecVersion $ max a b + instance Monoid OpenApiSpecVersion where mempty = OpenApiSpecVersion (makeVersion [3,0,0]) mappend = (<>) - + instance Semigroup OpenApi where (<>) = genericMappend instance Monoid OpenApi where @@ -1108,6 +1176,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 +1184,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 @@ -1282,7 +1351,7 @@ instance FromJSON OAuth2AuthorizationCodeFlow where -- Manual ToJSON instances -- ======================================================================= -instance ToJSON OpenApiSpecVersion where +instance ToJSON OpenApiSpecVersion where toJSON (OpenApiSpecVersion v)= toJSON . showVersion $ v instance ToJSON MediaType where @@ -1346,7 +1415,7 @@ instance ToJSON SecurityScheme where instance ToJSON Schema where toJSON = sopSwaggerGenericToJSONWithOpts $ - mkSwaggerAesonOptions "schema" & saoSubObject ?~ "items" + mkSwaggerAesonOptions "schema" & saoSubObject .~ ["items", "extensions"] instance ToJSON Header where toJSON = sopSwaggerGenericToJSON @@ -1448,6 +1517,11 @@ 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 -- ======================================================================= @@ -1456,15 +1530,15 @@ instance FromJSON OpenApiSpecVersion where parseJSON = withText "OpenApiSpecVersion" $ \str -> let validatedVersion :: Either String Version validatedVersion = do - parsedVersion <- readVersion str + parsedVersion <- readVersion str unless ((parsedVersion >= lowerOpenApiSpecVersion) && (parsedVersion <= upperOpenApiSpecVersion)) $ Left ("The provided version " <> showVersion parsedVersion <> " is out of the allowed range >=" <> showVersion lowerOpenApiSpecVersion <> " && <=" <> showVersion upperOpenApiSpecVersion) return parsedVersion - in + in either fail (return . OpenApiSpecVersion) validatedVersion where readVersion :: Text -> Either String Version - readVersion v = case readP_to_S parseVersion (Text.unpack v) of + readVersion v = case readP_to_S parseVersion (Text.unpack v) of [] -> Left $ "Failed to parse as a version string " <> Text.unpack v solutions -> Right (fst . last $ solutions) @@ -1538,9 +1612,22 @@ 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 -> Bool +isExt = Text.isPrefixOf "x-" + instance FromJSON Example where parseJSON = sopSwaggerGenericParseJSON @@ -1609,6 +1696,12 @@ 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" instance HasSwaggerAesonOptions Components where @@ -1616,42 +1709,65 @@ instance HasSwaggerAesonOptions Components where 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 OpenApiSpecVersion where swaggerAesonOptions _ = mkSwaggerAesonOptions "openapi" instance HasSwaggerAesonOptions OpenApi where swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" + & 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 AesonDefaultValue Version where +instance AesonDefaultValue Version where defaultValue = Just (makeVersion [3,0,0]) instance AesonDefaultValue OpenApiSpecVersion + +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 Server instance AesonDefaultValue Components instance AesonDefaultValue OAuth2ImplicitFlow diff --git a/src/Data/OpenApi/Internal/AesonUtils.hs b/src/Data/OpenApi/Internal/AesonUtils.hs index 3804ab32..91a27cf3 100644 --- a/src/Data/OpenApi/Internal/AesonUtils.hs +++ b/src/Data/OpenApi/Internal/AesonUtils.hs @@ -49,13 +49,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 +154,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,9 +227,9 @@ 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 + cons <$> withDef (parseJSON $ Object obj) <*> rest | otherwise = case def of Just def' -> cons <$> obj .:? stringToKey name' .!= def' <*> rest Nothing -> cons <$> obj .: stringToKey name' <*> rest @@ -269,7 +269,7 @@ sopSwaggerGenericToEncoding x = opts = swaggerAesonOptions proxy pairsToSeries :: [Pair] -> Series -pairsToSeries = foldMap (\(k, v) -> (k .= v)) +pairsToSeries = foldMap (uncurry (.=)) sopSwaggerGenericToEncoding' :: (All2 ToJSON '[xs], All2 Eq '[xs]) @@ -294,7 +294,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) @@ -311,3 +311,21 @@ sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go modifier = lowerFirstUppers . drop (length prefix) lowerFirstUppers s = map toLower x ++ y where (x, y) = span isUpper s + +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 diff --git a/test/Data/OpenApiSpec.hs b/test/Data/OpenApiSpec.hs index cb860747..313e4543 100644 --- a/test/Data/OpenApiSpec.hs +++ b/test/Data/OpenApiSpec.hs @@ -18,6 +18,8 @@ import Data.Text (Text) import Data.OpenApi import SpecCommon import Test.Hspec hiding (example) +import qualified Data.HashMap.Strict.InsOrd as InsOrdHM +import Data.OpenApi spec :: Spec spec = do @@ -69,6 +71,7 @@ infoExample = mempty & contact ?~ contactExample & license ?~ licenseExample & version .~ "1.0.1" + & extensions .~ mempty infoExampleJSON :: Value infoExampleJSON = [aesonQQ| @@ -79,13 +82,16 @@ infoExampleJSON = [aesonQQ| "contact": { "name": "API Support", "url": "http://www.swagger.io/support", - "email": "support@swagger.io" + "email": "support@swagger.io", + "extensions": {} }, "license": { "name": "Apache 2.0", - "url": "http://www.apache.org/licenses/LICENSE-2.0.html" + "url": "http://www.apache.org/licenses/LICENSE-2.0.html", + "extensions": {} }, - "version": "1.0.1" + "version": "1.0.1", + "extensions": {} } |] @@ -98,13 +104,15 @@ contactExample = mempty & name ?~ "API Support" & url ?~ URL "http://www.swagger.io/support" & email ?~ "support@swagger.io" + & extensions .~ mempty contactExampleJSON :: Value contactExampleJSON = [aesonQQ| { "name": "API Support", "url": "http://www.swagger.io/support", - "email": "support@swagger.io" + "email": "support@swagger.io", + "extensions": {} } |] @@ -115,12 +123,14 @@ contactExampleJSON = [aesonQQ| licenseExample :: License licenseExample = "Apache 2.0" & url ?~ URL "http://www.apache.org/licenses/LICENSE-2.0.html" + & extensions .~ mempty licenseExampleJSON :: Value licenseExampleJSON = [aesonQQ| { "name": "Apache 2.0", - "url": "http://www.apache.org/licenses/LICENSE-2.0.html" + "url": "http://www.apache.org/licenses/LICENSE-2.0.html", + "extensions": {} } |] @@ -152,6 +162,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 +217,8 @@ operationExampleJSON = [aesonQQ| "read:pets" ] } - ] + ], + "x-ext1": true } |] @@ -238,6 +250,7 @@ schemaSimpleModelExample = mempty & minimum_ ?~ 0 & type_ ?~ OpenApiInteger & format ?~ "int32" ) ] + & extensions .~ SpecificationExtensions (InsOrdHM.fromList [("ext1", toJSON True)]) schemaSimpleModelExampleJSON :: Value schemaSimpleModelExampleJSON = [aesonQQ| @@ -255,7 +268,8 @@ schemaSimpleModelExampleJSON = [aesonQQ| "type": "integer" } }, - "type": "object" + "type": "object", + "x-ext1": true } |] @@ -456,15 +470,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 , _oAuth2Scopes = [ ("write:pets", "modify pets in your account") - , ("read:pets", "read your pets") ] } ) - , _securitySchemeDescription = Nothing }) ] + , ("read:pets", "read your pets") ] + , _oAuth2Extensions = mempty } ) + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = SpecificationExtensions (InsOrdHM.fromList [("ext1", toJSON True)])})] securityDefinitionsExampleJSON :: Value securityDefinitionsExampleJSON = [aesonQQ| @@ -484,7 +501,8 @@ securityDefinitionsExampleJSON = [aesonQQ| }, "authorizationUrl": "http://swagger.io/api/oauth/dialog" } - } + }, + "x-ext1": true } } @@ -497,8 +515,10 @@ oAuth2SecurityDefinitionsReadExample = SecurityDefinitions { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" , _oAath2RefreshUrl = Nothing , _oAuth2Scopes = - [ ("read:pets", "read your pets") ] } ) - , _securitySchemeDescription = Nothing }) + [ ("read:pets", "read your pets") ] + , _oAuth2Extensions = mempty } ) + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = mempty }) ] oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions @@ -508,8 +528,10 @@ oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog" , _oAath2RefreshUrl = Nothing , _oAuth2Scopes = - [ ("write:pets", "modify pets in your account") ] } ) - , _securitySchemeDescription = Nothing }) + [ ("write:pets", "modify pets in your account") ] + , _oAuth2Extensions = mempty } ) + , _securitySchemeDescription = Nothing + , _securitySchemeExtensions = mempty }) ] oAuth2SecurityDefinitionsEmptyExample :: SecurityDefinitions @@ -599,7 +621,7 @@ emptyPathsFieldExampleJSON :: Value emptyPathsFieldExampleJSON = [aesonQQ| { "openapi": "3.0.0", - "info": {"version": "", "title": ""}, + "info": {"version": "", "title": "", "extensions": {}}, "paths": {}, "components": {} } @@ -614,7 +636,9 @@ swaggerExample = mempty & title .~ "Todo API" & license ?~ "MIT" & license._Just.url ?~ URL "http://mit.com" + & license . _Just . extensions .~ mempty & description ?~ "This is an API that tests servant-swagger support for a Todo API") + & extensions .~ mempty & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation) & responses . at 200 ?~ Inline (mempty & description .~ "OK" @@ -651,9 +675,11 @@ swaggerExampleJSON = [aesonQQ| "title": "Todo API", "license": { "url": "http://mit.com", - "name": "MIT" + "name": "MIT", + "extensions": {} }, - "description": "This is 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", + "extensions": {} }, "paths": { "/todo/{id}": { @@ -713,8 +739,10 @@ petstoreExampleJSON = [aesonQQ| "version": "1.0.0", "title": "Swagger Petstore", "license": { - "name": "MIT" - } + "name": "MIT", + "extensions": {} + }, + "extensions": {} }, "servers": [ { From f33a35e908cf18c6e85418aafc65235608fb7136 Mon Sep 17 00:00:00 2001 From: Avery Date: Wed, 16 Mar 2022 14:20:16 +0100 Subject: [PATCH 2/9] add param extension field --- src/Data/OpenApi/Internal.hs | 4 +++- test/Data/OpenApiSpec.hs | 6 ++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 3a63aeef..86db07a3 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -553,6 +553,8 @@ data Param = Param -- the examples value SHALL override the example provided by the schema. , _paramExamples :: InsOrdHashMap Text (Referenced Example) + , _paramExtensions :: SpecificationExtensions + -- TODO -- _paramContent :: InsOrdHashMap MediaType MediaTypeObject -- should be singleton. mutually exclusive with _paramSchema. @@ -1715,7 +1717,7 @@ instance HasSwaggerAesonOptions OAuth2Flows where instance HasSwaggerAesonOptions Operation where swaggerAesonOptions _ = mkSwaggerAesonOptions "operation" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Param where - swaggerAesonOptions _ = mkSwaggerAesonOptions "param" + swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions PathItem where swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Response where diff --git a/test/Data/OpenApiSpec.hs b/test/Data/OpenApiSpec.hs index 313e4543..ba411700 100644 --- a/test/Data/OpenApiSpec.hs +++ b/test/Data/OpenApiSpec.hs @@ -150,7 +150,8 @@ operationExample = mempty & description ?~ "ID of pet that needs to be updated" & required ?~ True & in_ .~ ParamPath - & schema ?~ Inline (mempty & type_ ?~ OpenApiString))] + & schema ?~ Inline (mempty & type_ ?~ OpenApiString) + & extensions .~ SpecificationExtensions (InsOrdHM.fromList [("param-extension-here", "SomeString")]))] & requestBody ?~ Inline ( mempty & content . at "application/x-www-form-urlencoded" ?~ (mempty & schema ?~ (Inline (mempty & properties . at "petId" ?~ Inline (mempty @@ -181,7 +182,8 @@ operationExampleJSON = [aesonQQ| }, "in": "path", "name": "petId", - "description": "ID of pet that needs to be updated" + "description": "ID of pet that needs to be updated", + "x-param-extension-here": "SomeString" } ], "requestBody": { From 5780c5310ab9902f324b9b08b9516f6affac13ee Mon Sep 17 00:00:00 2001 From: Avery Date: Wed, 16 Mar 2022 14:34:53 +0100 Subject: [PATCH 3/9] Add better extension lens support --- src/Data/OpenApi/Internal.hs | 5 ++-- src/Data/OpenApi/Lens.hs | 6 +++++ stack.yaml.lock | 47 ++++++++++++++++++++++++++++++++++++ test/Data/OpenApiSpec.hs | 8 +++--- 4 files changed, 60 insertions(+), 6 deletions(-) create mode 100644 stack.yaml.lock diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 86db07a3..244a1ff0 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -1035,9 +1035,10 @@ data AdditionalProperties | AdditionalPropertiesSchema (Referenced Schema) deriving (Eq, Show, Data, Typeable) + newtype OpenApiSpecVersion = OpenApiSpecVersion {getVersion :: Version} deriving (Eq, Show, Generic, Data, Typeable) -newtype SpecificationExtensions = SpecificationExtensions {getSpecificationExtensions :: Definitions Value} +newtype SpecificationExtensions = SpecificationExtensions { _unDefs :: Definitions Value} deriving (Eq, Show, Hashable, Data, Typeable, Semigroup, Monoid, SwaggerMonoid, AesonDefaultValue) ------------------------------------------------------------------------------- @@ -1520,7 +1521,7 @@ instance ToJSON Callback where toJSON (Callback ps) = toJSON ps instance ToJSON SpecificationExtensions where - toJSON = toJSON . addExtPrefix . getSpecificationExtensions + toJSON = toJSON . addExtPrefix . _unDefs where addExtPrefix = InsOrdHashMap.mapKeys ("x-" <>) diff --git a/src/Data/OpenApi/Lens.hs b/src/Data/OpenApi/Lens.hs index b8e23101..a434ca06 100644 --- a/src/Data/OpenApi/Lens.hs +++ b/src/Data/OpenApi/Lens.hs @@ -57,6 +57,7 @@ makeFields ''Encoding makeFields ''Example makeFields ''Discriminator makeFields ''Link +makeLenses ''SpecificationExtensions -- * Prisms -- ** 'SecuritySchemeType' prisms @@ -89,9 +90,11 @@ _OpenApiItemsObject type instance Index Responses = HttpStatusCode type instance Index Operation = HttpStatusCode +type instance Index SpecificationExtensions = Text type instance IxValue Responses = Referenced Response type instance IxValue Operation = Referenced Response +type instance IxValue SpecificationExtensions = Value instance Ixed Responses where ix n = responses . ix n instance At Responses where at n = responses . at n @@ -99,6 +102,9 @@ 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 +instance Ixed SpecificationExtensions where ix n = unDefs . ix n +instance At SpecificationExtensions where at n = unDefs . at n + instance HasType NamedSchema (Maybe OpenApiType) where type_ = schema.type_ -- OVERLAPPABLE instances diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 00000000..4cf8f146 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,47 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: optics-core-0.3@sha256:0464583aaef715f8e48b8c9ce3fab9866345de93e740dae32d5c5e9a57097bf7,4532 + pantry-tree: + size: 5030 + sha256: d87366c3a2d4099a7a1d54df029a38e24b591ba8fb88d56fabf0c5c4bc345a51 + original: + hackage: optics-core-0.3 +- completed: + hackage: optics-th-0.3@sha256:b4746b3d142feb2dc9dfcf76b49a11fd04321aa0ee9c1bcd297c5e8dc393803c,1965 + pantry-tree: + size: 653 + sha256: 24e990405793450726f6364034614c715537b0ed3f21fafc9ce0267979feb01b + original: + hackage: optics-th-0.3 +- completed: + hackage: optics-extra-0.3@sha256:99696d87a92025e5f8d02e418b7851115e30a3d1425fba4afb6d41a0445cddd5,3492 + pantry-tree: + size: 1809 + sha256: 4d07622a2f3f62882de4f431d7f600053a8b461d5aa372c7ae596b672efab644 + original: + hackage: optics-extra-0.3 +- completed: + hackage: indexed-profunctors-0.1@sha256:ddf618d0d4c58319c1e735e746bc69a1021f13b6f475dc9614b80af03432e6d4,1016 + pantry-tree: + size: 235 + sha256: cfd66c0a53be1b45eae72df112ea1158614458bb7b1c9cbbe3410b04ab011ec6 + original: + hackage: indexed-profunctors-0.1 +- completed: + hackage: insert-ordered-containers-0.2.3.1@sha256:003307d51ba47411ead1f79b8559569b220723aea7439341d16980213f7520e9,2324 + pantry-tree: + size: 541 + sha256: c5b7b2a76cb090a990e9abbc671cb8913859925f230cd37ab1691ddca301fe06 + original: + hackage: insert-ordered-containers-0.2.3.1 +snapshots: +- completed: + size: 534126 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml + sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6 + original: lts-16.31 diff --git a/test/Data/OpenApiSpec.hs b/test/Data/OpenApiSpec.hs index ba411700..bbba5e29 100644 --- a/test/Data/OpenApiSpec.hs +++ b/test/Data/OpenApiSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE LambdaCase #-} module Data.OpenApiSpec where import Prelude () @@ -15,7 +16,6 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashSet.InsOrd as InsOrdHS import Data.Text (Text) -import Data.OpenApi import SpecCommon import Test.Hspec hiding (example) import qualified Data.HashMap.Strict.InsOrd as InsOrdHM @@ -48,7 +48,7 @@ spec = do context "Todo Example" $ swaggerExample <=> swaggerExampleJSON context "PetStore Example" $ do it "decodes successfully" $ do - fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: OpenApi) -> True; _ -> False) + fromJSON petstoreExampleJSON `shouldSatisfy` (\case Success (_ :: OpenApi) -> True; _ -> False) it "roundtrips: fmap toJSON . fromJSON" $ do (toJSON :: OpenApi -> Value) <$> fromJSON petstoreExampleJSON `shouldBe` Success petstoreExampleJSON context "Security schemes" $ do @@ -153,13 +153,13 @@ operationExample = mempty & schema ?~ Inline (mempty & type_ ?~ OpenApiString) & extensions .~ SpecificationExtensions (InsOrdHM.fromList [("param-extension-here", "SomeString")]))] & requestBody ?~ Inline ( - mempty & content . at "application/x-www-form-urlencoded" ?~ (mempty & schema ?~ (Inline (mempty + mempty & content . at "application/x-www-form-urlencoded" ?~ (mempty & schema ?~ Inline (mempty & properties . at "petId" ?~ Inline (mempty & description ?~ "Updated name of the pet" & type_ ?~ OpenApiString) & properties . at "status" ?~ Inline (mempty & description ?~ "Updated status of the pet" - & type_ ?~ OpenApiString))))) + & type_ ?~ OpenApiString)))) & at 200 ?~ "Pet updated." & at 405 ?~ "Invalid input" & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]] From 0ce05fb2f563a55989c783c2db898f9e785390a4 Mon Sep 17 00:00:00 2001 From: Avery Date: Wed, 16 Mar 2022 15:02:59 +0100 Subject: [PATCH 4/9] add header extensions and paramlocation ord --- src/Data/OpenApi/Internal.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 244a1ff0..822b373d 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -659,7 +659,7 @@ data ParamLocation | ParamPath -- | Used to pass a specific cookie value to the API. | ParamCookie - deriving (Eq, Show, Generic, Data, Typeable) + deriving (Eq, Ord, Show, Generic, Data, Typeable) type Format = Text @@ -833,6 +833,7 @@ data Header = Header , _headerExamples :: InsOrdHashMap Text (Referenced Example) , _headerSchema :: Maybe (Referenced Schema) + , _headerExtensions :: SpecificationExtensions } deriving (Eq, Show, Generic, Data, Typeable) -- | The location of the API key. @@ -1710,7 +1711,7 @@ instance HasSwaggerAesonOptions Server where instance HasSwaggerAesonOptions Components where swaggerAesonOptions _ = mkSwaggerAesonOptions "components" instance HasSwaggerAesonOptions Header where - swaggerAesonOptions _ = mkSwaggerAesonOptions "header" + swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject .~ ["extensions"] instance AesonDefaultValue p => HasSwaggerAesonOptions (OAuth2Flow p) where swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject .~ ["params", "extensions"] instance HasSwaggerAesonOptions OAuth2Flows where From 7471a6f671468aa43979ec2191e14075a3e0ce7f Mon Sep 17 00:00:00 2001 From: Avery Date: Wed, 16 Mar 2022 15:11:48 +0100 Subject: [PATCH 5/9] add hashable instance --- src/Data/OpenApi/Internal.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 822b373d..18efad15 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -661,6 +661,8 @@ data ParamLocation | ParamCookie deriving (Eq, Ord, Show, Generic, Data, Typeable) +instance Hashable ParamLocation + type Format = Text type ParamName = Text From 169d24908c1d97355d6742d94b61ba4db043992f Mon Sep 17 00:00:00 2001 From: Avery Date: Wed, 16 Mar 2022 16:35:11 +0100 Subject: [PATCH 6/9] more gracefully handle optional extensions --- src/Data/OpenApi/Internal.hs | 41 +++++++++++++------------ src/Data/OpenApi/Internal/AesonUtils.hs | 32 ++++++++++++++++--- test/Data/OpenApiSpec.hs | 35 +++++++-------------- 3 files changed, 60 insertions(+), 48 deletions(-) diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 18efad15..8d884314 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -14,6 +14,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} module Data.OpenApi.Internal where import Prelude () @@ -52,7 +53,7 @@ import Data.OpenApi.Aeson.Compat (deleteKey, filterWithKey, objectToList, import Data.OpenApi.Internal.AesonUtils (AesonDefaultValue (..), HasSwaggerAesonOptions (..), mkSwaggerAesonOptions, saoAdditionalPairs, saoSubObject, sopSwaggerGenericParseJSON, sopSwaggerGenericToEncoding, - sopSwaggerGenericToJSON, sopSwaggerGenericToJSONWithOpts) + sopSwaggerGenericToJSON, sopSwaggerGenericToJSONWithOpts, sopSwaggerGenericParseJSONWithOpts) import Data.OpenApi.Internal.Utils import Generics.SOP.TH (deriveGeneric) import Data.Version @@ -661,7 +662,7 @@ data ParamLocation | ParamCookie deriving (Eq, Ord, Show, Generic, Data, Typeable) -instance Hashable ParamLocation +instance Hashable ParamLocation type Format = Text @@ -1259,15 +1260,6 @@ 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") @@ -1314,15 +1306,6 @@ 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") @@ -1528,6 +1511,15 @@ instance ToJSON SpecificationExtensions where where addExtPrefix = InsOrdHashMap.mapKeys ("x-" <>) +instance ToJSON Info where + toJSON = sopSwaggerGenericToJSONWithOpts (mkSwaggerAesonOptions "Info") + +instance ToJSON Contact where + toJSON = sopSwaggerGenericToJSONWithOpts (mkSwaggerAesonOptions "Contact") + +instance ToJSON License where + toJSON = sopSwaggerGenericToJSONWithOpts (mkSwaggerAesonOptions "License") + -- ======================================================================= -- Manual FromJSON instances -- ======================================================================= @@ -1708,6 +1700,15 @@ instance FromJSON SpecificationExtensions where extFieldsParser = pure . SpecificationExtensions . InsOrdHashMap.fromList . catMaybes . filterExtFields filterExtFields = fmap (\(k, v) -> fmap (\k' -> (k', v)) $ Text.stripPrefix "x-" (keyToText k)) . objectToList +instance FromJSON Info where + parseJSON = sopSwaggerGenericParseJSONWithOpts (mkSwaggerAesonOptions "Info") + +instance FromJSON Contact where + parseJSON = sopSwaggerGenericParseJSONWithOpts (mkSwaggerAesonOptions "Contact") + +instance FromJSON License where + parseJSON = sopSwaggerGenericParseJSONWithOpts (mkSwaggerAesonOptions "License") + instance HasSwaggerAesonOptions Server where swaggerAesonOptions _ = mkSwaggerAesonOptions "server" instance HasSwaggerAesonOptions Components where diff --git a/src/Data/OpenApi/Internal/AesonUtils.hs b/src/Data/OpenApi/Internal/AesonUtils.hs index 91a27cf3..70e9cc34 100644 --- a/src/Data/OpenApi/Internal/AesonUtils.hs +++ b/src/Data/OpenApi/Internal/AesonUtils.hs @@ -12,6 +12,7 @@ module Data.OpenApi.Internal.AesonUtils ( sopSwaggerGenericToEncoding, sopSwaggerGenericToJSONWithOpts, sopSwaggerGenericParseJSON, + sopSwaggerGenericParseJSONWithOpts, -- * Options HasSwaggerAesonOptions(..), SwaggerAesonOptions, @@ -176,8 +177,7 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go ------------------------------------------------------------------------------- -- FromJSON ------------------------------------------------------------------------------- - -sopSwaggerGenericParseJSON +sopSwaggerGenericParseJSONWithOpts :: forall a xs. ( HasDatatypeInfo a , HasSwaggerAesonOptions a @@ -185,13 +185,37 @@ sopSwaggerGenericParseJSON , All2 Eq (Code a) , Code a ~ '[xs] ) - => Value + => SwaggerAesonOptions + -> Value -> Parser a -sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj -> +sopSwaggerGenericParseJSONWithOpts opts = withObject "Swagger Record Object" $ \obj -> let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy) in do traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs) to <$> ps + where + proxy = Proxy :: Proxy a + + parseAdditionalField :: Object -> Pair -> Parser () + parseAdditionalField obj (k, v) = do + v' <- obj .: k + unless (v == v') $ fail $ + "Additonal field don't match for key " ++ keyToString k + ++ ": " ++ show v + ++ " /= " ++ show v' + + +sopSwaggerGenericParseJSON + :: forall a xs. + ( HasDatatypeInfo a + , HasSwaggerAesonOptions a + , All2 FromJSON (Code a) + , All2 Eq (Code a) + , Code a ~ '[xs] + ) + => Value + -> Parser a +sopSwaggerGenericParseJSON = sopSwaggerGenericParseJSONWithOpts opts where proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy diff --git a/test/Data/OpenApiSpec.hs b/test/Data/OpenApiSpec.hs index bbba5e29..7965aa33 100644 --- a/test/Data/OpenApiSpec.hs +++ b/test/Data/OpenApiSpec.hs @@ -71,7 +71,6 @@ infoExample = mempty & contact ?~ contactExample & license ?~ licenseExample & version .~ "1.0.1" - & extensions .~ mempty infoExampleJSON :: Value infoExampleJSON = [aesonQQ| @@ -82,16 +81,13 @@ infoExampleJSON = [aesonQQ| "contact": { "name": "API Support", "url": "http://www.swagger.io/support", - "email": "support@swagger.io", - "extensions": {} + "email": "support@swagger.io" }, "license": { "name": "Apache 2.0", - "url": "http://www.apache.org/licenses/LICENSE-2.0.html", - "extensions": {} + "url": "http://www.apache.org/licenses/LICENSE-2.0.html" }, - "version": "1.0.1", - "extensions": {} + "version": "1.0.1" } |] @@ -104,15 +100,13 @@ contactExample = mempty & name ?~ "API Support" & url ?~ URL "http://www.swagger.io/support" & email ?~ "support@swagger.io" - & extensions .~ mempty contactExampleJSON :: Value contactExampleJSON = [aesonQQ| { "name": "API Support", "url": "http://www.swagger.io/support", - "email": "support@swagger.io", - "extensions": {} + "email": "support@swagger.io" } |] @@ -123,14 +117,12 @@ contactExampleJSON = [aesonQQ| licenseExample :: License licenseExample = "Apache 2.0" & url ?~ URL "http://www.apache.org/licenses/LICENSE-2.0.html" - & extensions .~ mempty licenseExampleJSON :: Value licenseExampleJSON = [aesonQQ| { "name": "Apache 2.0", - "url": "http://www.apache.org/licenses/LICENSE-2.0.html", - "extensions": {} + "url": "http://www.apache.org/licenses/LICENSE-2.0.html" } |] @@ -623,7 +615,7 @@ emptyPathsFieldExampleJSON :: Value emptyPathsFieldExampleJSON = [aesonQQ| { "openapi": "3.0.0", - "info": {"version": "", "title": "", "extensions": {}}, + "info": {"version": "", "title": ""}, "paths": {}, "components": {} } @@ -638,9 +630,8 @@ swaggerExample = mempty & title .~ "Todo API" & license ?~ "MIT" & license._Just.url ?~ URL "http://mit.com" - & license . _Just . extensions .~ mempty & description ?~ "This is an API that tests servant-swagger support for a Todo API") - & extensions .~ mempty + & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation) & responses . at 200 ?~ Inline (mempty & description .~ "OK" @@ -677,11 +668,9 @@ swaggerExampleJSON = [aesonQQ| "title": "Todo API", "license": { "url": "http://mit.com", - "name": "MIT", - "extensions": {} + "name": "MIT" }, - "description": "This is an API that tests servant-swagger support for a Todo API", - "extensions": {} + "description": "This is an API that tests servant-swagger support for a Todo API" }, "paths": { "/todo/{id}": { @@ -741,10 +730,8 @@ petstoreExampleJSON = [aesonQQ| "version": "1.0.0", "title": "Swagger Petstore", "license": { - "name": "MIT", - "extensions": {} - }, - "extensions": {} + "name": "MIT" + } }, "servers": [ { From 2156a913bc3192c5ec41551eb24d1c6ee3c3bd73 Mon Sep 17 00:00:00 2001 From: PrettyPrincessKitty FS Date: Wed, 16 Mar 2022 16:02:27 +0100 Subject: [PATCH 7/9] Add better default value for extensions --- src/Data/OpenApi/Internal.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 8d884314..3125fc00 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -1043,7 +1043,10 @@ data AdditionalProperties newtype OpenApiSpecVersion = OpenApiSpecVersion {getVersion :: Version} deriving (Eq, Show, Generic, Data, Typeable) newtype SpecificationExtensions = SpecificationExtensions { _unDefs :: Definitions Value} - deriving (Eq, Show, Hashable, Data, Typeable, Semigroup, Monoid, SwaggerMonoid, AesonDefaultValue) + deriving (Eq, Show, Hashable, Data, Typeable, Semigroup, Monoid, SwaggerMonoid) + +instance AesonDefaultValue SpecificationExtensions where + defaultValue = Just (SpecificationExtensions mempty) ------------------------------------------------------------------------------- -- Generic instances From 86511acc85681c8cfdc4a1fe94c2bda2410358f5 Mon Sep 17 00:00:00 2001 From: Avery Date: Wed, 16 Mar 2022 16:49:59 +0100 Subject: [PATCH 8/9] Oops, forgot some instances --- src/Data/OpenApi/Internal.hs | 48 ++++++++++++++++++------------------ 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 3125fc00..00c49db3 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -1263,24 +1263,12 @@ instance ToJSON OpenApiType where instance ToJSON ParamLocation where toJSON = genericToJSON (jsonPrefix "Param") -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") @@ -1309,21 +1297,12 @@ instance FromJSON OpenApiType where instance FromJSON ParamLocation where parseJSON = genericParseJSON (jsonPrefix "Param") -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") @@ -1523,6 +1502,18 @@ instance ToJSON Contact where instance ToJSON License where toJSON = sopSwaggerGenericToJSONWithOpts (mkSwaggerAesonOptions "License") +instance ToJSON ServerVariable where + toJSON = sopSwaggerGenericToJSONWithOpts (mkSwaggerAesonOptions "ServerVariable") + +instance ToJSON Tag where + toJSON = sopSwaggerGenericToJSONWithOpts (mkSwaggerAesonOptions "Tag") + +instance ToJSON ExternalDocs where + toJSON = sopSwaggerGenericToJSONWithOpts (mkSwaggerAesonOptions "ExternalDocs") + +instance ToJSON Xml where + toJSON = sopSwaggerGenericToJSONWithOpts (mkSwaggerAesonOptions "Xml") + -- ======================================================================= -- Manual FromJSON instances -- ======================================================================= @@ -1682,9 +1673,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 @@ -1712,6 +1700,18 @@ instance FromJSON Contact where instance FromJSON License where parseJSON = sopSwaggerGenericParseJSONWithOpts (mkSwaggerAesonOptions "License") +instance FromJSON ServerVariable where + parseJSON = sopSwaggerGenericParseJSONWithOpts (mkSwaggerAesonOptions "ServerVariable") + +instance FromJSON Tag where + parseJSON = sopSwaggerGenericParseJSONWithOpts (mkSwaggerAesonOptions "Tag") + +instance FromJSON ExternalDocs where + parseJSON = sopSwaggerGenericParseJSONWithOpts (mkSwaggerAesonOptions "ExternalDocs") + +instance FromJSON Xml where + parseJSON = sopSwaggerGenericParseJSONWithOpts (mkSwaggerAesonOptions "xml") + instance HasSwaggerAesonOptions Server where swaggerAesonOptions _ = mkSwaggerAesonOptions "server" instance HasSwaggerAesonOptions Components where From c2575dfbbf487c8019201ad1abe2d9b49fdc5685 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Thu, 24 Mar 2022 15:12:42 +0100 Subject: [PATCH 9/9] Aeson 2 for extensions --- src/Data/OpenApi/Aeson/Compat.hs | 6 ++++++ src/Data/OpenApi/Internal.hs | 19 +++++++++---------- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/src/Data/OpenApi/Aeson/Compat.hs b/src/Data/OpenApi/Aeson/Compat.hs index ca5d441e..90413402 100644 --- a/src/Data/OpenApi/Aeson/Compat.hs +++ b/src/Data/OpenApi/Aeson/Compat.hs @@ -46,6 +46,9 @@ lookupKey = KeyMap.lookup . Key.fromText hasKey :: T.Text -> KeyMap.KeyMap a -> Bool hasKey = KeyMap.member . Key.fromText + +filterKeys :: (Key -> Bool) -> KeyMap.KeyMap a -> KeyMap.KeyMap a +filterKeys p = KeyMap.filterWithKey (\key _ -> p key) #else filterWithKey :: (T.Text -> v -> Bool) -> HM.HashMap T.Text v -> HM.HashMap T.Text v filterWithKey = HM.filterWithKey @@ -79,4 +82,7 @@ lookupKey = HM.lookup hasKey :: T.Text -> HM.HashMap T.Text a -> Bool hasKey = HM.member + +filterKeys :: (T.Text -> Bool) -> HM.HashMap T.Text a -> HM.HashMap T.Text a +filterKeys p = HM.filterWithKey (\key _ -> p key) #endif diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 00c49db3..2d8101e8 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -49,7 +49,7 @@ import Text.Read (readMaybe) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap -import Data.OpenApi.Aeson.Compat (deleteKey, filterWithKey, objectToList, keyToText) +import Data.OpenApi.Aeson.Compat (deleteKey, filterKeys, objectToList, keyToText) import Data.OpenApi.Internal.AesonUtils (AesonDefaultValue (..), HasSwaggerAesonOptions (..), mkSwaggerAesonOptions, saoAdditionalPairs, saoSubObject, sopSwaggerGenericParseJSON, sopSwaggerGenericToEncoding, @@ -1606,14 +1606,14 @@ instance FromJSON Responses where <$> o .:? "default" <*> parseJSON ( Object - ( filterWithKey (\k _ -> not $ isExt k) - $ deleteKey "default" o + ( filterKeys (not . isExt . keyToText) $ + deleteKey "default" o ) ) - <*> case filterWithKey (\k _ -> isExt k) o of - exts - | null exts -> pure (SpecificationExtensions mempty) - | otherwise -> parseJSON (Object exts) + <*> case filterKeys (isExt . keyToText) o of + exts + | null exts -> pure (SpecificationExtensions mempty) + | otherwise -> parseJSON (Object exts) parseJSON _ = empty @@ -1689,7 +1689,7 @@ 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 + filterExtFields = fmap (\(k, v) -> (, v) <$> Text.stripPrefix "x-" (keyToText k)) . objectToList instance FromJSON Info where parseJSON = sopSwaggerGenericParseJSONWithOpts (mkSwaggerAesonOptions "Info") @@ -1743,8 +1743,7 @@ instance HasSwaggerAesonOptions Schema where instance HasSwaggerAesonOptions OpenApiSpecVersion where swaggerAesonOptions _ = mkSwaggerAesonOptions "openapi" instance HasSwaggerAesonOptions OpenApi where - swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" - & saoSubObject .~ ["extensions"] + swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Example where swaggerAesonOptions _ = mkSwaggerAesonOptions "example" & saoSubObject .~ ["extensions"] instance HasSwaggerAesonOptions Encoding where