git.iko.soy/compaREST
on master help sign in
Guarded Recursion (#67)
1ee90eemniip
src/OpenAPI/Checker/Memo.hs+3−2
compare with master
unifiedsplit
@@ -110,8 +110,9 @@ memoWithKnot tier f k = memoStateLookup @k @v k <$> get >>= \case
110 <> ", got " <> show (dynTypeRep dyn)
110 <> ", got " <> show (dynTypeRep dyn)
111 Just (Finished _) -> error $ "Unexpected Finished when memoizing "
111 Just (Finished _) -> error $ "Unexpected Finished when memoizing "
112 <> show (typeRep @(k -> v))
112 <> show (typeRep @(k -> v))
113− Nothing -> error $ "No key found when memoizing "
113+ Nothing -> pure v
114− <> show (typeRep @(k -> v))
114+ -- Normally this would be an error, but the underlying monad can refuse
115+ -- to remember memoization state
115 modify $ memoStateInsert @k @v k (Finished v')
116 modify $ memoStateInsert @k @v k (Finished v')
116 pure v'
117 pure v'
117
118
src/OpenAPI/Checker/Validate/Schema.hs+52−13
@@ -20,6 +20,7 @@ import Control.Comonad.Env hiding (env)
20import Control.Lens hiding (cons)
20import Control.Lens hiding (cons)
21import Control.Monad.Reader hiding (ask)
21import Control.Monad.Reader hiding (ask)
22import qualified Control.Monad.Reader as R
22import qualified Control.Monad.Reader as R
23+import Control.Monad.State
23import Control.Monad.Writer
24import Control.Monad.Writer
24import qualified Data.Aeson as A
25import qualified Data.Aeson as A
25import Data.Coerce
26import Data.Coerce
@@ -32,7 +33,7 @@ import Data.Kind
32import qualified Data.List.NonEmpty as NE
33import qualified Data.List.NonEmpty as NE
33import qualified Data.Map as M
34import qualified Data.Map as M
34import Data.Maybe
35import Data.Maybe
35−import Data.OpenApi
36+import Data.OpenApi hiding (get)
36import Data.Ord
37import Data.Ord
37import Data.Ratio
38import Data.Ratio
38import Data.Scientific
39import Data.Scientific
@@ -42,6 +43,7 @@ import qualified Data.Text as T hiding (singleton)
42import Data.Typeable
43import Data.Typeable
43import Text.Regex.Pcre2
44import Text.Regex.Pcre2
44import OpenAPI.Checker.Behavior
45import OpenAPI.Checker.Behavior
46+import OpenAPI.Checker.Memo
45import OpenAPI.Checker.Orphans ()
47import OpenAPI.Checker.Orphans ()
46import OpenAPI.Checker.Paths
48import OpenAPI.Checker.Paths
47import qualified OpenAPI.Checker.PathsPrefixTree as P
49import qualified OpenAPI.Checker.PathsPrefixTree as P
@@ -393,17 +395,51 @@ parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$r
393 A.Success x -> x
395 A.Success x -> x
394 A.Error _ -> Ref $ Reference v
396 A.Error _ -> Ref $ Reference v
395
397
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
397
402
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+
398−warn :: Issue 'SchemaLevel -> ProcessM ()
420+warn :: MonadProcess m => Issue 'SchemaLevel -> m ()
399warn issue = tell $ P.singleton $ AnItem Root $ AnIssue issue
421warn issue = tell $ P.singleton $ AnItem Root $ AnIssue issue
400
422
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+
401processRefSchema
436processRefSchema
437+ :: MonadProcess m
402− :: Traced (Referenced Schema)
438+ => Traced (Referenced Schema)
403− -> ProcessM (ForeachType JsonFormula)
439+ -> m (ForeachType JsonFormula)
404processRefSchema x = do
440processRefSchema x = do
405 defs <- R.ask
441 defs <- R.ask
406− processSchema $ dereference defs x
442+ memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)
407
443
408tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
444tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
409tracedAllOf sch =
445tracedAllOf sch =
@@ -447,8 +483,9 @@ tracedProperties sch =
447-- for every possible type of a JSON value. The conditions are independent, and
483-- for every possible type of a JSON value. The conditions are independent, and
448-- are thus checked independently.
484-- are thus checked independently.
449processSchema
485processSchema
486+ :: MonadProcess m
450− :: Traced Schema
487+ => Traced Schema
451− -> ProcessM (ForeachType JsonFormula)
488+ -> m (ForeachType JsonFormula)
452processSchema sch@(extract -> Schema {..}) = do
489processSchema sch@(extract -> Schema {..}) = do
453 let singletonFormula :: Condition t -> JsonFormula t
490 let singletonFormula :: Condition t -> JsonFormula t
454 singletonFormula f = SingleConjunct [f]
491 singletonFormula f = SingleConjunct [f]
@@ -606,7 +643,7 @@ processSchema sch@(extract -> Schema {..}) = do
606 itemsClause <- case tracedItems sch of
643 itemsClause <- case tracedItems sch of
607 Nothing -> pure top
644 Nothing -> pure top
608 Just (Left rs) -> do
645 Just (Left rs) -> do
609− f <- processRefSchema rs
646+ f <- silently $ processRefSchema rs
610 pure top {forArray = singletonFormula $ Items f rs}
647 pure top {forArray = singletonFormula $ Items f rs}
611 Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
648 Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
612
649
@@ -632,12 +669,12 @@ processSchema sch@(extract -> Schema {..}) = do
632 _ -> top
669 _ -> top
633
670
634 (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
671 (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
635− Just (Right rs) -> (,Just rs) <$> processRefSchema rs
672+ Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)
636 Just (Left False) -> pure (bottom, Nothing)
673 Just (Left False) -> pure (bottom, Nothing)
637 _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
674 _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
638 propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
675 propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
639 (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
676 (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
640− Just rs -> (,rs) <$> processRefSchema rs
677+ Just rs -> (,rs) <$> silently (processRefSchema rs)
641 Nothing ->
678 Nothing ->
642 let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
679 let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
643 in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
680 in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
@@ -713,14 +750,14 @@ processSchema sch@(extract -> Schema {..}) = do
713
750
714{- TODO: ReadOnly/WriteOnly #68 -}
751{- TODO: ReadOnly/WriteOnly #68 -}
715
752
716−checkOneOfDisjoint :: [Traced (Referenced Schema)] -> ProcessM Bool
753+checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool
717checkOneOfDisjoint = const $ pure True -- TODO #69
754checkOneOfDisjoint = const $ pure True -- TODO #69
718
755
719schemaToFormula
756schemaToFormula
720 :: Traced (Definitions Schema)
757 :: Traced (Definitions Schema)
721 -> Traced Schema
758 -> Traced Schema
722 -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
759 -> (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
724
761
725checkFormulas
762checkFormulas
726 :: (HasAll (CheckEnv Schema) xs)
763 :: (HasAll (CheckEnv Schema) xs)
@@ -971,6 +1008,8 @@ instance Issuable 'SchemaLevel where
971 -- ^ Some (openapi-supported) feature that we do not support was encountered in the schema
1008 -- ^ Some (openapi-supported) feature that we do not support was encountered in the schema
972 | InvalidSchema Text
1009 | InvalidSchema Text
973 -- ^ The schema is actually invalid
1010 -- ^ The schema is actually invalid
1011+ | UnguardedRecursion
1012+ -- ^ The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
974 deriving stock (Eq, Ord, Show)
1013 deriving stock (Eq, Ord, Show)
975 issueIsUnsupported _ = True
1014 issueIsUnsupported _ = True
976
1015
test/golden/common/recursive/a.yamlnew file+44
@@ -0,0 +1,44 @@
1+openapi: 3.0.0
2+info:
3+ title: ""
4+ version: ""
5+servers:
6+ - url: /
7+paths:
8+ /api/foo:
9+ get:
10+ responses:
11+ 200:
12+ description: ""
13+ content:
14+ application/json;charset=utf-8:
15+ schema:
16+ $ref: "#/components/schemas/Tree"
17+components:
18+ schemas:
19+ Tree:
20+ type: object
21+ properties:
22+ node:
23+ required:
24+ - children
25+ type: object
26+ properties:
27+ children:
28+ type: array
29+ items:
30+ $ref: "#/components/schemas/Tree"
31+ leaf:
32+ required:
33+ - value
34+ type: object
35+ properties:
36+ value:
37+ $ref: "#/components/schemas/Item"
38+ Item:
39+ required:
40+ - foo
41+ type: object
42+ properties:
43+ foo:
44+ type: string
test/golden/common/recursive/b.yamlnew file+43
@@ -0,0 +1,43 @@
1+openapi: 3.0.0
2+info:
3+ title: ""
4+ version: ""
5+servers:
6+ - url: /
7+paths:
8+ /api/foo:
9+ get:
10+ responses:
11+ 200:
12+ description: ""
13+ content:
14+ application/json;charset=utf-8:
15+ schema:
16+ $ref: "#/components/schemas/Tree"
17+components:
18+ schemas:
19+ Tree:
20+ type: object
21+ properties:
22+ node:
23+ required:
24+ - children
25+ type: object
26+ properties:
27+ children:
28+ type: array
29+ items:
30+ $ref: "#/components/schemas/Tree"
31+ leaf:
32+ required:
33+ - value
34+ type: object
35+ properties:
36+ value:
37+ required:
38+ - foo
39+ type: object
40+ properties:
41+ foo:
42+ enum:
43+ - "a"
test/golden/common/recursive/trace-tree.yamlnew file+1
@@ -0,0 +1 @@
1+Right: []
test/golden/common/unguarded-recursive/a.yamlnew file+21
@@ -0,0 +1,21 @@
1+openapi: 3.0.0
2+info:
3+ title: ""
4+ version: ""
5+servers:
6+ - url: /
7+paths:
8+ /api/foo:
9+ get:
10+ responses:
11+ 200:
12+ description: ""
13+ content:
14+ application/json;charset=utf-8:
15+ schema:
16+ $ref: "#/components/schemas/Bad"
17+components:
18+ schemas:
19+ Bad:
20+ anyOf:
21+ - $ref: "#/components/schemas/Bad"
test/golden/common/unguarded-recursive/b.yamlnew file+21
@@ -0,0 +1,21 @@
1+openapi: 3.0.0
2+info:
3+ title: ""
4+ version: ""
5+servers:
6+ - url: /
7+paths:
8+ /api/foo:
9+ get:
10+ responses:
11+ 200:
12+ description: ""
13+ content:
14+ application/json;charset=utf-8:
15+ schema:
16+ $ref: "#/components/schemas/Bad"
17+components:
18+ schemas:
19+ Bad:
20+ allOf:
21+ - $ref: "#/components/schemas/Bad"
test/golden/common/unguarded-recursive/trace-tree.yamlnew file+6
@@ -0,0 +1,6 @@
1+Left:
2+ AtPath (ProdCons {producer = "/api/foo", consumer = "/api/foo"}):
3+ InOperation GetMethod:
4+ WithStatusCode 200:
5+ ResponsePayload:
6+ PayloadSchema: UnguardedRecursion