@@ -20,6 +20,7 @@ import Control.Comonad.Env hiding (env)
2020import Control.Lens hiding (cons)
2121import Control.Monad.Reader hiding (ask)
2222import qualified Control.Monad.Reader as R
23+import Control.Monad.State
2324import Control.Monad.Writer
2425import qualified Data.Aeson as A
2526import Data.Coerce
@@ -32,7 +33,7 @@ import Data.Kind
3233import qualified Data.List.NonEmpty as NE
3334import qualified Data.Map as M
3435import Data.Maybe
35−import Data.OpenApi
36+import Data.OpenApi hiding (get)
3637import Data.Ord
3738import Data.Ratio
3839import Data.Scientific
@@ -42,6 +43,7 @@ import qualified Data.Text as T hiding (singleton)
4243import Data.Typeable
4344import Text.Regex.Pcre2
4445import OpenAPI.Checker.Behavior
46+import OpenAPI.Checker.Memo
4547import OpenAPI.Checker.Orphans ()
4648import OpenAPI.Checker.Paths
4749import qualified OpenAPI.Checker.PathsPrefixTree as P
@@ -393,17 +395,51 @@ parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$r
393395 A.Success x -> x
394396 A.Error _ -> Ref $ Reference v
395397
396−type ProcessM = ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))
398+-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.
399+newtype Silent q f r a = Silent { runSilent :: a }
400+ deriving stock (Functor)
401+ deriving (Applicative, Monad) via Identity
397402
398−warn :: Issue 'SchemaLevel -> ProcessM ()
403+instance MonadWriter (P.PathsPrefixTree q f r) (Silent q f r) where
404+ tell _ = Silent ()
405+ listen (Silent x) = Silent (x, P.empty)
406+ pass (Silent (x, _)) = Silent x
407+
408+instance MonadState (MemoState ()) (Silent q f r) where
409+ get = Silent $ runIdentity $ runMemo () get
410+ put _ = pure ()
411+
412+type MonadProcess m =
413+ ( MonadReader (Traced (Definitions Schema)) m
414+ , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m
415+ , MonadState (MemoState ()) m
416+ )
417+
418+type SilentM = ReaderT (Traced (Definitions Schema)) (Silent Behave AnIssue 'SchemaLevel)
419+
420+warn :: MonadProcess m => Issue 'SchemaLevel -> m ()
399421warn issue = tell $ P.singleton $ AnItem Root $ AnIssue issue
400422
423+-- | Ignore warnings but allow a recursive loop that lazily computes a recursive 'Condition'.
424+silently :: MonadProcess m => SilentM a -> m a
425+silently m = do
426+ defs <- R.ask
427+ pure . runSilent $ runReaderT m defs
428+
429+warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
430+warnKnot = KnotTier
431+ { onKnotFound = warn UnguardedRecursion
432+ , onKnotUsed = \_ -> pure bottom
433+ , tieKnot = \_ -> pure
434+ }
435+
401436processRefSchema
402− :: Traced (Referenced Schema)
403− -> ProcessM (ForeachType JsonFormula)
437+ :: MonadProcess m
438+ => Traced (Referenced Schema)
439+ -> m (ForeachType JsonFormula)
404440processRefSchema x = do
405441 defs <- R.ask
406− processSchema $ dereference defs x
442+ memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)
407443
408444tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
409445tracedAllOf sch =
@@ -447,8 +483,9 @@ tracedProperties sch =
447483-- for every possible type of a JSON value. The conditions are independent, and
448484-- are thus checked independently.
449485processSchema
450− :: Traced Schema
451− -> ProcessM (ForeachType JsonFormula)
486+ :: MonadProcess m
487+ => Traced Schema
488+ -> m (ForeachType JsonFormula)
452489processSchema sch@(extract -> Schema {..}) = do
453490 let singletonFormula :: Condition t -> JsonFormula t
454491 singletonFormula f = SingleConjunct [f]
@@ -606,7 +643,7 @@ processSchema sch@(extract -> Schema {..}) = do
606643 itemsClause <- case tracedItems sch of
607644 Nothing -> pure top
608645 Just (Left rs) -> do
609− f <- processRefSchema rs
646+ f <- silently $ processRefSchema rs
610647 pure top {forArray = singletonFormula $ Items f rs}
611648 Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
612649
@@ -632,12 +669,12 @@ processSchema sch@(extract -> Schema {..}) = do
632669 _ -> top
633670
634671 (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
635− Just (Right rs) -> (,Just rs) <$> processRefSchema rs
672+ Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)
636673 Just (Left False) -> pure (bottom, Nothing)
637674 _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
638675 propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
639676 (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
640− Just rs -> (,rs) <$> processRefSchema rs
677+ Just rs -> (,rs) <$> silently (processRefSchema rs)
641678 Nothing ->
642679 let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
643680 in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
@@ -713,14 +750,14 @@ processSchema sch@(extract -> Schema {..}) = do
713750
714751{- TODO: ReadOnly/WriteOnly #68 -}
715752
716−checkOneOfDisjoint :: [Traced (Referenced Schema)] -> ProcessM Bool
753+checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool
717754checkOneOfDisjoint = const $ pure True -- TODO #69
718755
719756schemaToFormula
720757 :: Traced (Definitions Schema)
721758 -> Traced Schema
722759 -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
723−schemaToFormula defs rs = runWriter . (`runReaderT` defs) $ processSchema rs
760+schemaToFormula defs rs = runWriter . (`runReaderT` defs) . runMemo () $ processSchema rs
724761
725762checkFormulas
726763 :: (HasAll (CheckEnv Schema) xs)
@@ -971,6 +1008,8 @@ instance Issuable 'SchemaLevel where
9711008 -- ^ Some (openapi-supported) feature that we do not support was encountered in the schema
9721009 | InvalidSchema Text
9731010 -- ^ The schema is actually invalid
1011+ | UnguardedRecursion
1012+ -- ^ The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
9741013 deriving stock (Eq, Ord, Show)
9751014 issueIsUnsupported _ = True
9761015