Support top-level references in components

src/Data/OpenApi.hs

@@ -214,7 +214,7 @@ import Data.OpenApi.Internal
 --
 -- >>> :{
 -- BSL.putStrLn $ encodePretty $ (mempty :: OpenApi)
---   & components . schemas .~ IOHM.fromList [ ("User", mempty & type_ ?~ OpenApiString) ]
+--   & components . schemas .~ IOHM.fromList [ ("User", Inline $ mempty & type_ ?~ OpenApiString) ]
 --   & paths .~
 --     IOHM.fromList [ ("/user", mempty & get ?~ (mempty
 --         & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (Reference "User")))

src/Data/OpenApi/Internal.hs

@@ -66,7 +66,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
 -- >>> import Data.OpenApi.Internal.Utils
 
 -- | A list of definitions that can be used in references.
-type Definitions = InsOrdHashMap Text
+type Definitions a = InsOrdHashMap Text (Referenced a)
 
 -- | This is the root document object for the API specification.
 data OpenApi = OpenApi
@@ -1006,12 +1006,12 @@ deriveGeneric ''OpenApiSpecVersion
 -- =======================================================================
 
 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
@@ -1122,7 +1122,13 @@ instance Semigroup SecurityScheme where
 
 instance Semigroup SecurityDefinitions where
   (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =
-     SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2
+    SecurityDefinitions $ InsOrdHashMap.unionWith mergeRefSecuritySchemes sd1 sd2
+    where
+      -- If there's a conflict between two inline security schemes, we merge them
+      -- recursively, but otherwise we behave as the 'Semigroup' instance on
+      -- 'InsOrdHashMap' would, preferring the left value.
+      mergeRefSecuritySchemes (Inline s1) (Inline s2) = Inline (s1 <> s2)
+      mergeRefSecuritySchemes l _ = l
 
 instance Monoid SecurityDefinitions where
   mempty = SecurityDefinitions InsOrdHashMap.empty
@@ -1282,7 +1288,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
@@ -1436,6 +1442,7 @@ instance ToJSON (Referenced Example)  where toJSON = referencedToJSON "#/compone
 instance ToJSON (Referenced Header)   where toJSON = referencedToJSON "#/components/headers/"
 instance ToJSON (Referenced Link)     where toJSON = referencedToJSON "#/components/links/"
 instance ToJSON (Referenced Callback) where toJSON = referencedToJSON "#/components/callbacks/"
+instance ToJSON (Referenced SecurityScheme) where toJSON = referencedToJSON "#/components/securitySchemes/"
 
 instance ToJSON AdditionalProperties where
   toJSON (AdditionalPropertiesAllowed b) = toJSON b
@@ -1456,15 +1463,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)
 
@@ -1593,6 +1600,7 @@ instance FromJSON (Referenced Example)  where parseJSON = referencedParseJSON "#
 instance FromJSON (Referenced Header)   where parseJSON = referencedParseJSON "#/components/headers/"
 instance FromJSON (Referenced Link)     where parseJSON = referencedParseJSON "#/components/links/"
 instance FromJSON (Referenced Callback) where parseJSON = referencedParseJSON "#/components/callbacks/"
+instance FromJSON (Referenced SecurityScheme) where parseJSON = referencedParseJSON "#/components/securitySchemes/"
 
 instance FromJSON Xml where
   parseJSON = genericParseJSON (jsonPrefix "xml")
@@ -1649,7 +1657,7 @@ instance HasSwaggerAesonOptions Encoding where
 instance HasSwaggerAesonOptions Link where
   swaggerAesonOptions _ = mkSwaggerAesonOptions "link"
 
-instance AesonDefaultValue Version where 
+instance AesonDefaultValue Version where
   defaultValue = Just (makeVersion [3,0,0])
 instance AesonDefaultValue OpenApiSpecVersion
 instance AesonDefaultValue Server

src/Data/OpenApi/Internal/Schema.hs

@@ -248,7 +248,7 @@ declareSchemaRef proxy = do
       -- this schema this time and thus simply return the reference.
       known <- looks (InsOrdHashMap.member name)
       when (not known) $ do
-        declare [(name, schema)]
+        declare [(name, Inline schema)]
         void $ declareNamedSchema proxy
       return $ Ref (Reference name)
     _ -> Inline <$> declareSchema proxy
@@ -266,7 +266,7 @@ inlineSchemasWhen p defs = template %~ deref
     deref r@(Ref (Reference name))
       | p name =
           case InsOrdHashMap.lookup name defs of
-            Just schema -> Inline (inlineSchemasWhen p defs schema)
+            Just schema -> inlineSchemasWhen p defs schema
             Nothing -> r
       | otherwise = r
     deref (Inline schema) = Inline (inlineSchemasWhen p defs schema)
@@ -315,19 +315,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
   where
     nonRecursive name =
       case InsOrdHashMap.lookup name defs of
-        Just schema -> name `notElem` execDeclare (usedNames schema) mempty
+        Just schema -> name `notElem` execDeclare (schemaRefNames schema) mempty
         Nothing     -> False
 
-    usedNames schema = traverse_ schemaRefNames (schema ^.. template)
+    schemaNames :: Schema -> Declare [T.Text] ()
+    schemaNames schema = traverse_ schemaRefNames (schema ^.. template)
 
     schemaRefNames :: Referenced Schema -> Declare [T.Text] ()
     schemaRefNames ref = case ref of
       Ref (Reference name) -> do
         seen <- looks (name `elem`)
         when (not seen) $ do
           declare [name]
-          traverse_ usedNames (InsOrdHashMap.lookup name defs)
-      Inline subschema -> usedNames subschema
+          traverse_ schemaRefNames (InsOrdHashMap.lookup name defs)
+      Inline s -> schemaNames s
 
 -- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
 -- Produced schema can be used for further refinement.
@@ -978,7 +979,7 @@ gdeclareSchemaRef opts proxy = do
       -- this schema this time and thus simply return the reference.
       known <- looks (InsOrdHashMap.member name)
       when (not known) $ do
-        declare [(name, schema)]
+        declare [(name, Inline schema)]
         void $ gdeclareNamedSchema opts proxy mempty
       return $ Ref (Reference name)
     _ -> Inline <$> gdeclareSchema opts proxy

src/Data/OpenApi/Internal/Schema/Validation.hs

@@ -299,7 +299,8 @@ withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
 withRef (Reference ref) f = withConfig $ \cfg ->
   case InsOrdHashMap.lookup ref (configDefinitions cfg) of
     Nothing -> invalid $ "unknown schema " ++ show ref
-    Just s  -> f s
+    Just (Ref ref') -> invalid $ "reference to a reference is currently unsupported: " ++ show ref ++ " refers to the reference " ++ show ref'
+    Just (Inline s)  -> f s
 
 validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
 validateWithSchemaRef (Ref ref)  js = withRef ref $ \sch -> sub sch (validateWithSchema js)

src/Data/OpenApi/Operation.hs

@@ -300,7 +300,8 @@ setResponseForWith ops f code dres swag = swag
     (defs, new) = runDeclare dres mempty
 
     combine (Just (Ref (Reference n))) = case swag ^. components.responses.at n of
-      Just old -> f old new
+      Just (Inline old) -> f old new
+      Just (Ref _) -> new -- we don't chase references any further, to avoid a loop in case of recursion
       Nothing  -> new -- response name can't be dereferenced, replacing with new response
     combine (Just (Inline old)) = f old new
     combine Nothing = new

src/Data/OpenApi/Optics.hs

@@ -24,7 +24,7 @@
 --
 -- >>> :{
 -- BSL.putStrLn $ encodePretty $ (mempty :: OpenApi)
---   & #components % #schemas .~ IOHM.fromList [ ("User", mempty & #type ?~ OpenApiString) ]
+--   & #components % #schemas .~ IOHM.fromList [ ("User", Inline $ mempty & #type ?~ OpenApiString) ]
 --   & #paths .~
 --     IOHM.fromList [ ("/user", mempty & #get ?~ (mempty
 --         & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User")))

src/Data/OpenApi/Schema/Generator.hs

@@ -101,7 +101,10 @@ schemaGen defns schema =
 
 dereference :: Definitions a -> Referenced a -> a
 dereference _ (Inline a)               = a
-dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
+dereference defs (Ref (Reference ref)) = fromInline $ fromJust $ M.lookup ref defs
+  where
+    fromInline (Inline s) = s
+    fromInline (Ref _) = error "reference to another reference is unsupported"
 
 genValue :: (ToSchema a) => Proxy a -> Gen Value
 genValue p =

test/Data/OpenApiSpec.hs

@@ -39,7 +39,7 @@ spec = do
   describe "OAuth2 Security Definitions with empty Scope" $ oAuth2SecurityDefinitionsEmptyExample <=> oAuth2SecurityDefinitionsEmptyExampleJSON
   describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
   describe "Swagger Object" $ do
-    context "Example with no paths" $ do 
+    context "Example with no paths" $ do
       emptyPathsFieldExample <=> emptyPathsFieldExampleJSON
       it "fails to parse a spec with a wrong Openapi spec version" $ do
         (fromJSON wrongVersionExampleJSON :: Result OpenApi) `shouldBe` Error "The provided version 3.0.4 is out of the allowed range >=3.0.0 && <=3.0.3"
@@ -49,6 +49,11 @@ spec = do
         fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: OpenApi) -> True; _ -> False)
       it "roundtrips: fmap toJSON . fromJSON" $ do
         (toJSON :: OpenApi -> Value) <$> fromJSON petstoreExampleJSON `shouldBe` Success petstoreExampleJSON
+    context "Ref schema example" $ do
+      it "decodes successfully" $ do
+        fromJSON refSchemaExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: OpenApi) -> True; _ -> False)
+      it "roundtrips: fmap toJSON . fromJSON" $ do
+        (toJSON :: OpenApi -> Value) <$> fromJSON refSchemaExampleJSON `shouldBe` Success refSchemaExampleJSON
     context "Security schemes" $ do
       it "merged correctly" $ do
         let merged = oAuth2SecurityDefinitionsReadOpenApi <> oAuth2SecurityDefinitionsWriteOpenApi <> oAuth2SecurityDefinitionsEmptyOpenApi
@@ -454,17 +459,17 @@ responsesDefinitionExampleJSON = [aesonQQ|
 
 securityDefinitionsExample :: SecurityDefinitions
 securityDefinitionsExample = SecurityDefinitions
-  [ ("api_key", SecurityScheme
+  [ ("api_key", Inline (SecurityScheme
       { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
-      , _securitySchemeDescription = Nothing })
-  , ("petstore_auth", SecurityScheme
+      , _securitySchemeDescription = Nothing }))
+  , ("petstore_auth", Inline (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 }) ]
+      , _securitySchemeDescription = Nothing })) ]
 
 securityDefinitionsExampleJSON :: Value
 securityDefinitionsExampleJSON = [aesonQQ|
@@ -492,35 +497,35 @@ securityDefinitionsExampleJSON = [aesonQQ|
 
 oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions
 oAuth2SecurityDefinitionsReadExample = SecurityDefinitions
-  [ ("petstore_auth", SecurityScheme
+  [ ("petstore_auth", Inline (SecurityScheme
       { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow
             { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog"
             , _oAath2RefreshUrl = Nothing
             , _oAuth2Scopes =
               [ ("read:pets", "read your pets") ] } )
-      , _securitySchemeDescription = Nothing })
+      , _securitySchemeDescription = Nothing }))
   ]
 
 oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions
 oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions
-  [ ("petstore_auth", SecurityScheme
+  [ ("petstore_auth", Inline (SecurityScheme
       { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow
             { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog"
             , _oAath2RefreshUrl = Nothing
             , _oAuth2Scopes =
                 [ ("write:pets", "modify pets in your account") ] } )
-      , _securitySchemeDescription = Nothing })
+      , _securitySchemeDescription = Nothing }))
   ]
 
 oAuth2SecurityDefinitionsEmptyExample :: SecurityDefinitions
 oAuth2SecurityDefinitionsEmptyExample = SecurityDefinitions
-  [ ("petstore_auth", SecurityScheme
+  [ ("petstore_auth", Inline (SecurityScheme
       { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow
             { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog"
             , _oAath2RefreshUrl = Nothing
             , _oAuth2Scopes = []
             } )
-      , _securitySchemeDescription = Nothing })
+      , _securitySchemeDescription = Nothing }))
   ]
 
 oAuth2SecurityDefinitionsExample :: SecurityDefinitions
@@ -1003,3 +1008,25 @@ compositionSchemaExampleJSON = [aesonQQ|
   ]
 }
 |]
+
+refSchemaExampleJSON :: Value
+refSchemaExampleJSON = [aesonQQ|
+{
+  "openapi": "3.0.3",
+  "info": {
+    "version": "1.0.0",
+    "title": "Example using references"
+  },
+  "paths": {},
+  "components": {
+    "schemas": {
+      "Foo": {
+        "type": "string"
+      },
+      "Bar": {
+        "$ref": "#/components/schemas/Foo"
+      }
+    }
+  }
+}
+|]