Detect unguarded recursion when inspecting object properties and simi…

…lar things (#128)

* Do check for unguarded recursion in the "silent" branches of schema processing

* Add test

* Make test more throrough

* Fixed tests

Signed-off-by: iko <[email protected]>

Co-authored-by: iko <[email protected]>

compaREST.cabal

@@ -14,7 +14,7 @@ extra-doc-files:     README.md
                      CHANGELOG.md
 tested-with:         GHC == 8.10.4
 extra-source-files: awsm-css/dist/awsm.min.css
-data-files:
+extra-source-files:
   test/golden/**/*.yaml
   test/golden/**/*.md
 

src/Data/OpenApi/Compare/Validate/Schema/Process.hs

@@ -39,15 +39,11 @@ instance Monoid w => MonadWriter w (Silent w) where
   listen (Silent x) = Silent (x, mempty)
   pass (Silent (x, _)) = Silent x
 
-instance MonadState (MemoState ()) (Silent w) where
-  get = Silent $ runIdentity $ runMemo () get
-  put _ = pure ()
-
 type ProcessM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))
 
-type SilentM = ReaderT (Traced (Definitions Schema)) (Silent (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))
+type SilentM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Silent (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))
 
--- Either SilentM or ProcessM
+-- Either ProcessM or SilentM
 type MonadProcess m =
   ( MonadReader (Traced (Definitions Schema)) m
   , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m
@@ -57,11 +53,11 @@ type MonadProcess m =
 warn :: MonadProcess m => Issue 'SchemaLevel -> m ()
 warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue
 
--- | Ignore warnings but allow a recursive loop that lazily computes a recursive 'Condition'.
-silently :: MonadProcess m => SilentM a -> m a
-silently m = do
+-- Perform a computation lazily, ignoring the warnings and discarding memoization/loop detection information.
+lazily :: MonadProcess m => SilentM a -> m a
+lazily m = do
   defs <- R.ask
-  pure . runSilent $ runReaderT m defs
+  pure $ runSilent $ runReaderT (runMemo () m) defs
 
 warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
 warnKnot =
@@ -243,11 +239,11 @@ processSchema sch@(extract -> Schema {..}) = do
   itemsClause <- case tracedItems sch of
     Nothing -> pure top
     Just (Left rs) -> do
-      f <- silently $ processRefSchema rs
+      f <- lazily $ processRefSchema rs
       pure top {forArray = singletonFormula $ Items f rs}
     Just (Right rss) -> do
       fsrs <- forM rss $ \rs -> do
-        f <- silently $ processRefSchema rs
+        f <- lazily $ processRefSchema rs
         pure (f, rs)
       pure top {forArray = singletonFormula $ TupleItems fsrs}
 
@@ -273,12 +269,12 @@ processSchema sch@(extract -> Schema {..}) = do
         _ -> top
 
   (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
-    Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)
+    Just (Right rs) -> (,Just rs) <$> lazily (processRefSchema rs)
     Just (Left False) -> pure (bottom, Nothing)
     _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
   propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
     (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
-      Just rs -> (,rs) <$> silently (processRefSchema rs)
+      Just rs -> (,rs) <$> lazily (processRefSchema rs)
       Nothing ->
         let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
          in -- The mempty here is incorrect, but if addPropSchema was Nothing, then

test/Spec/Golden/TraceTree.hs

@@ -12,7 +12,6 @@ import Data.OpenApi.Compare.Validate.OpenApi ()
 import Data.Text (Text)
 import qualified Data.Text.Encoding as T
 import qualified Data.Yaml as Yaml
-import Paths_compaREST
 import Spec.Golden.Extra
 import Test.Tasty (TestTree, testGroup)
 import Text.Pandoc.Builder
@@ -23,11 +22,10 @@ import Prelude hiding (id, (.))
 
 tests :: IO TestTree
 tests = do
-  dir <- getDataDir
   traceTreeTests <-
     goldenInputsTreeUniform
       "TraceTree"
-      dir
+      "test/golden"
       "trace-tree.yaml"
       ("a.yaml", "b.yaml")
       Yaml.decodeFileThrow
@@ -36,7 +34,7 @@ tests = do
   reportTests <-
     goldenInputsTreeUniform
       "Report"
-      dir
+      "test/golden"
       "report.md"
       ("a.yaml", "b.yaml")
       Yaml.decodeFileThrow

test/golden/common/unguarded-recursive/silent/a.yaml

@@ -0,0 +1,25 @@
+components:
+  schemas:
+    A:
+      type: object
+      properties:
+        bar:
+          $ref: "#/components/schemas/B"
+    B:
+      anyOf:
+        - $ref: "#/components/schemas/B"
+      type: object
+openapi: 3.0.0
+info:
+  version: ""
+  title: ""
+paths:
+  /foo:
+    get:
+      responses:
+        "200":
+          content:
+            application/json;charset=utf-8:
+              schema:
+                $ref: "#/components/schemas/A"
+          description: ""

test/golden/common/unguarded-recursive/silent/b.yaml

@@ -0,0 +1,19 @@
+components:
+  schemas: {}
+openapi: 3.0.0
+info:
+  version: ""
+  title: ""
+paths:
+  /foo:
+    get:
+      responses:
+        "200":
+          content:
+            application/json;charset=utf-8:
+              schema:
+                type: object
+                properties:
+                  bar:
+                    type: object
+          description: ""

test/golden/common/unguarded-recursive/silent/report.md

@@ -0,0 +1,15 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |
+|---------------------|-------------------------|--------------------------------------------------------|
+| 0                   | 0                       | 1                                                      |
+
+# <span id="unsupported-changes"></span>❓ Unsupported feature changes
+
+## **GET** /foo
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$.bar`
+
+Encountered recursion that is too complex for CompaREST to untangle.

test/golden/common/unguarded-recursive/silent/trace-tree.yaml

@@ -0,0 +1,16 @@
+forwardChanges:
+  AtPath "/foo":
+    InOperation GetMethod:
+      WithStatusCode 200:
+        ResponsePayload:
+          PayloadSchema:
+            OfType Object:
+              InProperty "bar": UnguardedRecursion
+backwardChanges:
+  AtPath "/foo":
+    InOperation GetMethod:
+      WithStatusCode 200:
+        ResponsePayload:
+          PayloadSchema:
+            OfType Object:
+              InProperty "bar": UnguardedRecursion