From 8a307e99e08a86680ed3c218ad2019b1db76c8e2 Mon Sep 17 00:00:00 2001 From: Daniel Chambers Date: Fri, 29 Apr 2022 17:44:28 +1000 Subject: [PATCH] Added ability to have external references --- openapi3.cabal | 1 + src/Data/OpenApi.hs | 2 +- src/Data/OpenApi/Internal.hs | 31 ++++++++++++++----- src/Data/OpenApi/Internal/Schema.hs | 16 +++++++--- .../OpenApi/Internal/Schema/Validation.hs | 6 ++-- src/Data/OpenApi/Lens.hs | 2 ++ src/Data/OpenApi/Operation.hs | 3 +- src/Data/OpenApi/Optics.hs | 2 +- src/Data/OpenApi/Schema/Generator.hs | 5 +-- test/Data/OpenApiSpec.hs | 4 +-- 10 files changed, 51 insertions(+), 21 deletions(-) diff --git a/openapi3.cabal b/openapi3.cabal index 8718c151..bc7ff5d9 100644 --- a/openapi3.cabal +++ b/openapi3.cabal @@ -85,6 +85,7 @@ library , insert-ordered-containers >=0.2.3 && <0.3 , lens >=4.16.1 && <5.2 , network >=2.6.3.5 && <3.2 + , network-uri >=2.6.4.0 && <2.7 , optics-core >=0.2 && <0.5 , optics-th >=0.2 && <0.5 , scientific >=0.3.6.2 && <0.4 diff --git a/src/Data/OpenApi.hs b/src/Data/OpenApi.hs index e8c8ea6e..d6091b6e 100644 --- a/src/Data/OpenApi.hs +++ b/src/Data/OpenApi.hs @@ -214,7 +214,7 @@ import Data.OpenApi.Internal -- & components . schemas .~ [ ("User", mempty & type_ ?~ OpenApiString) ] -- & paths .~ -- [ ("/user", mempty & get ?~ (mempty --- & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (Reference "User"))) +-- & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (InternalReference "User"))) -- & at 404 ?~ "User info not found")) ] -- :} -- { diff --git a/src/Data/OpenApi/Internal.hs b/src/Data/OpenApi/Internal.hs index 5395ff25..f32fdf8a 100644 --- a/src/Data/OpenApi/Internal.hs +++ b/src/Data/OpenApi/Internal.hs @@ -44,6 +44,7 @@ import GHC.Generics (Generic) import Network.HTTP.Media (MediaType, mainType, parameters, parseAccept, subType, (//), (/:)) import Network.Socket (HostName, PortNumber) +import Network.URI (URI, parseURIReference, uriToString) import Text.Read (readMaybe) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) @@ -943,8 +944,13 @@ data ExternalDocs = ExternalDocs instance Hashable ExternalDocs -- | A simple object to allow referencing other definitions in the specification. --- It can be used to reference parameters and responses that are defined at the top level for reuse. -newtype Reference = Reference { getReference :: Text } +-- It can be used to reference parameters and responses that are defined at the top level for reuse +-- or for referencing definitions from external schemas via a URI. +data Reference + = -- | For referencing definitions from within the current OpenAPI schema. + InternalReference Text + -- | For referencing definitions from external schemas. + | ExternalReference URI deriving (Eq, Show, Data, Typeable) data Referenced a @@ -1392,10 +1398,12 @@ instance ToJSON SecurityDefinitions where toJSON (SecurityDefinitions sd) = toJSON sd instance ToJSON Reference where - toJSON (Reference ref) = object [ "$ref" .= ref ] + toJSON (InternalReference ref) = object [ "$ref" .= ref ] + toJSON (ExternalReference uri) = object [ "$ref" .= uriToString id uri "" ] referencedToJSON :: ToJSON a => Text -> Referenced a -> Value -referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ] +referencedToJSON prefix (Ref (InternalReference ref)) = object [ "$ref" .= (prefix <> ref) ] +referencedToJSON prefix (Ref (ExternalReference uri)) = object [ "$ref" .= uriToString id uri "" ] referencedToJSON _ (Inline x) = toJSON x instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/components/schemas/" @@ -1523,7 +1531,14 @@ instance FromJSON Link where parseJSON = sopSwaggerGenericParseJSON instance FromJSON Reference where - parseJSON (Object o) = Reference <$> o .: "$ref" + parseJSON (Object o) = do + ref <- o .: "$ref" + if "#" `Text.isPrefixOf` ref + then pure $ InternalReference ref + else + let refError = fail "expected $ref to be either a URI or a fragment" + in maybe refError (pure . ExternalReference) . parseURIReference $ Text.unpack ref + parseJSON _ = empty referencedParseJSON :: FromJSON a => Text -> Value -> JSON.Parser (Referenced a) @@ -1535,8 +1550,10 @@ referencedParseJSON prefix js@(Object o) = do where parseRef s = do case Text.stripPrefix prefix s of - Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s - Just suffix -> pure (Reference suffix) + Nothing -> + let refError = fail $ "expected $ref to be either a URI, or of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s + in maybe refError (pure . ExternalReference) . parseURIReference $ Text.unpack s + Just suffix -> pure (InternalReference suffix) referencedParseJSON _ _ = fail "referenceParseJSON: not an object" instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/components/schemas/" diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index f8649640..b6921071 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -58,6 +58,7 @@ import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU import Data.Version (Version) +import Network.URI (uriToString) import Numeric.Natural.Compat (Natural) import Data.Word import GHC.Generics @@ -241,7 +242,7 @@ declareSchemaRef proxy = do when (not known) $ do declare [(name, schema)] void $ declareNamedSchema proxy - return $ Ref (Reference name) + return $ Ref (InternalReference name) _ -> Inline <$> declareSchema proxy -- | Inline any referenced schema if its name satisfies given predicate. @@ -254,13 +255,17 @@ declareSchemaRef proxy = do inlineSchemasWhen :: Data s => (T.Text -> Bool) -> (Definitions Schema) -> s -> s inlineSchemasWhen p defs = template %~ deref where - deref r@(Ref (Reference name)) + deref r@(Ref (InternalReference name)) = tryInline r name + deref r@(Ref (ExternalReference uri)) = tryInline r (T.pack $ uriToString id uri "") + deref (Inline schema) = Inline (inlineSchemasWhen p defs schema) + + tryInline r name | p name = case InsOrdHashMap.lookup name defs of Just schema -> Inline (inlineSchemasWhen p defs schema) Nothing -> r | otherwise = r - deref (Inline schema) = Inline (inlineSchemasWhen p defs schema) + -- | Inline any referenced schema if its name is in the given list. -- @@ -313,11 +318,12 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs schemaRefNames :: Referenced Schema -> Declare [T.Text] () schemaRefNames ref = case ref of - Ref (Reference name) -> do + Ref (InternalReference name) -> do seen <- looks (name `elem`) when (not seen) $ do declare [name] traverse_ usedNames (InsOrdHashMap.lookup name defs) + Ref (ExternalReference name) -> pure () Inline subschema -> usedNames subschema -- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance. @@ -971,7 +977,7 @@ gdeclareSchemaRef opts proxy = do when (not known) $ do declare [(name, schema)] void $ gdeclareNamedSchema opts proxy mempty - return $ Ref (Reference name) + return $ Ref (InternalReference name) _ -> Inline <$> gdeclareSchema opts proxy appendItem :: Referenced Schema -> Maybe OpenApiItems -> Maybe OpenApiItems diff --git a/src/Data/OpenApi/Internal/Schema/Validation.hs b/src/Data/OpenApi/Internal/Schema/Validation.hs index 7893ce0b..a78c652b 100644 --- a/src/Data/OpenApi/Internal/Schema/Validation.hs +++ b/src/Data/OpenApi/Internal/Schema/Validation.hs @@ -293,10 +293,12 @@ sub_ = lmap . view -- | Validate value against a schema given schema reference and validation function. withRef :: Reference -> (Schema -> Validation s a) -> Validation s a -withRef (Reference ref) f = withConfig $ \cfg -> +withRef (InternalReference ref) f = withConfig $ \cfg -> case InsOrdHashMap.lookup ref (configDefinitions cfg) of Nothing -> invalid $ "unknown schema " ++ show ref Just s -> f s +withRef (ExternalReference uri) _f = + invalid $ "external schema reference " ++ show uri validateWithSchemaRef :: Referenced Schema -> Value -> Validation s () validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js) @@ -385,7 +387,7 @@ validateObject o = withSchema $ \sch -> Just (Success pvalue) -> let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types -- TODO ref may be name or reference - in validateWithSchemaRef (Ref (Reference ref)) (Object o) + in validateWithSchemaRef (Ref (InternalReference ref)) (Object o) Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg) Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing") Nothing -> do diff --git a/src/Data/OpenApi/Lens.hs b/src/Data/OpenApi/Lens.hs index b8e23101..5c26c2f2 100644 --- a/src/Data/OpenApi/Lens.hs +++ b/src/Data/OpenApi/Lens.hs @@ -63,6 +63,8 @@ makeFields ''Link makePrisms ''SecuritySchemeType -- ** 'Referenced' prisms makePrisms ''Referenced +-- ** 'Reference prisms +makePrisms ''Reference -- ** 'OpenApiItems' prisms diff --git a/src/Data/OpenApi/Operation.hs b/src/Data/OpenApi/Operation.hs index 9a2484b1..3fdf80dd 100644 --- a/src/Data/OpenApi/Operation.hs +++ b/src/Data/OpenApi/Operation.hs @@ -298,8 +298,9 @@ setResponseForWith ops f code dres swag = swag where (defs, new) = runDeclare dres mempty - combine (Just (Ref (Reference n))) = case swag ^. components.responses.at n of + combine (Just (Ref (InternalReference n))) = case swag ^. components.responses.at n of Just old -> f old new Nothing -> new -- response name can't be dereferenced, replacing with new response + combine (Just (Ref (ExternalReference uri))) = new -- external reference can't be dereferenced, just replace with new combine (Just (Inline old)) = f old new combine Nothing = new diff --git a/src/Data/OpenApi/Optics.hs b/src/Data/OpenApi/Optics.hs index feb125d7..5150d58c 100644 --- a/src/Data/OpenApi/Optics.hs +++ b/src/Data/OpenApi/Optics.hs @@ -26,7 +26,7 @@ -- & #components % #schemas .~ [ ("User", mempty & #type ?~ OpenApiString) ] -- & #paths .~ -- [ ("/user", mempty & #get ?~ (mempty --- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User"))) +-- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (InternalReference "User"))) -- & at 404 ?~ "User info not found")) ] -- :} -- { diff --git a/src/Data/OpenApi/Schema/Generator.hs b/src/Data/OpenApi/Schema/Generator.hs index 9cb4014f..bc144966 100644 --- a/src/Data/OpenApi/Schema/Generator.hs +++ b/src/Data/OpenApi/Schema/Generator.hs @@ -100,8 +100,9 @@ schemaGen defns schema = return . Object $ fromInsOrdHashMap x dereference :: Definitions a -> Referenced a -> a -dereference _ (Inline a) = a -dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs +dereference _ (Inline a) = a +dereference defs (Ref (InternalReference ref)) = fromJust $ M.lookup ref defs +dereference defs (Ref (ExternalReference ref)) = error $ "can't dereference external reference: " <> show ref genValue :: (ToSchema a) => Proxy a -> Gen Value genValue p = diff --git a/test/Data/OpenApiSpec.hs b/test/Data/OpenApiSpec.hs index eb31d267..9a71d3ef 100644 --- a/test/Data/OpenApiSpec.hs +++ b/test/Data/OpenApiSpec.hs @@ -229,7 +229,7 @@ schemaSimpleModelExample = mempty & required .~ [ "name" ] & properties .~ [ ("name", Inline (mempty & type_ ?~ OpenApiString)) - , ("address", Ref (Reference "Address")) + , ("address", Ref (InternalReference "Address")) , ("age", Inline $ mempty & minimum_ ?~ 0 & type_ ?~ OpenApiInteger @@ -935,7 +935,7 @@ compositionSchemaExample :: Schema compositionSchemaExample = mempty & type_ ?~ OpenApiObject & Data.OpenApi.allOf ?~ [ - Ref (Reference "Other") + Ref (InternalReference "Other") , Inline (mempty & type_ ?~ OpenApiObject & properties .~