mirror of
https://github.com/ilyakooo0/compaREST.git
synced 2024-09-11 14:35:25 +03:00
Guarded Recursion (#67)
* Allow guarded recursion * Add a test for guarded recursion * Detect and report "unguarded" recursion * Add test
This commit is contained in:
parent
df1f841721
commit
1ee90ee5a5
@ -110,8 +110,9 @@ memoWithKnot tier f k = memoStateLookup @k @v k <$> get >>= \case
|
||||
<> ", got " <> show (dynTypeRep dyn)
|
||||
Just (Finished _) -> error $ "Unexpected Finished when memoizing "
|
||||
<> show (typeRep @(k -> v))
|
||||
Nothing -> error $ "No key found when memoizing "
|
||||
<> show (typeRep @(k -> v))
|
||||
Nothing -> pure v
|
||||
-- Normally this would be an error, but the underlying monad can refuse
|
||||
-- to remember memoization state
|
||||
modify $ memoStateInsert @k @v k (Finished v')
|
||||
pure v'
|
||||
|
||||
|
@ -20,6 +20,7 @@ import Control.Comonad.Env hiding (env)
|
||||
import Control.Lens hiding (cons)
|
||||
import Control.Monad.Reader hiding (ask)
|
||||
import qualified Control.Monad.Reader as R
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Writer
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Coerce
|
||||
@ -32,7 +33,7 @@ import Data.Kind
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.OpenApi
|
||||
import Data.OpenApi hiding (get)
|
||||
import Data.Ord
|
||||
import Data.Ratio
|
||||
import Data.Scientific
|
||||
@ -42,6 +43,7 @@ import qualified Data.Text as T hiding (singleton)
|
||||
import Data.Typeable
|
||||
import Text.Regex.Pcre2
|
||||
import OpenAPI.Checker.Behavior
|
||||
import OpenAPI.Checker.Memo
|
||||
import OpenAPI.Checker.Orphans ()
|
||||
import OpenAPI.Checker.Paths
|
||||
import qualified OpenAPI.Checker.PathsPrefixTree as P
|
||||
@ -393,17 +395,51 @@ parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$r
|
||||
A.Success x -> x
|
||||
A.Error _ -> Ref $ Reference v
|
||||
|
||||
type ProcessM = ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))
|
||||
-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.
|
||||
newtype Silent q f r a = Silent { runSilent :: a }
|
||||
deriving stock (Functor)
|
||||
deriving (Applicative, Monad) via Identity
|
||||
|
||||
warn :: Issue 'SchemaLevel -> ProcessM ()
|
||||
instance MonadWriter (P.PathsPrefixTree q f r) (Silent q f r) where
|
||||
tell _ = Silent ()
|
||||
listen (Silent x) = Silent (x, P.empty)
|
||||
pass (Silent (x, _)) = Silent x
|
||||
|
||||
instance MonadState (MemoState ()) (Silent q f r) where
|
||||
get = Silent $ runIdentity $ runMemo () get
|
||||
put _ = pure ()
|
||||
|
||||
type MonadProcess m =
|
||||
( MonadReader (Traced (Definitions Schema)) m
|
||||
, MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m
|
||||
, MonadState (MemoState ()) m
|
||||
)
|
||||
|
||||
type SilentM = ReaderT (Traced (Definitions Schema)) (Silent Behave AnIssue 'SchemaLevel)
|
||||
|
||||
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
|
||||
defs <- R.ask
|
||||
pure . runSilent $ runReaderT m defs
|
||||
|
||||
warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
|
||||
warnKnot = KnotTier
|
||||
{ onKnotFound = warn UnguardedRecursion
|
||||
, onKnotUsed = \_ -> pure bottom
|
||||
, tieKnot = \_ -> pure
|
||||
}
|
||||
|
||||
processRefSchema
|
||||
:: Traced (Referenced Schema)
|
||||
-> ProcessM (ForeachType JsonFormula)
|
||||
:: MonadProcess m
|
||||
=> Traced (Referenced Schema)
|
||||
-> m (ForeachType JsonFormula)
|
||||
processRefSchema x = do
|
||||
defs <- R.ask
|
||||
processSchema $ dereference defs x
|
||||
memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)
|
||||
|
||||
tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
|
||||
tracedAllOf sch =
|
||||
@ -447,8 +483,9 @@ tracedProperties sch =
|
||||
-- for every possible type of a JSON value. The conditions are independent, and
|
||||
-- are thus checked independently.
|
||||
processSchema
|
||||
:: Traced Schema
|
||||
-> ProcessM (ForeachType JsonFormula)
|
||||
:: MonadProcess m
|
||||
=> Traced Schema
|
||||
-> m (ForeachType JsonFormula)
|
||||
processSchema sch@(extract -> Schema {..}) = do
|
||||
let singletonFormula :: Condition t -> JsonFormula t
|
||||
singletonFormula f = SingleConjunct [f]
|
||||
@ -606,7 +643,7 @@ processSchema sch@(extract -> Schema {..}) = do
|
||||
itemsClause <- case tracedItems sch of
|
||||
Nothing -> pure top
|
||||
Just (Left rs) -> do
|
||||
f <- processRefSchema rs
|
||||
f <- silently $ processRefSchema rs
|
||||
pure top {forArray = singletonFormula $ Items f rs}
|
||||
Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")
|
||||
|
||||
@ -632,12 +669,12 @@ processSchema sch@(extract -> Schema {..}) = do
|
||||
_ -> top
|
||||
|
||||
(addProps, addPropSchema) <- case tracedAdditionalProperties sch of
|
||||
Just (Right rs) -> (,Just rs) <$> processRefSchema rs
|
||||
Just (Right rs) -> (,Just rs) <$> silently (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) <$> processRefSchema rs
|
||||
Just rs -> (,rs) <$> silently (processRefSchema rs)
|
||||
Nothing ->
|
||||
let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
|
||||
in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
|
||||
@ -713,14 +750,14 @@ processSchema sch@(extract -> Schema {..}) = do
|
||||
|
||||
{- TODO: ReadOnly/WriteOnly #68 -}
|
||||
|
||||
checkOneOfDisjoint :: [Traced (Referenced Schema)] -> ProcessM Bool
|
||||
checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool
|
||||
checkOneOfDisjoint = const $ pure True -- TODO #69
|
||||
|
||||
schemaToFormula
|
||||
:: Traced (Definitions Schema)
|
||||
-> Traced Schema
|
||||
-> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
|
||||
schemaToFormula defs rs = runWriter . (`runReaderT` defs) $ processSchema rs
|
||||
schemaToFormula defs rs = runWriter . (`runReaderT` defs) . runMemo () $ processSchema rs
|
||||
|
||||
checkFormulas
|
||||
:: (HasAll (CheckEnv Schema) xs)
|
||||
@ -971,6 +1008,8 @@ instance Issuable 'SchemaLevel where
|
||||
-- ^ Some (openapi-supported) feature that we do not support was encountered in the schema
|
||||
| InvalidSchema Text
|
||||
-- ^ The schema is actually invalid
|
||||
| UnguardedRecursion
|
||||
-- ^ The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
|
||||
deriving stock (Eq, Ord, Show)
|
||||
issueIsUnsupported _ = True
|
||||
|
||||
|
44
test/golden/common/recursive/a.yaml
Normal file
44
test/golden/common/recursive/a.yaml
Normal file
@ -0,0 +1,44 @@
|
||||
openapi: 3.0.0
|
||||
info:
|
||||
title: ""
|
||||
version: ""
|
||||
servers:
|
||||
- url: /
|
||||
paths:
|
||||
/api/foo:
|
||||
get:
|
||||
responses:
|
||||
200:
|
||||
description: ""
|
||||
content:
|
||||
application/json;charset=utf-8:
|
||||
schema:
|
||||
$ref: "#/components/schemas/Tree"
|
||||
components:
|
||||
schemas:
|
||||
Tree:
|
||||
type: object
|
||||
properties:
|
||||
node:
|
||||
required:
|
||||
- children
|
||||
type: object
|
||||
properties:
|
||||
children:
|
||||
type: array
|
||||
items:
|
||||
$ref: "#/components/schemas/Tree"
|
||||
leaf:
|
||||
required:
|
||||
- value
|
||||
type: object
|
||||
properties:
|
||||
value:
|
||||
$ref: "#/components/schemas/Item"
|
||||
Item:
|
||||
required:
|
||||
- foo
|
||||
type: object
|
||||
properties:
|
||||
foo:
|
||||
type: string
|
43
test/golden/common/recursive/b.yaml
Normal file
43
test/golden/common/recursive/b.yaml
Normal file
@ -0,0 +1,43 @@
|
||||
openapi: 3.0.0
|
||||
info:
|
||||
title: ""
|
||||
version: ""
|
||||
servers:
|
||||
- url: /
|
||||
paths:
|
||||
/api/foo:
|
||||
get:
|
||||
responses:
|
||||
200:
|
||||
description: ""
|
||||
content:
|
||||
application/json;charset=utf-8:
|
||||
schema:
|
||||
$ref: "#/components/schemas/Tree"
|
||||
components:
|
||||
schemas:
|
||||
Tree:
|
||||
type: object
|
||||
properties:
|
||||
node:
|
||||
required:
|
||||
- children
|
||||
type: object
|
||||
properties:
|
||||
children:
|
||||
type: array
|
||||
items:
|
||||
$ref: "#/components/schemas/Tree"
|
||||
leaf:
|
||||
required:
|
||||
- value
|
||||
type: object
|
||||
properties:
|
||||
value:
|
||||
required:
|
||||
- foo
|
||||
type: object
|
||||
properties:
|
||||
foo:
|
||||
enum:
|
||||
- "a"
|
1
test/golden/common/recursive/trace-tree.yaml
Normal file
1
test/golden/common/recursive/trace-tree.yaml
Normal file
@ -0,0 +1 @@
|
||||
Right: []
|
21
test/golden/common/unguarded-recursive/a.yaml
Normal file
21
test/golden/common/unguarded-recursive/a.yaml
Normal file
@ -0,0 +1,21 @@
|
||||
openapi: 3.0.0
|
||||
info:
|
||||
title: ""
|
||||
version: ""
|
||||
servers:
|
||||
- url: /
|
||||
paths:
|
||||
/api/foo:
|
||||
get:
|
||||
responses:
|
||||
200:
|
||||
description: ""
|
||||
content:
|
||||
application/json;charset=utf-8:
|
||||
schema:
|
||||
$ref: "#/components/schemas/Bad"
|
||||
components:
|
||||
schemas:
|
||||
Bad:
|
||||
anyOf:
|
||||
- $ref: "#/components/schemas/Bad"
|
21
test/golden/common/unguarded-recursive/b.yaml
Normal file
21
test/golden/common/unguarded-recursive/b.yaml
Normal file
@ -0,0 +1,21 @@
|
||||
openapi: 3.0.0
|
||||
info:
|
||||
title: ""
|
||||
version: ""
|
||||
servers:
|
||||
- url: /
|
||||
paths:
|
||||
/api/foo:
|
||||
get:
|
||||
responses:
|
||||
200:
|
||||
description: ""
|
||||
content:
|
||||
application/json;charset=utf-8:
|
||||
schema:
|
||||
$ref: "#/components/schemas/Bad"
|
||||
components:
|
||||
schemas:
|
||||
Bad:
|
||||
allOf:
|
||||
- $ref: "#/components/schemas/Bad"
|
6
test/golden/common/unguarded-recursive/trace-tree.yaml
Normal file
6
test/golden/common/unguarded-recursive/trace-tree.yaml
Normal file
@ -0,0 +1,6 @@
|
||||
Left:
|
||||
AtPath (ProdCons {producer = "/api/foo", consumer = "/api/foo"}):
|
||||
InOperation GetMethod:
|
||||
WithStatusCode 200:
|
||||
ResponsePayload:
|
||||
PayloadSchema: UnguardedRecursion
|
Loading…
Reference in New Issue
Block a user