Support for external references

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

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")) ]
 -- :}
 -- {

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/"

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

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

src/Data/OpenApi/Lens.hs

@@ -63,6 +63,8 @@ makeFields ''Link
 makePrisms ''SecuritySchemeType
 -- ** 'Referenced' prisms
 makePrisms ''Referenced
+-- ** 'Reference prisms
+makePrisms ''Reference
 
 -- ** 'OpenApiItems' prisms
 

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

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")) ]
 -- :}
 -- {

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 =

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 .~