8687e5f · compaREST · git.iko.soy

git.iko.soy/compaREST

Traces (#50)

* Implement internal vs external traces * Fixup tests * Move some errors around * ToBehavior -> SubtreeLevel * minor fixes * Fixed server * integrated anyOfSubtreeAt into anyOfAt Co-authored-by: iko <ilyakooo0@gmail.com>

commit8687e5fbac266f9a426a32cc039a5a215d11bf20 authormniip <mniip@users.noreply.github.com> dateFri 14 May 2021, 12:25 (5 years ago) parent7df8b85

38 files changed+950−812

compare with master

unifiedsplit

openapi-diff.cabal+3−2

@@ -98,15 +98,16 @@ library

9898 import: common-options

9999 hs-source-dirs: src

100100 exposed-modules: Data.HList

101+ , OpenAPI.Checker.Behavior

101102 , OpenAPI.Checker.Formula

102103 , OpenAPI.Checker.Memo

103104 , OpenAPI.Checker.Options

104105 , OpenAPI.Checker.Orphans

106+ , OpenAPI.Checker.Paths

107+ , OpenAPI.Checker.PathsPrefixTree

105108 , OpenAPI.Checker.References

106109 , OpenAPI.Checker.Run

107110 , OpenAPI.Checker.Subtree

108− , OpenAPI.Checker.Trace

109− , OpenAPI.Checker.TracePrefixTree

110111 , OpenAPI.Checker.Validate.MediaTypeObject

111112 , OpenAPI.Checker.Validate.OpenApi

112113 , OpenAPI.Checker.Validate.Operation

src/OpenAPI/Checker/Behavior.hsnew file+53

@@ -0,0 +1,53 @@

1+module OpenAPI.Checker.Behavior

2+ ( BehaviorLevel (..)

3+ , Behavable (..)

4+ , Issuable (..)

5+ , Behavior

6+ , AnIssue (..)

7+ ) where

9+import Data.Aeson

10+import Data.Kind

11+import Data.Text as T

12+import OpenAPI.Checker.Paths

13+

14+-- | Kind

15+data BehaviorLevel

16+ = APILevel

17+ | ServerLevel

18+ | SecurityRequirementLevel

19+ | PathLevel

20+ | OperationLevel

21+ | PathFragmentLevel

22+ | RequestLevel

23+ | ResponseLevel

24+ | HeaderLevel

25+ | -- | either request or response data

26+ PayloadLevel

27+ | SchemaLevel

28+ | TypedSchemaLevel

29+

30+class (Ord (Behave a b), Show (Behave a b))

31+ => Behavable (a :: BehaviorLevel) (b :: BehaviorLevel) where

32+ data Behave a b

33+

34+class (Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where

35+ data Issue l :: Type

36+ describeIssue :: Issue l -> Text

37+ describeIssue = T.pack . show -- TODO: remove this default

38+ issueIsUnsupported :: Issue l -> Bool

39+

40+-- | A set of interactions having common unifying features

41+type Behavior = Paths Behave 'APILevel

42+

43+instance Issuable l => ToJSON (Issue l) where

44+ toJSON = toJSON . describeIssue

45+

46+data AnIssue (l :: BehaviorLevel) where

47+ AnIssue :: Issuable l => Issue l -> AnIssue l

48+

49+deriving stock instance Eq (AnIssue l)

50+deriving stock instance Ord (AnIssue l)

51+

52+instance ToJSON (AnIssue l) where

53+ toJSON (AnIssue issue) = toJSON issue

src/OpenAPI/Checker/Formula.hs+24−24

@@ -12,8 +12,8 @@ module OpenAPI.Checker.Formula

1212import Data.Kind

1313import Data.Monoid

1414import qualified Data.List.NonEmpty as NE

15−import OpenAPI.Checker.Trace

16−import qualified OpenAPI.Checker.TracePrefixTree as T

15+import OpenAPI.Checker.Paths

16+import qualified OpenAPI.Checker.PathsPrefixTree as P

1717

1818type VarRef = Int

1919

@@ -21,30 +21,30 @@ type VarRef = Int

2121-- formulas involving variables, conjunctions, and disjunctions. These

2222-- operations (and the generated algebra) are monotonous. This ensures that

2323-- fixpoints always exist, i.e. that @x = f x@ has at least one solution.

24−data FormulaF (f :: k -> Type) (r :: k) (a :: Type) where

25− Result :: a -> FormulaF f r a

26− Errors :: !(T.TracePrefixTree f r) -> FormulaF f r a

24+data FormulaF (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: Type) where

25+ Result :: a -> FormulaF q f r a

26+ Errors :: !(P.PathsPrefixTree q f r) -> FormulaF q f r a

2727 -- ^ invariant: never empty

28− Apply :: FormulaF f r (b -> c) -> FormulaF f r b -> (c -> a) -> FormulaF f r a

28+ Apply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a

2929 -- ^ invariant: at least one of LHS and RHS is not 'Errors', and they are

3030 -- both not 'Result'

3131 SelectFirst :: NE.NonEmpty (SomeFormulaF b)

32− -> !(AnItem f r) -> (b -> a) -> FormulaF f r a

32+ -> !(AnItem q f r) -> (b -> a) -> FormulaF q f r a

3333 -- ^ invariant: the list doesn't contain any 'Result's, 'Errors' or

3434 -- 'SelectFirst'

35− Variable :: !VarRef -> a -> FormulaF f r a

35+ Variable :: !VarRef -> a -> FormulaF q f r a

3636

37−mkApply :: FormulaF f r (b -> c) -> FormulaF f r b -> (c -> a) -> FormulaF f r a

37+mkApply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a

3838mkApply (Result f) x h = h . f <$> x

3939mkApply f (Result x) h = h . ($ x) <$> f

4040mkApply (Errors e1) (Errors e2) _ = Errors (e1 <> e2)

4141mkApply f x h = Apply f x h

4242

43−mkSelectFirst :: [SomeFormulaF b] -> AnItem f r -> (b -> a) -> FormulaF f r a

43+mkSelectFirst :: [SomeFormulaF b] -> AnItem q f r -> (b -> a) -> FormulaF q f r a

4444mkSelectFirst fs allE h = case foldMap check fs of

4545 (First (Just x), _) -> Result (h x)

4646 (First Nothing, x:xs) -> SelectFirst (x NE.:| xs) allE h

47− (First Nothing, []) -> Errors $ T.singleton allE

47+ (First Nothing, []) -> Errors $ P.singleton allE

4848 where

4949 check (SomeFormulaF (Result x)) = (First (Just x), mempty)

5050 check (SomeFormulaF (Errors _)) = (mempty, mempty)

@@ -53,20 +53,20 @@ mkSelectFirst fs allE h = case foldMap check fs of

5353 check x = (mempty, [x])

5454

5555data SomeFormulaF (a :: Type) where

56− SomeFormulaF :: FormulaF f r a -> SomeFormulaF a

56+ SomeFormulaF :: FormulaF q f r a -> SomeFormulaF a

5757

58−anError :: AnItem f r -> FormulaF f r a

59−anError e = Errors $ T.singleton e

58+anError :: AnItem q f r -> FormulaF q f r a

59+anError e = Errors $ P.singleton e

6060

61−errors :: T.TracePrefixTree f r -> FormulaF f r ()

61+errors :: P.PathsPrefixTree q f r -> FormulaF q f r ()

6262errors t

63− | T.null t = Result ()

63+ | P.null t = Result ()

6464 | otherwise = Errors t

6565

66−variable :: VarRef -> FormulaF f r ()

66+variable :: VarRef -> FormulaF q f r ()

6767variable v = Variable v ()

6868

69−instance Functor (FormulaF f r) where

69+instance Functor (FormulaF q f r) where

7070 fmap f (Result x) = Result (f x)

7171 fmap _ (Errors e) = Errors e

7272 fmap f (Apply g x h) = Apply g x (f . h)

@@ -76,14 +76,14 @@ instance Functor (FormulaF f r) where

7676instance Functor SomeFormulaF where

7777 fmap f (SomeFormulaF x) = SomeFormulaF (fmap f x)

7878

79−instance Applicative (FormulaF f r) where

79+instance Applicative (FormulaF q f r) where

8080 pure = Result

8181 f <*> x = mkApply f x id

8282

83−eitherOf :: [FormulaF f' r' a] -> AnItem f r -> FormulaF f r a

83+eitherOf :: [FormulaF q' f' r' a] -> AnItem q f r -> FormulaF q f r a

8484eitherOf fs allE = mkSelectFirst (map SomeFormulaF fs) allE id

8585

86−calculate :: FormulaF f r a -> Either (T.TracePrefixTree f r) a

86+calculate :: FormulaF q f r a -> Either (P.PathsPrefixTree q f r) a

8787calculate (Result x) = Right x

8888calculate (Errors e) = Left e

8989calculate (Apply f x h) = case calculate f of

@@ -98,15 +98,15 @@ calculate (SelectFirst xs e h) = go (NE.toList xs)

9898 go (SomeFormulaF r:rs) = case calculate r of

9999 Left _ -> go rs

100100 Right x -> Right (h x)

101− go [] = Left $ T.singleton e

101+ go [] = Left $ P.singleton e

102102calculate (Variable i _) = error $ "Unknown variable " <> show i

103103

104104-- Approximate for now. Answers yes/no correctly, but the error lists aren't

105105-- super accurate. TODO: improve

106−maxFixpoint :: VarRef -> FormulaF f r () -> FormulaF f r ()

106+maxFixpoint :: VarRef -> FormulaF q f r () -> FormulaF q f r ()

107107maxFixpoint i = go

108108 where

109− go :: FormulaF f r a -> FormulaF f r a

109+ go :: FormulaF q f r a -> FormulaF q f r a

110110 go (Result x) = Result x

111111 go (Errors e) = Errors e

112112 go (Apply f x h) = mkApply (go f) (go x) h

src/OpenAPI/Checker/Orphans.hs+1−9

@@ -1,21 +1,13 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

3−module OpenAPI.Checker.Orphans (Step (..)) where

3+module OpenAPI.Checker.Orphans () where

55import Control.Comonad.Env

66import Data.OpenApi

7−import Data.Typeable

87import qualified Data.HashMap.Strict.InsOrd as IOHM

9−import OpenAPI.Checker.Trace

108

119deriving newtype instance Ord Reference

1210

13−instance Typeable a => Steppable (Referenced a) a where

14− data Step (Referenced a) a

15− = InlineStep

16− | ReferencedStep Reference

17− deriving (Eq, Ord, Show)

18−

1911deriving stock instance Ord a => Ord (Referenced a)

2012deriving stock instance Ord Schema

2113deriving stock instance Ord AdditionalProperties

src/OpenAPI/Checker/Trace.hs → src/OpenAPI/Checker/Paths.hsrenamed+34−51

@@ -1,25 +1,18 @@

11-- | Utilities for traversing heterogeneous trees. A heterogeneous tree is a

22-- collection of datatypes that "contain" eachother in some form of tree

33-- structure.

4−module OpenAPI.Checker.Trace

5− ( Steppable (..)

6− , Trace (..)

7− , DiffTrace (..)

8− , catDiffTrace

9− , _DiffTrace

4+module OpenAPI.Checker.Paths

5+ ( NiceQuiver

6+ , Paths (..)

7+ , DiffPaths (..)

8+ , catDiffPaths

9+ , _DiffPaths

1010 , AnItem (..)

1111 , step

12− , Traced

13− , Traced'

14− , traced

1512

1613 -- * Reexports

1714 , (>>>)

1815 , (<<<)

19− , extract

20− , ask

21− , asks

22− , local

2316 )

2417where

2518

@@ -31,53 +24,50 @@ import Data.Type.Equality

3124import Type.Reflection

3225import Prelude hiding ((.))

3326

34−class

35− (Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>

36− Steppable (a :: k) (b :: k)

37− where

38− -- | How to get from an @a@ node to a @b@ node

39− data Step (a :: k) (b :: k) :: Type

27+type NiceQuiver q a b = (Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q a b))

4028

41−-- | How to get from an @a@ node to a @b@ node in possibly multiple steps. Like

42−-- a list, but indexed. The list is in reverse because in practice we append

29+-- | All the possible ways to navigate between nodes in a heterogeneous tree

30+-- form a quiver. The hom-sets of the free category constructed from this quiver

31+-- are the sets of various multi-step paths between nodes. This is similar to a

32+-- list, but indexed. The list is in reverse because in practice we append

4333-- items at the end one at a time.

44−data Trace (a :: k) (b :: k) where

45− Root :: Trace a a

46− Snoc :: Steppable b c => Trace a b -> !(Step b c) -> Trace a c

47−

48−deriving stock instance Show (Trace a b)

34+data Paths (q :: k -> k -> Type) (a :: k) (b :: k) where

35+ Root :: Paths q a a

36+ Snoc :: NiceQuiver q b c => Paths q a b -> !(q b c) -> Paths q a c

4937

5038infixl 5 `Snoc`

5139

52−step :: Steppable a b => Step a b -> Trace a b

40+deriving stock instance Show (Paths q a b)

41+

42+step :: NiceQuiver q a b => q a b -> Paths q a b

5343step s = Root `Snoc` s

5444

55−instance Category Trace where

45+instance Category (Paths q) where

5646 id = Root

5747 Root . xs = xs

5848 (Snoc ys y) . xs = Snoc (ys . xs) y

5949

60−typeRepRHS :: Typeable b => Trace a b -> TypeRep b

50+typeRepRHS :: Typeable b => Paths q a b -> TypeRep b

6151typeRepRHS _ = typeRep

6252

63−typeRepLHS :: Typeable b => Trace a b -> TypeRep a

53+typeRepLHS :: Typeable b => Paths q a b -> TypeRep a

6454typeRepLHS Root = typeRep

6555typeRepLHS (Snoc xs _) = typeRepLHS xs

6656

67−instance TestEquality (Trace a) where

57+instance TestEquality (Paths q a) where

6858 testEquality Root Root = Just Refl

6959 testEquality Root (Snoc ys _) = testEquality (typeRepLHS ys) typeRep

7060 testEquality (Snoc xs _) Root = testEquality typeRep (typeRepLHS xs)

7161 testEquality (Snoc _ _) (Snoc _ _) = testEquality typeRep typeRep

7262

73−instance Eq (Trace a b) where

63+instance Eq (Paths q a b) where

7464 Root == Root = True

7565 Snoc xs x == Snoc ys y

7666 | Just Refl <- testEquality (typeRepRHS xs) (typeRepRHS ys) =

7767 xs == ys && x == y

7868 _ == _ = False

7969

80−instance Ord (Trace a b) where

70+instance Ord (Paths q a b) where

8171 compare Root Root = EQ

8272 compare Root (Snoc _ _) = LT

8373 compare (Snoc _ _) Root = GT

@@ -87,29 +77,29 @@ instance Ord (Trace a b) where

8777 Nothing -> compare (someTypeRep xs) (someTypeRep ys)

8878

8979-- | Like a differece list, but indexed.

90−newtype DiffTrace (a :: k) (b :: k)

91− = DiffTrace (forall c. Trace c a -> Trace c b)

80+newtype DiffPaths (q :: k -> k -> Type) (a :: k) (b :: k)

81+ = DiffPaths (forall c. Paths q c a -> Paths q c b)

9282

93−catDiffTrace :: DiffTrace a b -> DiffTrace b c -> DiffTrace a c

94−catDiffTrace (DiffTrace f) (DiffTrace g) = DiffTrace (g . f)

83+catDiffPaths :: DiffPaths q a b -> DiffPaths q b c -> DiffPaths q a c

84+catDiffPaths (DiffPaths f) (DiffPaths g) = DiffPaths (g . f)

9585

96−_DiffTrace :: Iso (DiffTrace a b) (DiffTrace c d) (Trace a b) (Trace c d)

97−_DiffTrace = dimap (\(DiffTrace f) -> f Root) $

98− fmap $ \xs -> DiffTrace (>>> xs)

86+_DiffPaths :: Iso (DiffPaths q a b) (DiffPaths q c d) (Paths q a b) (Paths q c d)

87+_DiffPaths = dimap (\(DiffPaths f) -> f Root) $

88+ fmap $ \xs -> DiffPaths (>>> xs)

9989

10090-- | An item related to some path relative to the root @r@.

101−data AnItem (f :: k -> Type) (r :: k) where

102− AnItem :: Ord (f a) => Trace r a -> !(f a) -> AnItem f r

91+data AnItem (q :: k -> k -> Type) (f :: k -> Type) (r :: k) where

92+ AnItem :: Ord (f a) => Paths q r a -> !(f a) -> AnItem q f r

10393

10494-- the Ord is yuck but we need it and it should be fine in monomorphic cases

10595

106−instance Eq (AnItem f r) where

96+instance Eq (AnItem q f r) where

10797 AnItem xs fx == AnItem ys fy

10898 | Just Refl <- testEquality xs ys =

10999 xs == ys && fx == fy

110100 _ == _ = False

111101

112−instance Typeable r => Ord (AnItem f r) where

102+instance Typeable r => Ord (AnItem q f r) where

113103 compare (AnItem xs fx) (AnItem ys fy) =

114104 case testEquality xs ys of

115105 Just Refl -> compare xs ys <> compare fx fy

@@ -120,10 +110,3 @@ instance Typeable r => Ord (AnItem f r) where

120110 Snoc _ _ -> case ys of

121111 Root -> compare (someTypeRep xs) (someTypeRep ys)

122112 Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)

123−

124−type Traced r a = Traced' r a a

125−

126−type Traced' r a b = Env (Trace r a) b

127−

128−traced :: Trace r a -> b -> Traced' r a b

129−traced = env

src/OpenAPI/Checker/TracePrefixTree.hs → src/OpenAPI/Checker/PathsPrefixTree.hsrenamed+44−38

@@ -1,7 +1,7 @@

11{-# LANGUAGE QuantifiedConstraints #-}

3−module OpenAPI.Checker.TracePrefixTree

4− ( TracePrefixTree

3+module OpenAPI.Checker.PathsPrefixTree

4+ ( PathsPrefixTree

55 , empty

66 , singleton

77 , fromList

@@ -9,6 +9,7 @@ module OpenAPI.Checker.TracePrefixTree

99 , foldWith

1010 , toList

1111 , filter

12+ , embed

1213 )

1314where

1415

@@ -24,22 +25,22 @@ import Data.Type.Equality

2425import qualified Data.TypeRepMap as TRM

2526import qualified Data.Vector as V

2627import qualified GHC.Exts as TRM

27−import OpenAPI.Checker.Trace

28+import OpenAPI.Checker.Paths

2829import Type.Reflection

2930import Prelude hiding (filter, null)

3031

3132-- | A list of @AnItem r f@, but optimized into a prefix tree.

32−data TracePrefixTree (f :: k -> Type) (r :: k) = TracePrefixTree

33+data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPrefixTree

3334 { rootItems :: !(ASet (f r))

34− , snocItems :: !(TRM.TypeRepMap (AStep f r))

35+ , snocItems :: !(TRM.TypeRepMap (AStep q f r))

3536 }

3637

37−instance (forall a. ToJSON (f a)) => ToJSON (TracePrefixTree f r) where

38+instance (forall a. ToJSON (f a)) => ToJSON (PathsPrefixTree q f r) where

3839 toJSON =

3940 Object . getMergableObject

4041 . foldWith (\t x -> MergableObject . traceObject t $ toJSON x)

4142

42−deriving instance Eq (TracePrefixTree f a)

43+deriving instance Eq (PathsPrefixTree q f a)

4344

4445-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where

4546-- the components are ordered by the @SomeTypeRep@ of the @a@.

@@ -69,8 +70,8 @@ compareTRM s1 s2 =

6970 M.fromList

7071 [(someTypeRep x, w) | w@(TRM.WrapTypeable x) <- TRM.toList s]

7172

72−instance Ord (TracePrefixTree f a) where

73− compare (TracePrefixTree r1 s1) (TracePrefixTree r2 s2) =

73+instance Ord (PathsPrefixTree q f a) where

74+ compare (PathsPrefixTree r1 s1) (PathsPrefixTree r2 s2) =

7475 compare r1 r2 <> compareTRM s1 s2

7576

7677data ASet (a :: Type) where

@@ -97,75 +98,80 @@ deriving instance Ord (ASet a)

9798instance Monoid (ASet a) where

9899 mempty = AnEmptySet

99100

100−data AStep (f :: k -> Type) (r :: k) (a :: k) where

101+data AStep (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: k) where

101102 AStep

102− :: Steppable r a =>

103− !(M.Map (Step r a) (TracePrefixTree f a))

104− -> AStep f r a

103+ :: NiceQuiver q r a =>

104+ !(M.Map (q r a) (PathsPrefixTree q f a))

105+ -> AStep q f r a

105106

106−deriving instance Eq (AStep f r a)

107+deriving instance Eq (AStep q f r a)

107108

108−deriving instance Ord (AStep f r a)

109+deriving instance Ord (AStep q f r a)

109110

110−singleton :: AnItem f r -> TracePrefixTree f r

111−singleton (AnItem ys v) = go ys $ TracePrefixTree (ASet $ S.singleton v) TRM.empty

111+singleton :: AnItem q f r -> PathsPrefixTree q f r

112+singleton (AnItem ys v) = go ys $ PathsPrefixTree (ASet $ S.singleton v) TRM.empty

112113 where

113− go :: Trace r a -> TracePrefixTree f a -> TracePrefixTree f r

114+ go :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r

114115 go Root !t = t

115116 go (Snoc xs x) !t =

116117 go xs $

117− TracePrefixTree AnEmptySet $

118+ PathsPrefixTree AnEmptySet $

118119 TRM.one $

119120 AStep $ M.singleton x t

120121

121−instance Semigroup (TracePrefixTree f r) where

122− TracePrefixTree r1 s1 <> TracePrefixTree r2 s2 =

123− TracePrefixTree (r1 <> r2) (TRM.unionWith joinSteps s1 s2)

122+instance Semigroup (PathsPrefixTree q f r) where

123+ PathsPrefixTree r1 s1 <> PathsPrefixTree r2 s2 =

124+ PathsPrefixTree (r1 <> r2) (TRM.unionWith joinSteps s1 s2)

124125 where

125126 joinSteps (AStep m1) (AStep m2) = AStep $ M.unionWith (<>) m1 m2

126127

127−instance Monoid (TracePrefixTree f r) where

128− mempty = TracePrefixTree mempty TRM.empty

128+instance Monoid (PathsPrefixTree q f r) where

129+ mempty = PathsPrefixTree mempty TRM.empty

129130

130−empty :: TracePrefixTree f r

131+empty :: PathsPrefixTree q f r

131132empty = mempty

132133

133−fromList :: [AnItem f r] -> TracePrefixTree f r

134+fromList :: [AnItem q f r] -> PathsPrefixTree q f r

134135fromList = foldMap singleton

135136

136−null :: TracePrefixTree f r -> Bool

137−null (TracePrefixTree AnEmptySet s) = TRM.size s == 0

137+null :: PathsPrefixTree q f r -> Bool

138+null (PathsPrefixTree AnEmptySet s) = TRM.size s == 0

138139null _ = False

139140

140141foldWith

141− :: forall f m r.

142+ :: forall q f m r.

142143 Monoid m

143− => (forall a. Ord (f a) => Trace r a -> f a -> m)

144− -> TracePrefixTree f r

144+ => (forall a. Ord (f a) => Paths q r a -> f a -> m)

145+ -> PathsPrefixTree q f r

145146 -> m

146147foldWith k = goTPT Root

147148 where

148− goTPT :: forall a. Trace r a -> TracePrefixTree f a -> m

149+ goTPT :: forall a. Paths q r a -> PathsPrefixTree q f a -> m

149150 goTPT xs t = goASet xs (rootItems t) <> goTRM xs (snocItems t)

150− goASet :: forall a. Trace r a -> ASet (f a) -> m

151+ goASet :: forall a. Paths q r a -> ASet (f a) -> m

151152 goASet _ AnEmptySet = mempty

152153 goASet xs (ASet rs) = foldMap (k xs) rs

153− goTRM :: forall a. Trace r a -> TRM.TypeRepMap (AStep f a) -> m

154+ goTRM :: forall a. Paths q r a -> TRM.TypeRepMap (AStep q f a) -> m

154155 goTRM xs s = foldMap (\(TRM.WrapTypeable f) -> goAStep xs f) $ TRM.toList s

155− goAStep :: forall a b. Trace r a -> AStep f a b -> m

156+ goAStep :: forall a b. Paths q r a -> AStep q f a b -> m

156157 goAStep xs (AStep m) =

157158 M.foldrWithKey (\x t -> (goTPT (Snoc xs x) t <>)) mempty m

158159

159−toList :: TracePrefixTree f r -> [AnItem f r]

160+toList :: PathsPrefixTree q f r -> [AnItem q f r]

160161toList t = appEndo (foldWith (\xs f -> Endo (AnItem xs f :)) t) []

161162

162163-- | Select a subtree by prefix

163−filter :: Trace r a -> TracePrefixTree f r -> TracePrefixTree f a

164+filter :: Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a

164165filter Root t = t

165166filter (Snoc xs x) t =

166167 foldMap (\(AStep m) -> fold $ M.lookup x m) $

167168 TRM.lookup $ snocItems $ filter xs t

168169

170+-- | Embed a subtree in a larger tree with given prefix

171+embed :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r

172+embed Root t = t

173+embed (Snoc xs x) t = embed xs $ PathsPrefixTree AnEmptySet $ TRM.one $ AStep $ M.singleton x t

174+

169175newtype MergableObject = MergableObject {getMergableObject :: Object}

170176

171177instance Semigroup MergableObject where

@@ -183,7 +189,7 @@ instance Semigroup MergableObject where

183189instance Monoid MergableObject where

184190 mempty = MergableObject mempty

185191

186−traceObject :: Trace r a -> Value -> Object

192+traceObject :: Paths q r a -> Value -> Object

187193traceObject Root (Object o) = o

188194traceObject Root v = HM.singleton "root" v

189195traceObject (root `Snoc` s) v =

src/OpenAPI/Checker/References.hs+15−9

@@ -1,26 +1,32 @@

1+{-# OPTIONS_GHC -Wno-orphans #-}

12module OpenAPI.Checker.References

2− ( TracedReferences

3+ ( Step (..)

34 , dereference

45 )

56where

78import qualified Data.HashMap.Strict.InsOrd as IOHM

8−import Data.Map (Map)

99import Data.Maybe

1010import Data.OpenApi

1111import Data.Typeable

12−import OpenAPI.Checker.Orphans

13−import OpenAPI.Checker.Trace

12+import OpenAPI.Checker.Orphans ()

13+import OpenAPI.Checker.Subtree

1414

15−type TracedReferences root a = Map Reference (Traced root a)

15+instance Typeable a => Steppable (Referenced a) a where

16+ data Step (Referenced a) a = InlineStep

17+ deriving stock (Eq, Ord, Show)

18+

19+instance Typeable a => Steppable (Definitions a) a where

20+ data Step (Definitions a) a = ReferencedStep Reference

21+ deriving stock (Eq, Ord, Show)

1622

1723dereference

1824 :: Typeable a

19− => Definitions a

20− -> Traced r (Referenced a)

21− -> Traced r a

25+ => Traced (Definitions a)

26+ -> Traced (Referenced a)

27+ -> Traced a

2228dereference defs x = case extract x of

2329 Inline a

2430 -> traced (ask x >>> step InlineStep) a

2531 Ref r@(Reference ref)

26− -> traced (ask x >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref defs)

32+ -> traced (ask defs >>> step (ReferencedStep r)) (fromJust $ IOHM.lookup ref $ extract defs)

src/OpenAPI/Checker/Run.hs+2−2

@@ -6,7 +6,7 @@ import Data.HList

66import qualified Data.Yaml as Yaml

77import OpenAPI.Checker.Options

88import OpenAPI.Checker.Subtree

9−import OpenAPI.Checker.Trace

9+import OpenAPI.Checker.Paths

1010import OpenAPI.Checker.Validate.OpenApi ()

1111import Prelude hiding (id, (.))

1212

@@ -26,5 +26,5 @@ runChecker = do

2626 Right s -> pure s

2727 a <- traced Root <$> parseSchema (clientFile opts)

2828 b <- traced Root <$> parseSchema (serverFile opts)

29− let report = runCompatFormula $ checkCompatibility HNil (ProdCons a b)

29+ let report = runCompatFormula $ checkCompatibility HNil Root (ProdCons a b)

3030 BSC.putStrLn $ Yaml.encode report

src/OpenAPI/Checker/Subtree.hs+65−97

@@ -1,45 +1,67 @@

11module OpenAPI.Checker.Subtree

2− ( APIStep (..)

2+ ( Steppable (..)

3+ , Trace

4+ , Traced

5+ , Traced'

6+ , pattern Traced

7+ , traced

38 , Subtree (..)

49 , CompatM (..)

510 , CompatFormula'

611 , CompatFormula

712 , ProdCons (..)

8− , anyOfSubtreeAt

913 , HasUnsupportedFeature (..)

1014 , swapProdCons

11− , SubtreeCheckIssue (..)

1215 , runCompatFormula

13− , anyOfM

14− , anyOfAt

15− , issueAtTrace

1616 , issueAt

17− , tracedIssue

17+ , anyOfAt

1818 , memo

19+

20+ -- * Reexports

21+ , (>>>)

22+ , (<<<)

23+ , extract

24+ , ask

25+ , local

26+ , step

1927 )

2028where

2129

2230import Control.Comonad.Env

2331import Control.Monad.Identity

2432import Control.Monad.State

25−import Data.Aeson

2633import Data.Functor.Compose

2734import Data.HList

2835import Data.Kind

2936import Data.Monoid

3037import Data.OpenApi

31−import Data.Text

3238import Data.Typeable

39+import OpenAPI.Checker.Behavior

3340import OpenAPI.Checker.Formula

3441import OpenAPI.Checker.Memo

35−import OpenAPI.Checker.Trace

36−import qualified OpenAPI.Checker.TracePrefixTree as T

42+import OpenAPI.Checker.Paths

43+import qualified OpenAPI.Checker.PathsPrefixTree as P

3744

3845class

39− (Subtree a, Subtree b, Steppable a b) =>

40− APIStep (a :: Type) (b :: Type)

46+ (Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>

47+ Steppable (a :: Type) (b :: Type)

4148 where

42− describeStep :: Step a b -> Text

49+ -- | How to get from an @a@ node to a @b@ node

50+ data Step a b :: Type

51+

52+type Trace = Paths Step OpenApi

53+

54+type Traced' a b = Env (Trace a) b

55+

56+type Traced a = Traced' a a

57+

58+pattern Traced :: Trace a -> b -> Traced' a b

59+pattern Traced t x = EnvT t (Identity x)

60+

61+{-# COMPLETE Traced #-}

62+

63+traced :: Trace a -> a -> Traced a

64+traced = env

4365

4466data ProdCons a = ProdCons

4567 { producer :: a

@@ -56,7 +78,7 @@ instance Applicative ProdCons where

5678

5779newtype CompatM a = CompatM

5880 { unCompatM

59− :: (StateT (MemoState VarRef) Identity) a

81+ :: StateT (MemoState VarRef) Identity a

6082 }

6183 deriving newtype

6284 ( Functor

@@ -65,29 +87,21 @@ newtype CompatM a = CompatM

6587 , MonadState (MemoState VarRef)

6688 )

6789

68−type CompatFormula' f r = Compose CompatM (FormulaF f r)

90+type CompatFormula' q f r = Compose CompatM (FormulaF q f r)

6991

70−type CompatFormula = CompatFormula' SubtreeCheckIssue OpenApi

92+type CompatFormula = CompatFormula' Behave AnIssue 'APILevel

7193

72−class (Typeable t, Ord (CheckIssue t), Show (CheckIssue t)) => Subtree (t :: Type) where

94+class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where

7395 type CheckEnv t :: [Type]

74− data CheckIssue t :: Type

75−

76− issueIsUnsupported :: CheckIssue t -> Bool

77− issueIsUnsupported = const False

78−

79− -- | If we ever followed a reference, reroute the path through "components"

80− normalizeTrace :: Trace OpenApi t -> Trace OpenApi t

81− normalizeTrace = id

96+ type SubtreeLevel t :: BehaviorLevel

8297

8398 checkCompatibility

8499 :: HasAll (CheckEnv t) xs

85100 => HList xs

86− -> ProdCons (Traced OpenApi t)

101+ -> Behavior (SubtreeLevel t)

102+ -> ProdCons (Traced t)

87103 -> CompatFormula ()

88104

89−{-# WARNING normalizeTrace "It must be refactored. Does nothing for now" #-}

90−

91105class HasUnsupportedFeature x where

92106 hasUnsupportedFeature :: x -> Bool

93107

@@ -101,87 +115,41 @@ instance

101115 hasUnsupportedFeature (Left x) = hasUnsupportedFeature x

102116 hasUnsupportedFeature (Right x) = hasUnsupportedFeature x

103117

104−instance Subtree t => HasUnsupportedFeature (CheckIssue t) where

118+instance Issuable l => HasUnsupportedFeature (Issue l) where

105119 hasUnsupportedFeature = issueIsUnsupported

106120

121+instance HasUnsupportedFeature (AnIssue l) where

122+ hasUnsupportedFeature (AnIssue issue) = hasUnsupportedFeature issue

123+

107124instance

108125 (forall x. HasUnsupportedFeature (f x))

109− => HasUnsupportedFeature (T.TracePrefixTree f r)

126+ => HasUnsupportedFeature (P.PathsPrefixTree q f r)

110127 where

111128 hasUnsupportedFeature =

112− getAny . T.foldWith (\_ fa -> Any $ hasUnsupportedFeature fa)

113−

114−data SubtreeCheckIssue t where

115− SubtreeCheckIssue :: Subtree t => CheckIssue t -> SubtreeCheckIssue t

116−

117−deriving stock instance Eq (SubtreeCheckIssue t)

118−

119−deriving stock instance Ord (SubtreeCheckIssue t)

120−

121−instance Subtree t => ToJSON (CheckIssue t) where

122− toJSON = toJSON . show

123−

124−instance HasUnsupportedFeature (SubtreeCheckIssue t) where

125− hasUnsupportedFeature (SubtreeCheckIssue i) = hasUnsupportedFeature i

126−

127−instance ToJSON (SubtreeCheckIssue t) where

128− toJSON (SubtreeCheckIssue i) = toJSON i

129+ getAny . P.foldWith (\_ fa -> Any $ hasUnsupportedFeature fa)

129130

130131runCompatFormula

131− :: CompatFormula' f r a

132− -> Either (T.TracePrefixTree f r) a

132+ :: CompatFormula' q f r a

133+ -> Either (P.PathsPrefixTree q f r) a

133134runCompatFormula (Compose f) =

134135 calculate . runIdentity . runMemo 0 . unCompatM $ f

135136

136−issueAtTrace

137− :: Subtree t

138− => Trace r t

139− -> CheckIssue t

140− -> CompatFormula' SubtreeCheckIssue r a

141−issueAtTrace xs issue = Compose $ pure $ anError $ AnItem xs $ SubtreeCheckIssue issue

142−

143−issueAt

144− :: (Subtree t, ComonadEnv (Trace r t) w)

145− => w x

146− -> CheckIssue t

147− -> CompatFormula' SubtreeCheckIssue r a

148−issueAt x = issueAtTrace (ask x)

149−

150−tracedIssue

151− :: (Subtree t, ComonadEnv (Trace r t) w)

152− => w (CheckIssue t)

153− -> CompatFormula' SubtreeCheckIssue r a

154−tracedIssue x = issueAtTrace (ask x) (extract x)

155−

156−anyOfM

157− :: Subtree t

158− => Trace r t

159− -> CheckIssue t

160− -> [CompatFormula' SubtreeCheckIssue r a]

161− -> CompatFormula' SubtreeCheckIssue r a

162−anyOfM xs issue fs =

163− Compose $ (`eitherOf` AnItem xs (SubtreeCheckIssue issue)) <$> sequenceA (getCompose <$> fs)

137+issueAt :: Issuable l => Paths q r l -> Issue l -> CompatFormula' q AnIssue r a

138+issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ AnIssue issue

164139

165140anyOfAt

166− :: (Subtree t, ComonadEnv (Trace r t) w)

167− => w x

168− -> CheckIssue t

169− -> [CompatFormula' SubtreeCheckIssue r a]

170− -> CompatFormula' SubtreeCheckIssue r a

171−anyOfAt x = anyOfM (ask x)

172−

173−anyOfSubtreeAt

174− :: (Subtree t, ComonadEnv (Trace r t) w)

175− => w x

176− -> CheckIssue t

177− -> [CompatFormula' SubtreeCheckIssue r a]

178− -> CompatFormula' SubtreeCheckIssue r a

179−anyOfSubtreeAt _ _ [x] = x

180−anyOfSubtreeAt f i fs = anyOfAt f i fs

141+ :: Issuable l

142+ => Paths q r l

143+ -> Issue l

144+ -> [CompatFormula' q AnIssue r a]

145+ -> CompatFormula' q AnIssue r a

146+anyOfAt _ _ [x] = x

147+anyOfAt xs issue fs =

148+ Compose $ (`eitherOf` AnItem xs (AnIssue issue)) <$> sequenceA (getCompose <$> fs)

181149

182150fixpointKnot

183151 :: MonadState (MemoState VarRef) m

184− => KnotTier (FormulaF f r ()) VarRef m

152+ => KnotTier (FormulaF q f r ()) VarRef m

185153fixpointKnot =

186154 KnotTier

187155 { onKnotFound = modifyMemoNonce succ

@@ -190,8 +158,8 @@ fixpointKnot =

190158 }

191159

192160memo

193− :: (Typeable r, Subtree t)

194− => (ProdCons (Traced r t) -> CompatFormula ())

195− -> (ProdCons (Traced r t) -> CompatFormula ())

161+ :: (Typeable q, Typeable f, NiceQuiver p r t)

162+ => (ProdCons (Env (Paths p r t) t) -> CompatFormula' q f r ())

163+ -> (ProdCons (Env (Paths p r t) t) -> CompatFormula' q f r ())

196164memo f pc = Compose $ do

197165 memoWithKnot fixpointKnot (getCompose $ f pc) (ask <$> pc)

src/OpenAPI/Checker/Validate/MediaTypeObject.hs+51−23

@@ -1,7 +1,8 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

33module OpenAPI.Checker.Validate.MediaTypeObject

4− ( CheckIssue(..)

4+ ( Issue(..)

5+ , Behave(..)

56 ) where

78import Control.Lens

@@ -12,30 +13,42 @@ import Data.Map.Strict as M

1213import Data.OpenApi

1314import Data.Text (Text)

1415import Network.HTTP.Media (MediaType, mainType, subType)

16+import OpenAPI.Checker.Behavior

1517import OpenAPI.Checker.Subtree

16−import OpenAPI.Checker.Trace

1718import OpenAPI.Checker.Validate.Products

1819import OpenAPI.Checker.Validate.Schema ()

1920

20−tracedSchema :: Traced r MediaTypeObject -> Maybe (Traced r (Referenced Schema))

21+tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))

2122tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)

2223

23−tracedEncoding :: Traced r MediaTypeObject -> InsOrdHashMap Text (Traced r Encoding)

24+tracedEncoding :: Traced MediaTypeObject -> InsOrdHashMap Text (Traced Encoding)

2425tracedEncoding mto = IOHM.mapWithKey (\k -> traced (ask mto >>> step (MediaTypeParamEncoding k)))

2526 $ _mediaTypeObjectEncoding $ extract mto

2627

28+instance Issuable 'PayloadLevel where

29+ data Issue 'PayloadLevel

30+ = PayloadMediaTypeNotFound

31+ | MediaEncodingIncompat

32+ | MediaTypeSchemaRequired

33+ | MediaEncodingMissing Text

34+ | EncodingNotSupported

35+ deriving (Eq, Ord, Show)

36+ issueIsUnsupported = \case

37+ EncodingNotSupported -> True

38+ _ -> False

39+

40+instance Behavable 'PayloadLevel 'SchemaLevel where

41+ data Behave 'PayloadLevel 'SchemaLevel

42+ = PayloadSchema

43+ deriving (Eq, Ord, Show)

44+

2745instance Subtree MediaTypeObject where

46+ type SubtreeLevel MediaTypeObject = 'PayloadLevel

2847 type CheckEnv MediaTypeObject =

2948 '[ MediaType

30− , ProdCons (Definitions Schema)

49+ , ProdCons (Traced (Definitions Schema))

3150 ]

32− data CheckIssue MediaTypeObject

33− = RequestMediaTypeNotFound

34− | ResponseMediaTypeMissing

35− | MediaEncodingIncompat

36− | MediaTypeSchemaRequired

37− deriving (Eq, Ord, Show)

38− checkCompatibility env prodCons@(ProdCons p c) = do

51+ checkCompatibility env beh prodCons@(ProdCons p c) = do

3952 if | "multipart" == mainType mediaType -> checkEncoding

4053 | "application" == mainType mediaType &&

4154 "x-www-form-urlencoded" == subType mediaType -> checkEncoding

@@ -44,8 +57,9 @@ instance Subtree MediaTypeObject where

4457 -- request

4558 for_ (tracedSchema c) $ \consRef ->

4659 case tracedSchema p of

47− Nothing -> issueAt p MediaTypeSchemaRequired

48− Just prodRef -> checkCompatibility env $ ProdCons prodRef consRef

60+ Nothing -> issueAt beh MediaTypeSchemaRequired

61+ Just prodRef -> checkCompatibility env (beh >>> step PayloadSchema)

62+ $ ProdCons prodRef consRef

4963 pure ()

5064 where

5165 mediaType = getH @MediaType env

@@ -56,22 +70,19 @@ instance Subtree MediaTypeObject where

5670 $ (IOHM.toList $ tracedEncoding mt) <&> \(k, enc) ->

5771 ( k

5872 , ProductLike

59− { tracedValue = enc

73+ { productValue = enc

6074 , required = True } )

6175 encProdCons = getEncoding <$> prodCons

62− in checkProducts (const MediaEncodingMissing)

63− (const $ checkCompatibility HNil) encProdCons

76+ in checkProducts beh MediaEncodingMissing

77+ (const $ checkCompatibility HNil beh) encProdCons

6478

6579instance Subtree Encoding where

80+ type SubtreeLevel Encoding = 'PayloadLevel

6681 type CheckEnv Encoding = '[]

67− data CheckIssue Encoding

68− = MediaEncodingMissing

69− | EncodingNotSupported

7082 -- FIXME: Support only JSON body for now. Then Encoding is checked only for

7183 -- multipart/form-url-encoded

72− deriving (Eq, Ord, Show)

73− checkCompatibility _env pc =

74− issueAt (producer pc) EncodingNotSupported

84+ checkCompatibility _env beh _pc =

85+ issueAt beh EncodingNotSupported

7586

7687instance Steppable MediaTypeObject (Referenced Schema) where

7788 data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema

@@ -80,3 +91,20 @@ instance Steppable MediaTypeObject (Referenced Schema) where

8091instance Steppable MediaTypeObject Encoding where

8192 data Step MediaTypeObject Encoding = MediaTypeParamEncoding Text

8293 deriving (Eq, Ord, Show)

94+

95+instance Behavable 'OperationLevel 'ResponseLevel where

96+ data Behave 'OperationLevel 'ResponseLevel

97+ = WithStatusCode HttpStatusCode

98+ deriving stock (Eq, Ord, Show)

99+

100+instance Issuable 'OperationLevel where

101+ data Issue 'OperationLevel

102+ = ResponseCodeNotFound HttpStatusCode

103+ | CallbacksNotSupported

104+ | ParamNotMatched Text

105+ | PathFragmentNotMatched Int

106+ | NoRequestBody

107+ deriving stock (Eq, Ord, Show)

108+ issueIsUnsupported = \case

109+ CallbacksNotSupported -> True

110+ _ -> False

src/OpenAPI/Checker/Validate/OpenApi.hs+60−13

@@ -10,31 +10,78 @@ where

1010import Data.HList

1111import qualified Data.HashMap.Strict.InsOrd as IOHM

1212import Data.OpenApi

13+import OpenAPI.Checker.Behavior

14+import OpenAPI.Checker.Paths

1315import OpenAPI.Checker.Subtree

14−import OpenAPI.Checker.Trace

1516import OpenAPI.Checker.Validate.ProcessedPathItem

1617

17−tracedPaths :: Traced r OpenApi -> Traced r ProcessedPathItems

18+tracedPaths :: Traced OpenApi -> Traced ProcessedPathItems

1819tracedPaths oa = traced (ask oa >>> step OpenApiPathsStep)

1920 (processPathItems . IOHM.toList . _openApiPaths . extract $ oa)

2021

22+tracedRequestBodies :: Traced OpenApi -> Traced (Definitions RequestBody)

23+tracedRequestBodies oa = traced (ask oa >>> step ComponentsRequestBody)

24+ (_componentsRequestBodies . _openApiComponents . extract $ oa)

25+

26+tracedParameters :: Traced OpenApi -> Traced (Definitions Param)

27+tracedParameters oa = traced (ask oa >>> step ComponentsParam)

28+ (_componentsParameters . _openApiComponents . extract $ oa)

29+

30+tracedSecuritySchemes :: Traced OpenApi -> Traced (Definitions SecurityScheme)

31+tracedSecuritySchemes oa = traced (ask oa >>> step ComponentsSecurityScheme)

32+ (_componentsSecuritySchemes . _openApiComponents . extract $ oa)

33+

34+tracedResponses :: Traced OpenApi -> Traced (Definitions Response)

35+tracedResponses oa = traced (ask oa >>> step ComponentsResponse)

36+ (_componentsResponses . _openApiComponents . extract $ oa)

37+

38+tracedHeaders :: Traced OpenApi -> Traced (Definitions Header)

39+tracedHeaders oa = traced (ask oa >>> step ComponentsHeader)

40+ (_componentsHeaders . _openApiComponents . extract $ oa)

41+

42+tracedSchemas :: Traced OpenApi -> Traced (Definitions Schema)

43+tracedSchemas oa = traced (ask oa >>> step ComponentsSchema)

44+ (_componentsSchemas . _openApiComponents . extract $ oa)

45+

2146instance Subtree OpenApi where

47+ type SubtreeLevel OpenApi = 'APILevel

2248 type CheckEnv OpenApi = '[]

23− data CheckIssue OpenApi

24− deriving (Eq, Ord, Show)

25− checkCompatibility _ prodCons = do

26− let cs = _openApiComponents . extract <$> prodCons

49+ checkCompatibility _ beh prodCons = do

2750 checkCompatibility @ProcessedPathItems

28− ((_componentsRequestBodies <$> cs)

29− `HCons` (_componentsParameters <$> cs)

30− `HCons` (_componentsSecuritySchemes <$> cs)

31− `HCons` (_componentsResponses <$> cs)

32− `HCons` (_componentsHeaders <$> cs)

33− `HCons` (_componentsSchemas <$> cs)

51+ ((tracedRequestBodies <$> prodCons)

52+ `HCons` (tracedParameters <$> prodCons)

53+ `HCons` (tracedSecuritySchemes <$> prodCons)

54+ `HCons` (tracedResponses <$> prodCons)

55+ `HCons` (tracedHeaders <$> prodCons)

56+ `HCons` (tracedSchemas <$> prodCons)

3457 `HCons` (_openApiServers . extract <$> prodCons)

3558 `HCons` HNil)

36− (tracedPaths <$> prodCons)

59+ beh (tracedPaths <$> prodCons)

3760

3861instance Steppable OpenApi ProcessedPathItems where

3962 data Step OpenApi ProcessedPathItems = OpenApiPathsStep

4063 deriving (Eq, Ord, Show)

64+

65+instance Steppable OpenApi (Definitions RequestBody) where

66+ data Step OpenApi (Definitions RequestBody) = ComponentsRequestBody

67+ deriving (Eq, Ord, Show)

68+

69+instance Steppable OpenApi (Definitions Param) where

70+ data Step OpenApi (Definitions Param) = ComponentsParam

71+ deriving (Eq, Ord, Show)

72+

73+instance Steppable OpenApi (Definitions SecurityScheme) where

74+ data Step OpenApi (Definitions SecurityScheme) = ComponentsSecurityScheme

75+ deriving (Eq, Ord, Show)

76+

77+instance Steppable OpenApi (Definitions Response) where

78+ data Step OpenApi (Definitions Response) = ComponentsResponse

79+ deriving (Eq, Ord, Show)

80+

81+instance Steppable OpenApi (Definitions Header) where

82+ data Step OpenApi (Definitions Header) = ComponentsHeader

83+ deriving (Eq, Ord, Show)

84+

85+instance Steppable OpenApi (Definitions Schema) where

86+ data Step OpenApi (Definitions Schema) = ComponentsSchema

87+ deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Operation.hs+62−56

@@ -3,7 +3,6 @@

44module OpenAPI.Checker.Validate.Operation

55 ( MatchedOperation (..)

6− , CheckIssue (..)

76 , OperationMethod(..)

87 , pathItemMethod

98 ) where

@@ -17,21 +16,21 @@ import Data.Map.Strict as M

1716import Data.Maybe

1817import Data.OpenApi

1918import Data.Text (Text)

19+import OpenAPI.Checker.Behavior

2020import OpenAPI.Checker.References

2121import OpenAPI.Checker.Subtree

22−import OpenAPI.Checker.Trace

23−import OpenAPI.Checker.Validate.Param

22+import OpenAPI.Checker.Validate.MediaTypeObject

2423import OpenAPI.Checker.Validate.PathFragment

2524import OpenAPI.Checker.Validate.Products

26−import OpenAPI.Checker.Validate.RequestBody

25+import OpenAPI.Checker.Validate.RequestBody ()

2726import OpenAPI.Checker.Validate.Responses ()

2827import OpenAPI.Checker.Validate.Server ()

2928

3029data MatchedOperation = MatchedOperation

3130 { operation :: !Operation

32− , pathParams :: ![Traced OpenApi Param]

31+ , pathParams :: ![Traced Param]

3332 -- ^ Params from the PathItem

34− , getPathFragments :: !([Traced OpenApi Param] -> [Traced OpenApi PathFragmentParam])

33+ , getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])

3534 -- ^ Path fragments traced from PathItem. Takes full list of

3635 -- operation-specific parameters

3736 }

@@ -41,20 +40,20 @@ type ParamKey = (ParamLocation, Text)

4140paramKey :: Param -> ParamKey

4241paramKey param = (_paramIn param, _paramName param)

4342

44−tracedParameters :: Traced r MatchedOperation -> [Traced r (Referenced Param)]

43+tracedParameters :: Traced MatchedOperation -> [Traced (Referenced Param)]

4544tracedParameters oper =

4645 [ traced (ask oper >>> step (OperationParamsStep i)) x

4746 | (i, x) <- zip [0..] $ _operationParameters . operation $ extract oper

4847 ]

4948

50−tracedRequestBody :: Traced r MatchedOperation -> Maybe (Traced r (Referenced RequestBody))

49+tracedRequestBody :: Traced MatchedOperation -> Maybe (Traced (Referenced RequestBody))

5150tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)

5251

53−tracedResponses :: Traced r MatchedOperation -> Traced r Responses

52+tracedResponses :: Traced MatchedOperation -> Traced Responses

5453tracedResponses oper = traced (ask oper >>> step OperationResponsesStep)

5554 $ _operationResponses . operation $ extract oper

5655

57−tracedSecurity :: Traced r MatchedOperation -> [Traced r SecurityRequirement]

56+tracedSecurity :: Traced MatchedOperation -> [Traced SecurityRequirement]

5857tracedSecurity oper =

5958 [ traced (ask oper >>> step (OperationSecurityRequirementStep i)) x

6059 | (i, x) <- zip [0..] $ _operationSecurity . operation $ extract oper

@@ -63,29 +62,37 @@ tracedSecurity oper =

6362-- FIXME: https://github.com/typeable/openapi-diff/issues/28

6463tracedServers

6564 :: [Server] -- ^ Servers from env

66− -> Traced r MatchedOperation

67− -> Traced r [Server]

65+ -> Traced MatchedOperation

66+ -> Traced [Server]

6867tracedServers env oper =

6968 traced (ask oper >>> step OperationServersStep) $

7069 case _operationServers . operation $ extract oper of

7170 [] -> env

7271 ss -> ss

7372

73+instance Behavable 'OperationLevel 'PathFragmentLevel where

74+ data Behave 'OperationLevel 'PathFragmentLevel

75+ = InParam Text

76+ | InFragment Int

77+ deriving stock (Eq, Ord, Show)

78+

79+instance Behavable 'OperationLevel 'RequestLevel where

80+ data Behave 'OperationLevel 'RequestLevel

81+ = InRequest

82+ deriving stock (Eq, Ord, Show)

83+

7484instance Subtree MatchedOperation where

85+ type SubtreeLevel MatchedOperation = 'OperationLevel

7586 type CheckEnv MatchedOperation =

76− '[ ProdCons (Definitions Param)

77− , ProdCons (Definitions RequestBody)

78− , ProdCons (Definitions SecurityScheme)

79− , ProdCons (Definitions Response)

80− , ProdCons (Definitions Header)

81− , ProdCons (Definitions Schema)

87+ '[ ProdCons (Traced (Definitions Param))

88+ , ProdCons (Traced (Definitions RequestBody))

89+ , ProdCons (Traced (Definitions SecurityScheme))

90+ , ProdCons (Traced (Definitions Response))

91+ , ProdCons (Traced (Definitions Header))

92+ , ProdCons (Traced (Definitions Schema))

8293 , ProdCons [Server]

8394 ]

84− data CheckIssue MatchedOperation

85− = OperationMissing OperationMethod

86− | CallbacksNotSupported

87− deriving (Eq, Ord, Show)

88− checkCompatibility env prodCons = do

95+ checkCompatibility env beh prodCons = do

8996 checkParameters

9097 checkRequestBodies

9198 checkResponses

@@ -98,30 +105,29 @@ instance Subtree MatchedOperation where

98105 let

99106 -- Merged parameters got from Operation and PathItem in one

100107 -- place. First element is path params, second is non-path params

101− tracedParams :: ProdCons ([Traced OpenApi Param], [Traced OpenApi Param])

108+ tracedParams :: ProdCons ([Traced Param], [Traced Param])

102109 tracedParams = getParams <$> paramDefs <*> prodCons

103110 getParams defs mp =

104111 let

105− operationParamsMap :: Map ParamKey (Traced OpenApi Param)

112+ operationParamsMap :: Map ParamKey (Traced Param)

106113 operationParamsMap = M.fromList $ do

107114 paramRef <- tracedParameters mp

108115 let

109116 param = dereference defs paramRef

110117 key = paramKey . extract $ param

111118 pure (key, param)

112− pathParamsMap :: Map ParamKey (Traced OpenApi Param)

119+ pathParamsMap :: Map ParamKey (Traced Param)

113120 pathParamsMap = M.fromList $ do

114121 param <- pathParams . extract $ mp

115122 pure (paramKey . extract $ param, param)

116− params = M.elems $ M.union operationParamsMap pathParamsMap

117− -- We prefer params from Operation

123+ params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation

118124 splitted = L.partition

119125 (\p -> (_paramIn . extract $ p) == ParamPath) params

120126 in splitted

121127 checkNonPathParams $ snd <$> tracedParams

122128 checkPathParams $ fst <$> tracedParams

123129 pure ()

124− checkNonPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula ()

130+ checkNonPathParams :: ProdCons [Traced Param] -> CompatFormula ()

125131 checkNonPathParams params = do

126132 let

127133 elements = getEls <$> params

@@ -130,30 +136,30 @@ instance Subtree MatchedOperation where

130136 let

131137 k = (_paramIn . extract $ p, _paramName . extract $ p)

132138 v = ProductLike

133− { tracedValue = p

139+ { productValue = p

134140 , required = fromMaybe False . _paramRequired . extract $ p

135141 }

136142 pure (k, v)

137− check param = do

138− checkCompatibility @Param (singletonH schemaDefs) param

139− checkProducts (ParamNotMatched . snd) (const check) elements

140− checkPathParams :: ProdCons [Traced OpenApi Param] -> CompatFormula ()

143+ check (_, name) param = do

144+ checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param

145+ checkProducts beh (ParamNotMatched . snd) check elements

146+ checkPathParams :: ProdCons [Traced Param] -> CompatFormula ()

141147 checkPathParams pathParams = do

142148 let

143− fragments :: ProdCons [Traced OpenApi PathFragmentParam]

149+ fragments :: ProdCons [Traced PathFragmentParam]

144150 fragments = getFragments <$> pathParams <*> prodCons

145151 getFragments params mop = getPathFragments (extract mop) params

146152 -- Feed path parameters to the fragments getter

147− check frags = checkCompatibility @PathFragmentParam env frags

153+ check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags

148154 elements = fragments <&> \frags -> M.fromList $ zip [0 :: Int ..] $ do

149155 frag <- frags

150156 pure $ ProductLike

151− { tracedValue = frag

157+ { productValue = frag

152158 , required = True }

153− checkProducts (const PathFragmentNotMatched) (const check) elements

159+ checkProducts beh PathFragmentNotMatched check elements

154160 checkRequestBodies = do

155161 let

156− check reqBody = checkCompatibility @RequestBody env reqBody

162+ check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody

157163 elements = getReqBody <$> bodyDefs <*> prodCons

158164 getReqBody bodyDef mop = M.fromList $ do

159165 bodyRef <- F.toList . tracedRequestBody $ mop

@@ -161,31 +167,31 @@ instance Subtree MatchedOperation where

161167 body = dereference bodyDef bodyRef

162168 -- Single element map

163169 pure ((), ProductLike

164− { tracedValue = body

170+ { productValue = body

165171 , required = fromMaybe False . _requestBodyRequired . extract $ body

166172 })

167− checkProducts (const NoRequestBody) (const check) elements

173+ checkProducts beh (const NoRequestBody) (const check) elements

168174 checkResponses = do

169175 let

170176 respEnv = HCons (swapProdCons respDefs)

171177 $ HCons (swapProdCons headerDefs)

172178 $ HCons (swapProdCons schemaDefs) HNil

173179 resps = tracedResponses <$> prodCons

174− checkCompatibility respEnv $ swapProdCons resps

180+ checkCompatibility respEnv beh $ swapProdCons resps

175181 -- FIXME: https://github.com/typeable/openapi-diff/issues/27

176182 checkCallbacks = pure () -- (error "FIXME: not implemented")

177183 -- FIXME: https://github.com/typeable/openapi-diff/issues/28

178184 checkOperationSecurity = pure () -- (error "FIXME: not implemented")

179185 checkServers =

180− checkCompatibility env $

186+ checkCompatibility env beh $

181187 tracedServers <$> getH @(ProdCons [Server]) env <*> prodCons

182− bodyDefs = getH @(ProdCons (Definitions RequestBody)) env

183− respDefs = getH @(ProdCons (Definitions Response)) env

184− headerDefs = getH @(ProdCons (Definitions Header)) env

185− schemaDefs = getH @(ProdCons (Definitions Schema)) env

186− paramDefs = getH @(ProdCons (Definitions Param)) env

188+ bodyDefs = getH @(ProdCons (Traced (Definitions RequestBody))) env

189+ respDefs = getH @(ProdCons (Traced (Definitions Response))) env

190+ headerDefs = getH @(ProdCons (Traced (Definitions Header))) env

191+ schemaDefs = getH @(ProdCons (Traced (Definitions Schema))) env

192+ paramDefs = getH @(ProdCons (Traced (Definitions Param))) env

187193

188−data OperationMethod =

194+data OperationMethod =

189195 GetMethod

190196 | PutMethod

191197 | PostMethod

@@ -196,7 +202,7 @@ data OperationMethod =

196202 | TraceMethod

197203 deriving (Eq, Ord, Show)

198204

199−pathItemMethod :: OperationMethod -> PathItem -> Maybe Operation

205+pathItemMethod :: OperationMethod -> PathItem -> Maybe Operation

200206pathItemMethod = \case

201207 GetMethod -> _pathItemGet

202208 PutMethod -> _pathItemPut

@@ -209,22 +215,22 @@ pathItemMethod = \case

209215

210216instance Steppable MatchedOperation (Referenced Param) where

211217 data Step MatchedOperation (Referenced Param) = OperationParamsStep Int

212− deriving (Eq, Ord, Show)

218+ deriving stock (Eq, Ord, Show)

213219

214220instance Steppable MatchedOperation (Referenced RequestBody) where

215221 data Step MatchedOperation (Referenced RequestBody) = OperationRequestBodyStep

216− deriving (Eq, Ord, Show)

222+ deriving stock (Eq, Ord, Show)

217223

218224instance Steppable MatchedOperation Responses where

219225 data Step MatchedOperation Responses = OperationResponsesStep

220− deriving (Eq, Ord, Show)

226+ deriving stock (Eq, Ord, Show)

221227

222228instance Steppable MatchedOperation SecurityRequirement where

223229 data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int

224− deriving (Eq, Ord, Show)

230+ deriving stock (Eq, Ord, Show)

225231

226232instance Steppable MatchedOperation [Server] where

227− data Step MatchedOperation [Server]

228− = OperationServersStep

233+ data Step MatchedOperation [Server]

234+ = OperationServersStep

229235 | EnvServerStep

230236 deriving (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Param.hs+28−18

@@ -2,17 +2,18 @@

22{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

44module OpenAPI.Checker.Validate.Param

5− ( CheckIssue (..)

5+ ( Behave (..)

6+ , Issue (..)

67 ) where

89import Control.Lens

910import Control.Monad

1011import Data.Maybe

1112import Data.OpenApi

12−import Data.Text

13−import OpenAPI.Checker.Orphans

13+import Data.Text as T

14+import OpenAPI.Checker.Behavior

15+import OpenAPI.Checker.Orphans ()

1416import OpenAPI.Checker.Subtree

15−import OpenAPI.Checker.Trace

1617import OpenAPI.Checker.Validate.Schema ()

1718

1819-- | The type is normalized encoding style of the parameter. If two encoding

@@ -42,14 +43,12 @@ paramEncoding p = EncodingStyle

4243 ParamQuery -> Just $ fromMaybe False $ _paramAllowReserved p

4344 _ -> Nothing

4445

45−tracedSchema :: Traced r Param -> Maybe (Traced r (Referenced Schema))

46+tracedSchema :: Traced Param -> Maybe (Traced (Referenced Schema))

4647tracedSchema par = _paramSchema (extract par) <&> traced (ask par >>> step ParamSchema)

4748

48−instance Subtree Param where

49− type CheckEnv Param = '[ProdCons (Definitions Schema)]

50− data CheckIssue Param

51− = ParamNotMatched Text

52− | ParamNameMismatch

49+instance Issuable 'PathFragmentLevel where

50+ data Issue 'PathFragmentLevel

51+ = ParamNameMismatch

5352 -- ^ Params have different names

5453 | ParamEmptinessIncompatible

5554 -- ^ Consumer requires non-empty param, but producer gives emptyable

@@ -60,28 +59,39 @@ instance Subtree Param where

6059 -- ^ Params encoded in different styles

6160 | ParamSchemaMismatch

6261 -- ^ One of schemas not presented

62+ | PathFragmentsDontMatch Text Text

63+ deriving (Eq, Ord, Show)

64+ issueIsUnsupported _ = False

65+

66+instance Behavable 'PathFragmentLevel 'SchemaLevel where

67+ data Behave 'PathFragmentLevel 'SchemaLevel

68+ = InParamSchema

6369 deriving (Eq, Ord, Show)

64− checkCompatibility env pc@(ProdCons p c) = do

70+

71+instance Subtree Param where

72+ type SubtreeLevel Param = 'PathFragmentLevel

73+ type CheckEnv Param = '[ProdCons (Traced (Definitions Schema))]

74+ checkCompatibility env beh pc@(ProdCons p c) = do

6575 when (_paramName (extract p) /= _paramName (extract c))

66− $ issueAt p ParamNameMismatch

76+ $ issueAt beh ParamNameMismatch

6777 when ((fromMaybe False . _paramRequired . extract $ c) &&

6878 not (fromMaybe False . _paramRequired . extract $ p))

69− $ issueAt p ParamRequired

79+ $ issueAt beh ParamRequired

7080 case (_paramIn . extract $ p, _paramIn . extract $ c) of

7181 (ParamQuery, ParamQuery) -> do

7282 -- Emptiness is only for query params

7383 when ((fromMaybe False . _paramAllowEmptyValue . extract $ p)

7484 && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))

75− $ issueAt p ParamEmptinessIncompatible

85+ $ issueAt beh ParamEmptinessIncompatible

7686 (a, b) | a == b -> pure ()

77− _ -> issueAt p ParamPlaceIncompatible

87+ _ -> issueAt beh ParamPlaceIncompatible

7888 unless (paramEncoding (extract p) == paramEncoding (extract c))

79− $ issueAt p ParamStyleMismatch

89+ $ issueAt beh ParamStyleMismatch

8090 case tracedSchema <$> pc of

8191 ProdCons (Just prodSchema) (Just consSchema) -> do

82− checkCompatibility env $ ProdCons prodSchema consSchema

92+ checkCompatibility env (beh >>> step InParamSchema) $ ProdCons prodSchema consSchema

8393 ProdCons Nothing Nothing -> pure ()

84− ProdCons Nothing (Just _consSchema) -> issueAt p ParamSchemaMismatch

94+ ProdCons Nothing (Just _consSchema) -> issueAt beh ParamSchemaMismatch

8595 ProdCons (Just _prodSchema) Nothing -> pure ()

8696 -- If consumer doesn't care then why we should?

8797 pure ()

src/OpenAPI/Checker/Validate/PathFragment.hs+10−14

@@ -2,7 +2,6 @@ module OpenAPI.Checker.Validate.PathFragment

22 ( parsePath

33 , PathFragment (..)

44 , PathFragmentParam

5− , CheckIssue (..)

65 )

76where

@@ -11,9 +10,9 @@ import Data.OpenApi

1110import Data.Text (Text)

1211import qualified Data.Text as T

1312import Data.Typeable

13+import OpenAPI.Checker.Behavior

1414import OpenAPI.Checker.Subtree

15−import OpenAPI.Checker.Trace

16−import OpenAPI.Checker.Validate.Param ()

15+import OpenAPI.Checker.Validate.Param

1716

1817-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.

1918-- https://github.com/typeable/openapi-diff/issues/23

@@ -35,13 +34,13 @@ data PathFragment param

3534 | DynamicPath param

3635 deriving stock (Eq, Ord)

3736

38−type PathFragmentParam = PathFragment (Traced OpenApi Param)

37+type PathFragmentParam = PathFragment (Traced Param)

3938

4039instance (Typeable param) => Steppable (PathFragment param) Param where

4140 data Step (PathFragment param) Param = StaticPathParam Text

4241 deriving (Eq, Ord, Show)

4342

44−tracedPathFragmentParam :: Traced OpenApi PathFragmentParam -> Traced OpenApi Param

43+tracedPathFragmentParam :: Traced PathFragmentParam -> Traced Param

4544tracedPathFragmentParam pfp = case extract pfp of

4645 StaticPath s -> traced (ask pfp >>> step (StaticPathParam s))

4746 $ mempty

@@ -61,16 +60,13 @@ staticStringSchema t =

6160 }

6261

6362instance Subtree PathFragmentParam where

63+ type SubtreeLevel PathFragmentParam = 'PathFragmentLevel

6464 type CheckEnv PathFragmentParam =

65− '[ ProdCons (Definitions Schema) ]

66− data CheckIssue PathFragmentParam

67− = PathFragmentNotMatched

68− | PathFragmentsDontMatch Text Text

69− deriving (Eq, Ord, Show)

65+ '[ ProdCons (Traced (Definitions Schema)) ]

7066 -- This case isn't strictly needed. It is here for optimization.

71− checkCompatibility _ (ProdCons (extract -> StaticPath x) c@(extract -> StaticPath y))

67+ checkCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y))

7268 = if x == y

7369 then pure ()

74− else issueAt c (PathFragmentsDontMatch x y)

75− checkCompatibility env prodCons = do

76− checkCompatibility env (tracedPathFragmentParam <$> prodCons)

70+ else issueAt beh (PathFragmentsDontMatch x y)

71+ checkCompatibility env beh prodCons = do

72+ checkCompatibility env beh (tracedPathFragmentParam <$> prodCons)

src/OpenAPI/Checker/Validate/ProcessedPathItem.hs+61−39

@@ -9,6 +9,7 @@ module OpenAPI.Checker.Validate.ProcessedPathItem

99 )

1010where

1111

12+import Control.Arrow

1213import Control.Comonad.Env

1314import Control.Monad

1415import Data.Foldable as F

@@ -19,9 +20,11 @@ import Data.Map.Strict as M

1920import Data.Maybe

2021import Data.OpenApi

2122import Data.Text as T

23+import OpenAPI.Checker.Behavior

24+import OpenAPI.Checker.Orphans ()

25+import OpenAPI.Checker.Paths

2226import OpenAPI.Checker.References

2327import OpenAPI.Checker.Subtree

24−import OpenAPI.Checker.Trace

2528import OpenAPI.Checker.Validate.Operation

2629import OpenAPI.Checker.Validate.PathFragment

2730import OpenAPI.Checker.Validate.Sums

@@ -38,23 +41,32 @@ processPathItems = ProcessedPathItems . fmap (uncurry ProcessedPathItem)

3841newtype ProcessedPathItems =

3942 ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}

4043

44+instance Issuable 'APILevel where

45+ data Issue 'APILevel

46+ = NoPathsMatched FilePath

47+ | AllPathsFailed FilePath

48+ -- When several paths match given but all checks failed

49+ deriving stock (Eq, Ord, Show)

50+ issueIsUnsupported _ = False

51+

52+instance Behavable 'APILevel 'PathLevel where

53+ data Behave 'APILevel 'PathLevel

54+ = AtPath (ProdCons FilePath) -- TODO: why are there two?

55+ deriving stock (Eq, Ord, Show)

56+

4157instance Subtree ProcessedPathItems where

58+ type SubtreeLevel ProcessedPathItems = 'APILevel

4259 type

4360 CheckEnv ProcessedPathItems =

44− '[ ProdCons (Definitions Param)

45− , ProdCons (Definitions RequestBody)

46− , ProdCons (Definitions SecurityScheme)

47− , ProdCons (Definitions Response)

48− , ProdCons (Definitions Header)

49− , ProdCons (Definitions Schema)

61+ '[ ProdCons (Traced (Definitions Param))

62+ , ProdCons (Traced (Definitions RequestBody))

63+ , ProdCons (Traced (Definitions SecurityScheme))

64+ , ProdCons (Traced (Definitions Response))

65+ , ProdCons (Traced (Definitions Header))

66+ , ProdCons (Traced (Definitions Schema))

5067 , ProdCons [Server]

5168 ]

52− data CheckIssue ProcessedPathItems

53− = NoPathsMatched FilePath

54− | AllPathsFailed FilePath

55− -- When several paths match given but all checks failed

56− deriving (Eq, Ord, Show)

57− checkCompatibility env pc@(ProdCons p c) = do

69+ checkCompatibility env beh pc@(ProdCons p c) = do

5870 -- Each path generated by producer must be handled by consumer with exactly

5971 -- one way

6072 for_ (unProcessedPathItems . extract $ p) $ \ prodItem -> do

@@ -65,11 +77,11 @@ instance Subtree ProcessedPathItems where

6577 matched <- F.toList $ matchingPathItems $ ProdCons prodItem consItem

6678 return matched

6779 case matchedItems of

68− [] -> issueAt p $ NoPathsMatched prodPath

69− [match] -> checkCompatibility env (retraced <$> pc <*> match)

70− matches -> anyOfAt c (AllPathsFailed prodPath) $ do

80+ [] -> issueAt beh $ NoPathsMatched prodPath

81+ [match] -> checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)

82+ matches -> anyOfAt beh (AllPathsFailed prodPath) $ do

7183 match <- matches

72− pure $ checkCompatibility env (retraced <$> pc <*> match)

84+ pure $ checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)

7385 where

7486 retraced pc mpi = traced (ask pc >>> step (MatchedPathStep $ matchedPath mpi)) mpi

7587

@@ -106,14 +118,14 @@ data MatchedPathItem = MatchedPathItem

106118 -- ^ Pre-parsed path from PathItem

107119 }

108120

109−tracedParameters :: Traced r MatchedPathItem -> [Traced r (Referenced Param)]

121+tracedParameters :: Traced MatchedPathItem -> [Traced (Referenced Param)]

110122tracedParameters mpi =

111123 [ traced (ask mpi >>> step (PathItemParam i)) x

112124 | (i, x) <- L.zip [0..] $ _pathItemParameters . pathItem $ extract mpi

113125 ]

114126

115127-- TODO: simplify?

116−tracedFragments :: Traced r MatchedPathItem -> [Env (Trace r PathFragmentParam) (PathFragment Text)]

128+tracedFragments :: Traced MatchedPathItem -> [Env (Trace PathFragmentParam) (PathFragment Text)]

117129tracedFragments mpi =

118130 [ env (ask mpi >>> step (PathFragmentStep i)) x

119131 | (i, x) <- L.zip [0..] $ pathFragments $ extract mpi

@@ -121,30 +133,40 @@ tracedFragments mpi =

121133

122134tracedMethod

123135 :: OperationMethod

124− -> Traced r MatchedPathItem

125− -> Maybe (Env (Trace r MatchedOperation) Operation)

136+ -> Traced MatchedPathItem

137+ -> Maybe (Traced' MatchedOperation Operation)

126138tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)

127139

140+instance Issuable 'PathLevel where

141+ data Issue 'PathLevel

142+ = OperationMissing OperationMethod

143+ deriving stock (Eq, Ord, Show)

144+ issueIsUnsupported _ = False

145+

146+instance Behavable 'PathLevel 'OperationLevel where

147+ data Behave 'PathLevel 'OperationLevel

148+ = InOperation OperationMethod

149+ deriving (Eq, Ord, Show)

150+

128151instance Subtree MatchedPathItem where

152+ type SubtreeLevel MatchedPathItem = 'PathLevel

129153 type CheckEnv MatchedPathItem =

130− '[ ProdCons (Definitions Param)

131− , ProdCons (Definitions RequestBody)

132− , ProdCons (Definitions SecurityScheme)

133− , ProdCons (Definitions Response)

134− , ProdCons (Definitions Header)

135− , ProdCons (Definitions Schema)

154+ '[ ProdCons (Traced (Definitions Param))

155+ , ProdCons (Traced (Definitions RequestBody))

156+ , ProdCons (Traced (Definitions SecurityScheme))

157+ , ProdCons (Traced (Definitions Response))

158+ , ProdCons (Traced (Definitions Header))

159+ , ProdCons (Traced (Definitions Schema))

136160 , ProdCons [Server]

137161 ]

138− data CheckIssue MatchedPathItem

139− deriving (Eq, Ord, Show)

140− checkCompatibility env prodCons = do

162+ checkCompatibility env beh prodCons = do

141163 let

142− paramDefs = getH @(ProdCons (Definitions Param)) env

164+ paramDefs = getH @(ProdCons (Traced (Definitions Param))) env

143165 pathTracedParams = getPathParams <$> paramDefs <*> prodCons

144166 getPathParams

145− :: Definitions Param

146− -> Traced r MatchedPathItem

147− -> [Traced r Param]

167+ :: Traced (Definitions Param)

168+ -> Traced MatchedPathItem

169+ -> [Traced Param]

148170 getPathParams defs mpi = do

149171 paramRef <- tracedParameters mpi

150172 pure $ dereference defs paramRef

@@ -153,7 +175,7 @@ instance Subtree MatchedPathItem where

153175 -- operationParams will be known on Operation check stage, so we give a

154176 -- function, returning fragments

155177 let

156− paramsMap :: Map Text (Traced OpenApi Param)

178+ paramsMap :: Map Text (Traced Param)

157179 paramsMap = M.fromList $ do

158180 tracedParam <- operationParams

159181 let pname = _paramName . extract $ tracedParam

@@ -166,16 +188,16 @@ instance Subtree MatchedPathItem where

166188 in tracedFragments mpi <&> fmap convertFragment

167189 operations = getOperations <$> pathTracedParams <*> pathTracedFragments <*> prodCons

168190 getOperations pathParams getPathFragments mpi = M.fromList $ do

169− (i, getOp) <- (\m -> (m, tracedMethod m)) <$>

191+ (name, getOp) <- (id &&& tracedMethod) <$>

170192 [GetMethod, PutMethod, PostMethod, DeleteMethod, OptionsMethod, HeadMethod, PatchMethod, DeleteMethod]

171193 operation <- F.toList $ getOp mpi

172194 -- Got only Justs here

173195 let retraced = \op -> MatchedOperation { operation = op, pathParams, getPathFragments }

174− pure (i, retraced <$> operation)

175− check pc = checkCompatibility @MatchedOperation env pc

196+ pure (name, retraced <$> operation)

197+ check name pc = checkCompatibility @MatchedOperation env (beh >>> step (InOperation name)) pc

176198 -- Operations are sum-like entities. Use step to operation as key because

177199 -- why not

178− checkSums OperationMissing (const check) operations

200+ checkSums beh OperationMissing check operations

179201

180202

181203instance Steppable ProcessedPathItems MatchedPathItem where

src/OpenAPI/Checker/Validate/Products.hs+13−13

@@ -20,30 +20,30 @@ module OpenAPI.Checker.Validate.Products

2020import Data.Foldable

2121import Data.Map.Strict (Map)

2222import qualified Data.Map.Strict as M

23+import OpenAPI.Checker.Behavior

24+import OpenAPI.Checker.Paths

2325import OpenAPI.Checker.Subtree

24−import OpenAPI.Checker.Trace

2526

2627-- | Some entity which is product-like

27−data ProductLike root a = ProductLike

28− { tracedValue :: Traced root a

28+data ProductLike a = ProductLike

29+ { productValue :: a

2930 , required :: Bool

3031 }

3132

3233checkProducts

33− :: forall k r t

34− . (Subtree t, Ord k)

35− => (k -> CheckIssue t)

34+ :: (Ord k, Issuable l)

35+ => Paths q r l

36+ -> (k -> Issue l)

3637 -- ^ No required element found

37− -> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())

38− -> ProdCons (Map k (ProductLike r t))

39− -> CompatFormula' SubtreeCheckIssue r ()

40−checkProducts noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->

38+ -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())

39+ -> ProdCons (Map k (ProductLike t))

40+ -> CompatFormula' q AnIssue r ()

41+checkProducts xs noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->

4142 case M.lookup key p of

4243 Nothing -> case required consElt of

43− True -> issueAt (tracedValue consElt) $ noElt key

44+ True -> issueAt xs $ noElt key

4445 False -> pure ()

4546 Just prodElt -> do

4647 let

47− elts :: ProdCons (ProductLike r t)

4848 elts = ProdCons prodElt consElt

49− check key (tracedValue <$> elts)

49+ check key (productValue <$> elts)

src/OpenAPI/Checker/Validate/RequestBody.hs+21−12

@@ -1,7 +1,7 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

33module OpenAPI.Checker.Validate.RequestBody

4− ( CheckIssue (..)

4+ ( Issue (..)

55 )

66where

@@ -11,33 +11,42 @@ import Data.Map.Strict as M

1111import Data.Maybe

1212import Data.OpenApi

1313import Network.HTTP.Media (MediaType)

14+import OpenAPI.Checker.Behavior

1415import OpenAPI.Checker.Subtree

15−import OpenAPI.Checker.Trace

1616import OpenAPI.Checker.Validate.MediaTypeObject

1717import OpenAPI.Checker.Validate.Sums

1818

19−tracedContent :: Traced r RequestBody -> IOHM.InsOrdHashMap MediaType (Traced r MediaTypeObject)

19+tracedContent :: Traced RequestBody -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)

2020tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k)))

2121 $ _requestBodyContent $ extract resp

2222

23+instance Issuable 'RequestLevel where

24+ data Issue 'RequestLevel

25+ = RequestBodyRequired

26+ | RequestMediaTypeNotFound MediaType

27+ deriving stock (Eq, Ord, Show)

28+ issueIsUnsupported _ = False

29+

30+instance Behavable 'RequestLevel 'PayloadLevel where

31+ data Behave 'RequestLevel 'PayloadLevel

32+ = InPayload

33+ deriving stock (Eq, Ord, Show)

34+

2335instance Subtree RequestBody where

36+ type SubtreeLevel RequestBody = 'RequestLevel

2437 type CheckEnv RequestBody =

25− '[ ProdCons (Definitions Schema) ]

26− data CheckIssue RequestBody

27− = NoRequestBody

28− | RequestBodyRequired

29− deriving (Eq, Ord, Show)

30− checkCompatibility env prodCons@(ProdCons p c) =

38+ '[ ProdCons (Traced (Definitions Schema)) ]

39+ checkCompatibility env beh prodCons@(ProdCons p c) =

3140 if not (fromMaybe False . _requestBodyRequired . extract $ p)

3241 && (fromMaybe False . _requestBodyRequired . extract $ c)

33− then issueAt p RequestBodyRequired

42+ then issueAt beh RequestBodyRequired

3443 else

3544 -- Media type object are sums-like entities.

3645 let

37− check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) pc

46+ check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) (beh >>> step InPayload) pc

3847 sumElts = getSum <$> prodCons

3948 getSum rb = M.fromList . IOHM.toList $ tracedContent rb

40− in checkSums (const RequestMediaTypeNotFound) check sumElts

49+ in checkSums beh RequestMediaTypeNotFound check sumElts

4150

4251instance Steppable RequestBody MediaTypeObject where

4352 data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType

src/OpenAPI/Checker/Validate/Responses.hs+63−41

@@ -14,56 +14,70 @@ import Data.Map.Strict as M

1414import Data.Maybe

1515import Data.OpenApi

1616import Network.HTTP.Media (MediaType)

17+import OpenAPI.Checker.Behavior

1718import OpenAPI.Checker.References

1819import OpenAPI.Checker.Subtree

19−import OpenAPI.Checker.Trace

2020import OpenAPI.Checker.Validate.MediaTypeObject

2121import OpenAPI.Checker.Validate.Products

2222import OpenAPI.Checker.Validate.Schema ()

2323import OpenAPI.Checker.Validate.Sums

2424

25−tracedResponses :: Traced r Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced r (Referenced Response))

25+tracedResponses :: Traced Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced (Referenced Response))

2626tracedResponses resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k)))

2727 $ _responsesResponses $ extract resp

2828

2929instance Subtree Responses where

30+ type SubtreeLevel Responses = 'OperationLevel

3031 type CheckEnv Responses =

31− '[ ProdCons (Definitions Response)

32− , ProdCons (Definitions Header)

33− , ProdCons (Definitions Schema)

32+ '[ ProdCons (Traced (Definitions Response))

33+ , ProdCons (Traced (Definitions Header))

34+ , ProdCons (Traced (Definitions Schema))

3435 ]

35− data CheckIssue Responses

36− deriving (Eq, Ord, Show)

3736 -- Roles are already swapped. Producer is a server and consumer is a

3837 -- client. Response codes are sum-like entity because we can answer with only

3938 -- one element

40− checkCompatibility env prodCons = do

39+ checkCompatibility env beh prodCons = do

4140 let

42− defs = getH @(ProdCons (Definitions Response)) env

43− check resps = checkCompatibility @Response env resps

41+ defs = getH @(ProdCons (Traced (Definitions Response))) env

42+ check code resps = checkCompatibility @Response env (beh >>> step (WithStatusCode code)) resps

4443 elements = getEls <$> defs <*> prodCons

4544 getEls respDef resps = M.fromList $ do

4645 (code, respRef) <- IOHM.toList $ tracedResponses resps

4746 pure (code, dereference respDef respRef)

48− checkSums (const ResponseCodeNotFound) (const check) elements

47+ checkSums beh ResponseCodeNotFound check elements

4948

50−tracedContent :: Traced r Response -> IOHM.InsOrdHashMap MediaType (Traced r MediaTypeObject)

49+tracedContent :: Traced Response -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)

5150tracedContent resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k)))

5251 $ _responseContent $ extract resp

5352

54−tracedHeaders :: Traced r Response -> IOHM.InsOrdHashMap HeaderName (Traced r (Referenced Header))

53+tracedHeaders :: Traced Response -> IOHM.InsOrdHashMap HeaderName (Traced (Referenced Header))

5554tracedHeaders resp = IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k)))

5655 $ _responseHeaders $ extract resp

5756

57+instance Issuable 'ResponseLevel where

58+ data Issue 'ResponseLevel

59+ = ResponseMediaTypeMissing MediaType

60+ | ResponseHeaderMissing HeaderName

61+ deriving stock (Eq, Ord, Show)

62+ issueIsUnsupported _ = False

63+

64+instance Behavable 'ResponseLevel 'PayloadLevel where

65+ data Behave 'ResponseLevel 'PayloadLevel

66+ = ResponsePayload

67+ deriving stock (Eq, Ord, Show)

68+

69+instance Behavable 'ResponseLevel 'HeaderLevel where

70+ data Behave 'ResponseLevel 'HeaderLevel

71+ = InHeader HeaderName

72+ deriving stock (Eq, Ord, Show)

73+

5874instance Subtree Response where

75+ type SubtreeLevel Response = 'ResponseLevel

5976 type CheckEnv Response =

60− '[ ProdCons (Definitions Header)

61− , ProdCons (Definitions Schema)

77+ '[ ProdCons (Traced (Definitions Header))

78+ , ProdCons (Traced (Definitions Schema))

6279 ]

63− data CheckIssue Response

64− = ResponseCodeNotFound

65− deriving (Eq, Ord, Show)

66− checkCompatibility env prodCons = do

80+ checkCompatibility env beh prodCons = do

6781 -- Roles are already swapped. Producer is a server and consumer is a client

6882 checkMediaTypes

6983 checkHeaders

@@ -74,60 +88,68 @@ instance Subtree Response where

7488 let

7589 check mediaType mtObj =

7690 let mtEnv = HCons mediaType $ env

77− in checkCompatibility @MediaTypeObject mtEnv mtObj

91+ in checkCompatibility @MediaTypeObject mtEnv (beh >>> step ResponsePayload) mtObj

7892 elements = getEls <$> prodCons

7993 getEls resp = M.fromList . IOHM.toList $ tracedContent resp

80− checkSums (const ResponseMediaTypeMissing) check elements

94+ checkSums beh ResponseMediaTypeMissing check elements

8195

8296 checkHeaders = do

8397 -- Headers are product-like entities

8498 let

85− check hdrs = checkCompatibility @Header env hdrs

99+ check name hdrs = checkCompatibility @Header env (beh >>> step (InHeader name)) hdrs

86100 elements = getEls <$> headerDefs <*> prodCons

87101 getEls headerDef resp = M.fromList $ do

88102 (hname, headerRef) <- IOHM.toList $ tracedHeaders resp

89103 let header = dereference headerDef headerRef

90104 pure (hname, ProductLike

91− { tracedValue = header

105+ { productValue = header

92106 , required = fromMaybe False . _headerRequired . extract $ header

93107 })

94− checkProducts (const ResponseHeaderMissing) (const check) elements

95− headerDefs = getH @(ProdCons (Definitions Header)) env

108+ checkProducts beh ResponseHeaderMissing check elements

109+ headerDefs = getH @(ProdCons (Traced (Definitions Header))) env

96110

97−tracedSchema :: Traced r Header -> Maybe (Traced r (Referenced Schema))

111+tracedSchema :: Traced Header -> Maybe (Traced (Referenced Schema))

98112tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)

99113

100−instance Subtree Header where

101− type CheckEnv Header = '[ProdCons (Definitions Schema)]

102− data CheckIssue Header

103− = ResponseHeaderMissing

104− | RequiredHeaderMissing

114+instance Issuable 'HeaderLevel where

115+ data Issue 'HeaderLevel

116+ = RequiredHeaderMissing

105117 | NonEmptyHeaderRequired

106118 | HeaderSchemaRequired

107− deriving (Eq, Ord, Show)

108− checkCompatibility env (ProdCons p c) = do

119+ deriving stock (Eq, Ord, Show)

120+ issueIsUnsupported _ = False

121+

122+instance Behavable 'HeaderLevel 'SchemaLevel where

123+ data Behave 'HeaderLevel 'SchemaLevel

124+ = InSchema

125+ deriving stock (Eq, Ord, Show)

126+

127+instance Subtree Header where

128+ type SubtreeLevel Header = 'HeaderLevel

129+ type CheckEnv Header = '[ProdCons (Traced (Definitions Schema))]

130+ checkCompatibility env beh (ProdCons p c) = do

109131 if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)

110− then issueAt p RequiredHeaderMissing else pure ()

132+ then issueAt beh RequiredHeaderMissing else pure ()

111133 if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)

112− then issueAt p NonEmptyHeaderRequired else pure ()

134+ then issueAt beh NonEmptyHeaderRequired else pure ()

113135 for_ (tracedSchema c) $ \consRef ->

114136 case tracedSchema p of

115− Nothing -> issueAt p HeaderSchemaRequired

116− Just prodRef -> checkCompatibility env (ProdCons prodRef consRef)

137+ Nothing -> issueAt beh HeaderSchemaRequired

138+ Just prodRef -> checkCompatibility env (beh >>> step InSchema) (ProdCons prodRef consRef)

117139 pure ()

118140

119141instance Steppable Responses (Referenced Response) where

120142 data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode

121− deriving (Eq, Ord, Show)

143+ deriving stock (Eq, Ord, Show)

122144

123145instance Steppable Header (Referenced Schema) where

124146 data Step Header (Referenced Schema) = HeaderSchema

125− deriving (Eq, Ord, Show)

147+ deriving stock (Eq, Ord, Show)

126148

127149instance Steppable Response (Referenced Header) where

128150 data Step Response (Referenced Header) = ResponseHeader HeaderName

129− deriving (Eq, Ord, Show)

151+ deriving stock (Eq, Ord, Show)

130152

131153instance Steppable Response MediaTypeObject where

132154 data Step Response MediaTypeObject = ResponseMediaObject MediaType

133− deriving (Eq, Ord, Show)

155+ deriving stock (Eq, Ord, Show)

src/OpenAPI/Checker/Validate/Schema.hs+200−182

@@ -39,11 +39,12 @@ import qualified Data.Set as S

3939import Data.Text (Text)

4040import qualified Data.Text as T hiding (singleton)

4141import Data.Typeable

42+import OpenAPI.Checker.Behavior

4243import OpenAPI.Checker.Orphans ()

4344import OpenAPI.Checker.References

45+import OpenAPI.Checker.Paths

46+import qualified OpenAPI.Checker.PathsPrefixTree as P

4447import OpenAPI.Checker.Subtree

45−import OpenAPI.Checker.Trace

46−import qualified OpenAPI.Checker.TracePrefixTree as T

4748

4849-- | Type of a JSON value

4950data JsonType

@@ -53,7 +54,7 @@ data JsonType

5354 | String

5455 | Array

5556 | Object

56− deriving (Eq, Show)

57+ deriving stock (Eq, Ord, Show)

5758

5859-- | A 'A.Value' whose type we know

5960data TypedValue :: JsonType -> Type where

@@ -88,8 +89,8 @@ instance Ord a => Ord (Bound a) where

8889

8990data Property = Property

9091 { propRequired :: Bool

91− , propFormula :: ForeachType (JsonFormula OpenApi)

92− , propRefSchema :: Traced OpenApi (Referenced Schema)

92+ , propFormula :: ForeachType JsonFormula

93+ , propRefSchema :: Traced (Referenced Schema)

9394 }

9495 deriving stock (Eq, Ord, Show)

9596

@@ -106,17 +107,17 @@ data Condition :: JsonType -> Type where

106107 Pattern :: !Pattern -> Condition 'String

107108 StringFormat :: !Format -> Condition 'String

108109 Items

109− :: !(ForeachType (JsonFormula OpenApi))

110− -> !(Traced OpenApi (Referenced Schema))

110+ :: !(ForeachType JsonFormula)

111+ -> !(Traced (Referenced Schema))

111112 -> Condition 'Array

112113 MaxItems :: !Integer -> Condition 'Array

113114 MinItems :: !Integer -> Condition 'Array

114115 UniqueItems :: Condition 'Array

115116 Properties

116117 :: !(M.Map Text Property)

117− -> !(ForeachType (JsonFormula OpenApi))

118+ -> !(ForeachType JsonFormula)

118119 -- ^ formula for additional properties

119− -> !(Maybe (Traced OpenApi (Referenced Schema)))

120+ -> !(Maybe (Traced (Referenced Schema)))

120121 -- ^ schema for additional properties, Nothing means bottom

121122 -> Condition 'Object

122123 MaxProperties :: !Integer -> Condition 'Object

@@ -158,7 +159,7 @@ deriving stock instance Ord (Condition t)

158159deriving stock instance Show (Condition t)

159160

160161data SomeCondition where

161− SomeCondition :: Typeable t => Traced OpenApi (Condition t) -> SomeCondition

162+ SomeCondition :: Typeable t => Condition t -> SomeCondition

162163

163164instance Eq SomeCondition where

164165 SomeCondition x == SomeCondition y = case cast x of

@@ -175,26 +176,24 @@ deriving stock instance Show SomeCondition

175176-- | A boolean formula (without "not") of 'Condition's. Represented as a

176177-- Disjunctive Normal Form: the formula is a disjunction of a set of conjuncts,

177178-- each of which is a conjunction of a set of 'Condition's.

178−newtype JsonFormula r t

179− = DNF (S.Set (M.Map (Condition t) (Trace r (Condition t))))

179+newtype JsonFormula t

180+ = DNF (S.Set (S.Set (Condition t)))

180181 deriving stock (Eq, Ord, Show)

181182

182183disjAdd

183− :: JsonFormula r t

184− -> M.Map (Condition t) (Trace r (Condition t))

185− -> JsonFormula r t

184+ :: JsonFormula t

185+ -> S.Set (Condition t)

186+ -> JsonFormula t

186187disjAdd (DNF yss) xs

187− | any (`isMapSubsetOf` xs) yss = DNF yss

188− | otherwise = DNF $ S.insert xs $ S.filter (not . isMapSubsetOf xs) yss

189− where

190− isMapSubsetOf a b = M.keysSet a `S.isSubsetOf` M.keysSet b

188+ | any (`S.isSubsetOf` xs) yss = DNF yss

189+ | otherwise = DNF $ S.insert xs $ S.filter (not . S.isSubsetOf xs) yss

191190

192−instance Lattice (JsonFormula r t) where

191+instance Lattice (JsonFormula t) where

193192 xss \/ DNF yss = S.foldl' disjAdd xss yss

194193 DNF xss /\ DNF yss = F.foldl' disjAdd bottom $

195− liftA2 M.union (S.toList xss) (S.toList yss)

194+ liftA2 S.union (S.toList xss) (S.toList yss)

196195

197−pattern BottomFormula :: JsonFormula r t

196+pattern BottomFormula :: JsonFormula t

198197pattern BottomFormula <- DNF (S.null -> True)

199198 where BottomFormula = DNF S.empty

200199

@@ -203,35 +202,35 @@ isSingleton s

203202 | S.size s == 1 = S.lookupMin s

204203 | otherwise = Nothing

205204

206−pattern Conjunct :: [Traced r (Condition t)] -> M.Map (Condition t) (Trace r (Condition t))

207−pattern Conjunct xs <- (map (uncurry $ flip traced) . M.toList -> xs)

208− where Conjunct xs = M.fromList $ (extract &&& ask) <$> xs

205+pattern Conjunct :: [Condition t] -> S.Set (Condition t)

206+pattern Conjunct xs <- (S.toList -> xs)

207+ where Conjunct = S.fromList

209208{-# COMPLETE Conjunct #-}

210209

211−pattern SingleConjunct :: [Traced r (Condition t)] -> JsonFormula r t

210+pattern SingleConjunct :: [Condition t] -> JsonFormula t

212211pattern SingleConjunct xs <- DNF (isSingleton -> Just (Conjunct xs))

213212 where SingleConjunct xs = DNF $ S.singleton $ Conjunct xs

214213

215−pattern TopFormula :: JsonFormula r t

216−pattern TopFormula <- DNF (isSingleton -> Just (M.null -> True))

217− where TopFormula = DNF $ S.singleton M.empty

214+pattern TopFormula :: JsonFormula t

215+pattern TopFormula <- DNF (isSingleton -> Just (S.null -> True))

216+ where TopFormula = DNF $ S.singleton S.empty

218217

219−instance BoundedJoinSemiLattice (JsonFormula r t) where

218+instance BoundedJoinSemiLattice (JsonFormula t) where

220219 bottom = BottomFormula

221220

222−instance BoundedMeetSemiLattice (JsonFormula r t) where

221+instance BoundedMeetSemiLattice (JsonFormula t) where

223222 top = TopFormula

224223

225224foldLattice

226225 :: BoundedLattice l

227− => (Traced r (Condition t) -> l)

228− -> JsonFormula r t

226+ => (Condition t -> l)

227+ -> JsonFormula t

229228 -> l

230229foldLattice f (DNF xss) = S.foldl' (\z w ->

231− z \/ M.foldlWithKey' (\x y t -> x /\ f (traced t y)) top w) bottom xss

230+ z \/ S.foldl' (\x y -> x /\ f y) top w) bottom xss

232231

233−satisfiesFormula :: TypedValue t -> JsonFormula r t -> Bool

234−satisfiesFormula val = foldLattice (satisfiesTyped val . extract)

232+satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool

233+satisfiesFormula val = foldLattice (satisfiesTyped val)

235234

236235data ForeachType (f :: JsonType -> Type) = ForeachType

237236 { forNull :: f 'Null

@@ -242,7 +241,7 @@ data ForeachType (f :: JsonType -> Type) = ForeachType

242241 , forObject :: f 'Object

243242 }

244243

245−satisfies :: A.Value -> ForeachType (JsonFormula r) -> Bool

244+satisfies :: A.Value -> ForeachType JsonFormula -> Bool

246245satisfies val p = case val of

247246 A.Null -> satisfiesFormula TNull $ forNull p

248247 A.Bool b -> satisfiesFormula (TBool b) $ forBoolean p

@@ -257,27 +256,27 @@ deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachTyp

257256

258257foldType

259258 :: Monoid m

260− => (forall x. Typeable x => (ForeachType f -> f x) -> m)

259+ => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)

261260 -> m

262261foldType k =

263− k forNull <>

264− k forBoolean <>

265− k forNumber <>

266− k forString <>

267− k forArray <>

268− k forObject

262+ k Null forNull <>

263+ k Boolean forBoolean <>

264+ k Number forNumber <>

265+ k String forString <>

266+ k Array forArray <>

267+ k Object forObject

269268

270269forType_

271270 :: Applicative m

272− => (forall x. Typeable x => (ForeachType f -> f x) -> m ())

271+ => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ())

273272 -> m ()

274273forType_ k = do

275− k forNull

276− k forBoolean

277− k forNumber

278− k forString

279− k forArray

280− k forObject

274+ k Null forNull

275+ k Boolean forBoolean

276+ k Number forNumber

277+ k String forString

278+ k Array forArray

279+ k Object forObject

281280 pure ()

282281

283282instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where

@@ -320,6 +319,7 @@ instance (forall x. BoundedMeetSemiLattice (f x))

320319 , forObject = top

321320 }

322321

322+{- TODO: remove

323323instance Typeable t => Steppable Schema (Condition t) where

324324 data Step Schema (Condition t)

325325 = EnumField

@@ -340,6 +340,11 @@ instance Typeable t => Steppable Schema (Condition t) where

340340 | NullableField

341341 | IntegerType -- type=integer

342342 deriving (Eq, Ord, Show)

343+-}

344+

345+instance Behavable 'SchemaLevel 'SchemaLevel where

346+ data Behave 'SchemaLevel 'SchemaLevel

347+ deriving (Eq, Ord, Show)

343348

344349instance Steppable Schema (Referenced Schema) where

345350 data Step Schema (Referenced Schema)

@@ -352,44 +357,42 @@ instance Steppable Schema (Referenced Schema) where

352357 | PropertiesStep Text

353358 deriving (Eq, Ord, Show)

354359

355−type ProcessM = ReaderT (Definitions Schema) (Writer (T.TracePrefixTree SubtreeCheckIssue OpenApi))

360+type ProcessM = ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))

356361

357−warn

358− :: (Subtree t, ComonadEnv (Trace OpenApi t) w)

359− => w x -> CheckIssue t -> ProcessM ()

360−warn t issue = tell $ T.singleton $ AnItem (ask t) $ SubtreeCheckIssue issue

362+warn :: Issue 'SchemaLevel -> ProcessM ()

363+warn issue = tell $ P.singleton $ AnItem Root $ AnIssue issue

361364

362365processRefSchema

363− :: Traced OpenApi (Referenced Schema)

364− -> ProcessM (ForeachType (JsonFormula OpenApi))

366+ :: Traced (Referenced Schema)

367+ -> ProcessM (ForeachType JsonFormula)

365368processRefSchema x = do

366369 defs <- R.ask

367370 processSchema $ dereference defs x

368371

369−tracedAllOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]

372+tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

370373tracedAllOf sch = _schemaAllOf (extract sch) <&> \xs ->

371374 [ traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0..] xs ]

372375

373−tracedAnyOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]

376+tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

374377tracedAnyOf sch = _schemaAnyOf (extract sch) <&> \xs ->

375378 [ traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0..] xs ]

376379

377−tracedOneOf :: Traced r Schema -> Maybe [Traced r (Referenced Schema)]

380+tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

378381tracedOneOf sch = _schemaOneOf (extract sch) <&> \xs ->

379382 [ traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0..] xs ]

380383

381−tracedItems :: Traced r Schema -> Maybe (Either (Traced r (Referenced Schema)) [Traced r (Referenced Schema)])

384+tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])

382385tracedItems sch = _schemaItems (extract sch) <&> \case

383386 OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x

384387 OpenApiItemsArray xs -> Right

385388 [ traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0..] xs ]

386389

387−tracedAdditionalProperties :: Traced r Schema -> Maybe (Either Bool (Traced r (Referenced Schema)))

390+tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))

388391tracedAdditionalProperties sch = _schemaAdditionalProperties (extract sch) <&> \case

389392 AdditionalPropertiesAllowed b -> Left b

390393 AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x

391394

392−tracedProperties :: Traced r Schema -> IOHM.InsOrdHashMap Text (Traced r (Referenced Schema))

395+tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))

393396tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (PropertiesStep k)))

394397 $ _schemaProperties $ extract sch

395398

@@ -397,35 +400,35 @@ tracedProperties sch = IOHM.mapWithKey (\k -> traced (ask sch >>> step (Properti

397400-- for every possible type of a JSON value. The conditions are independent, and

398401-- are thus checked independently.

399402processSchema

400− :: Traced OpenApi Schema

401− -> ProcessM (ForeachType (JsonFormula OpenApi))

403+ :: Traced Schema

404+ -> ProcessM (ForeachType JsonFormula)

402405processSchema sch@(extract -> Schema{..}) = do

403406 let

404− singletonFormula :: Typeable t => Step Schema (Condition t) -> Condition t -> JsonFormula OpenApi t

405− singletonFormula t f = SingleConjunct [traced (ask sch >>> step t) f]

407+ singletonFormula :: Condition t -> JsonFormula t

408+ singletonFormula f = SingleConjunct [f]

406409

407410 allClauses <- case tracedAllOf sch of

408411 Nothing -> pure []

409− Just [] -> [] <$ warn sch (InvalidSchema "no items in allOf")

412+ Just [] -> [] <$ warn (InvalidSchema "no items in allOf")

410413 Just xs -> mapM processRefSchema xs

411414

412415 anyClause <- case tracedAnyOf sch of

413416 Nothing -> pure top

414− Just [] -> bottom <$ warn sch (InvalidSchema "no items in anyOf")

417+ Just [] -> bottom <$ warn (InvalidSchema "no items in anyOf")

415418 Just xs -> joins <$> mapM processRefSchema xs

416419

417420 oneClause <- case tracedOneOf sch of

418421 Nothing -> pure top

419− Just [] -> bottom <$ warn sch (InvalidSchema "no items in oneOf")

422+ Just [] -> bottom <$ warn (InvalidSchema "no items in oneOf")

420423 Just xs -> do

421424 checkOneOfDisjoint xs >>= \case

422425 True -> pure ()

423− False -> warn sch (NotSupported "Could not determine that oneOf branches are disjoint")

426+ False -> warn (NotSupported "Could not determine that oneOf branches are disjoint")

424427 joins <$> mapM processRefSchema xs

425428

426429 case _schemaNot of

427430 Nothing -> pure ()

428− Just _ -> warn sch (NotSupported "not clause is unsupported")

431+ Just _ -> warn (NotSupported "not clause is unsupported")

429432

430433 let

431434 typeClause = case _schemaType of

@@ -437,7 +440,7 @@ processSchema sch@(extract -> Schema{..}) = do

437440 Just OpenApiNumber -> bottom

438441 { forBoolean = top }

439442 Just OpenApiInteger -> bottom

440− { forNumber = singletonFormula IntegerType $ MultipleOf 1 }

443+ { forNumber = singletonFormula $ MultipleOf 1 }

441444 Just OpenApiString -> bottom

442445 { forString = top }

443446 Just OpenApiArray -> bottom

@@ -447,27 +450,27 @@ processSchema sch@(extract -> Schema{..}) = do

447450

448451 let

449452 valueEnum A.Null = bottom

450− { forNull = singletonFormula EnumField $ Exactly TNull }

453+ { forNull = singletonFormula $ Exactly TNull }

451454 valueEnum (A.Bool b) = bottom

452− { forBoolean = singletonFormula EnumField $ Exactly $ TBool b }

455+ { forBoolean = singletonFormula $ Exactly $ TBool b }

453456 valueEnum (A.Number n) = bottom

454− { forNumber = singletonFormula EnumField $ Exactly $ TNumber n }

457+ { forNumber = singletonFormula $ Exactly $ TNumber n }

455458 valueEnum (A.String s) = bottom

456− { forString = singletonFormula EnumField $ Exactly $ TString s }

459+ { forString = singletonFormula $ Exactly $ TString s }

457460 valueEnum (A.Array a) = bottom

458− { forArray = singletonFormula EnumField $ Exactly $ TArray a }

461+ { forArray = singletonFormula $ Exactly $ TArray a }

459462 valueEnum (A.Object o) = bottom

460− { forObject = singletonFormula EnumField $ Exactly $ TObject o }

463+ { forObject = singletonFormula $ Exactly $ TObject o }

461464 enumClause <- case _schemaEnum of

462465 Nothing -> pure top

463− Just [] -> bottom <$ warn sch (InvalidSchema "no items in enum")

466+ Just [] -> bottom <$ warn (InvalidSchema "no items in enum")

464467 Just xs -> pure $ joins (valueEnum <$> xs)

465468

466469 let

467470 maximumClause = case _schemaMaximum of

468471 Nothing -> top

469472 Just n -> top

470− { forNumber = singletonFormula MaximumFields $ Maximum $

473+ { forNumber = singletonFormula $ Maximum $

471474 case _schemaExclusiveMaximum of

472475 Just True -> Exclusive n

473476 _ -> Inclusive n }

@@ -475,7 +478,7 @@ processSchema sch@(extract -> Schema{..}) = do

475478 minimumClause = case _schemaMinimum of

476479 Nothing -> top

477480 Just n -> top

478− { forNumber = singletonFormula MinimumFields $ Minimum $ Down $

481+ { forNumber = singletonFormula $ Minimum $ Down $

479482 case _schemaExclusiveMinimum of

480483 Just True -> Exclusive $ Down n

481484 _ -> Inclusive $ Down n }

@@ -483,53 +486,53 @@ processSchema sch@(extract -> Schema{..}) = do

483486 multipleOfClause = case _schemaMultipleOf of

484487 Nothing -> top

485488 Just n -> top

486− { forNumber = singletonFormula MultipleOfField $ MultipleOf n }

489+ { forNumber = singletonFormula $ MultipleOf n }

487490

488491 formatClause <- case _schemaFormat of

489492 Nothing -> pure top

490493 Just f | f `elem` ["int32", "int64", "float", "double"] -> pure top

491− { forNumber = singletonFormula FormatField $ NumberFormat f }

494+ { forNumber = singletonFormula $ NumberFormat f }

492495 Just f | f `elem` ["byte", "binary", "date", "date-time", "password"] -> pure top

493− { forString = singletonFormula FormatField $ StringFormat f }

494− Just f -> top <$ warn sch (NotSupported $ "Unknown format: " <> f)

496+ { forString = singletonFormula $ StringFormat f }

497+ Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)

495498

496499 let

497500 maxLengthClause = case _schemaMaxLength of

498501 Nothing -> top

499502 Just n -> top

500− { forString = singletonFormula MaxLengthField $ MaxLength n }

503+ { forString = singletonFormula $ MaxLength n }

501504

502505 minLengthClause = case _schemaMinLength of

503506 Nothing -> top

504507 Just n -> top

505− { forString = singletonFormula MinLengthField $ MinLength n }

508+ { forString = singletonFormula $ MinLength n }

506509

507510 patternClause = case _schemaPattern of

508511 Nothing -> top

509512 Just p -> top

510− { forString = singletonFormula PatternField $ Pattern p }

513+ { forString = singletonFormula $ Pattern p }

511514

512515 itemsClause <- case tracedItems sch of

513516 Nothing -> pure top

514517 Just (Left rs) -> do

515518 f <- processRefSchema rs

516− pure top { forArray = singletonFormula ItemsField $ Items f rs }

517− Just (Right _) -> top <$ warn sch (NotSupported "array in items is not supported")

519+ pure top { forArray = singletonFormula $ Items f rs }

520+ Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")

518521

519522 let

520523 maxItemsClause = case _schemaMaxItems of

521524 Nothing -> top

522525 Just n -> top

523− { forArray = singletonFormula MaxItemsField $ MaxItems n }

526+ { forArray = singletonFormula $ MaxItems n }

524527

525528 minItemsClause = case _schemaMinItems of

526529 Nothing -> top

527530 Just n -> top

528− { forArray = singletonFormula MinItemsField $ MinItems n }

531+ { forArray = singletonFormula $ MinItems n }

529532

530533 uniqueItemsClause = case _schemaUniqueItems of

531534 Just True -> top

532− { forArray = singletonFormula UniqueItemsField UniqueItems }

535+ { forArray = singletonFormula UniqueItems }

533536 _ -> top

534537

535538 (addProps, addPropSchema) <- case tracedAdditionalProperties sch of

@@ -546,10 +549,10 @@ processSchema sch@(extract -> Schema{..}) = do

546549 in pure (addProps, fromMaybe fakeSchema addPropSchema)

547550 pure (k, Property (k `elem` _schemaRequired) f psch)

548551 let

549− allBottom f = getAll $ foldType $ \ty -> case ty f of

552+ allBottom f = getAll $ foldType $ \_ ty -> case ty f of

550553 BottomFormula -> All True

551554 _ -> All False

552− allTop f = getAll $ foldType $ \ty -> case ty f of

555+ allTop f = getAll $ foldType $ \_ ty -> case ty f of

553556 TopFormula -> All True

554557 _ -> All False

555558 -- remove optional fields whose schemata match that of additional props

@@ -561,21 +564,21 @@ processSchema sch@(extract -> Schema{..}) = do

561564 = top -- if all fields are optional and have trivial schemata

562565 | otherwise

563566 = top

564− { forObject = singletonFormula PropertiesFields $ Properties propMap addProps addPropSchema }

567+ { forObject = singletonFormula $ Properties propMap addProps addPropSchema }

565568

566569 maxPropertiesClause = case _schemaMaxProperties of

567570 Nothing -> top

568571 Just n -> top

569− { forObject = singletonFormula MaxPropertiesField $ MaxProperties n }

572+ { forObject = singletonFormula $ MaxProperties n }

570573

571574 minPropertiesClause = case _schemaMinProperties of

572575 Nothing -> top

573576 Just n -> top

574− { forObject = singletonFormula MinPropertiesField $ MinProperties n }

577+ { forObject = singletonFormula $ MinProperties n }

575578

576579 nullableClause

577580 | Just True <- _schemaNullable = bottom

578− { forNull = singletonFormula NullableField $ Exactly TNull }

581+ { forNull = singletonFormula $ Exactly TNull }

579582 | otherwise = bottom

580583

581584 pure $ nullableClause \/ meets (allClauses <>

@@ -585,24 +588,24 @@ processSchema sch@(extract -> Schema{..}) = do

585588 , uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])

586589{- TODO: ReadOnly/WriteOnly -}

587590

588−checkOneOfDisjoint :: [Traced OpenApi (Referenced Schema)] -> ProcessM Bool

591+checkOneOfDisjoint :: [Traced (Referenced Schema)] -> ProcessM Bool

589592checkOneOfDisjoint = const $ pure True -- TODO

590593

591594schemaToFormula

592− :: Definitions Schema

593− -> Traced OpenApi Schema

594− -> (ForeachType (JsonFormula OpenApi), T.TracePrefixTree SubtreeCheckIssue OpenApi)

595+ :: Traced (Definitions Schema)

596+ -> Traced Schema

597+ -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

595598schemaToFormula defs rs = runWriter . (`runReaderT` defs) $ processSchema rs

596599

597600checkFormulas

598601 :: HasAll (CheckEnv Schema) xs

599602 => HList xs

600− -> Trace OpenApi Schema

601− -> ProdCons (ForeachType (JsonFormula OpenApi), T.TracePrefixTree SubtreeCheckIssue OpenApi)

603+ -> Behavior 'SchemaLevel

604+ -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

602605 -> CompatFormula ()

603−checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =

604− case T.toList ep ++ T.toList ec of

605− issues@(_:_) -> F.for_ issues $ \(AnItem t (SubtreeCheckIssue e)) -> issueAtTrace t e

606+checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =

607+ case P.toList ep ++ P.toList ec of

608+ issues@(_:_) -> F.for_ issues $ \(AnItem t (AnIssue e)) -> issueAt (beh >>> t) e

606609 [] -> do

607610 -- We have the following isomorphisms:

608611 -- (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)

@@ -631,120 +634,122 @@ checkFormulas env tr (ProdCons (fp, ep) (fc, ec)) =

631634 -- (⋃_i ⋂_j A[i,j]) ⊂ ∅ = /\_i (⋂_j A[i,j]) ⊂ ∅

632635 -- where we again delegate (⋂_j A[j]) ⊂ ∅ to a heuristic, though here the

633636 -- shortcut of \/_j A[j] ⊂ ∅ hardly helps.

634− forType_ $ \ty ->

637+ forType_ $ \tyName ty -> do

638+ let beh' = beh >>> step (OfType tyName)

635639 case (ty fp, ty fc) of

636− (DNF pss, BottomFormula) -> F.for_ pss $ \(Conjunct ps) -> checkContradiction tr ps

640+ (DNF pss, BottomFormula) -> F.for_ pss $ \(Conjunct ps) -> checkContradiction beh' ps

637641 (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do

638− F.for_ cs $ checkImplication env ps -- avoid disjuntion if there's only one conjunct

642+ F.for_ cs $ checkImplication env beh' ps -- avoid disjuntion if there's only one conjunct

639643 (DNF pss, DNF css) -> F.for_ pss $ \(Conjunct ps) -> do

640− anyOfM tr (NoMatchingCondition $ SomeCondition <$> ps)

641− [F.for_ cs $ checkImplication env ps | Conjunct cs <- S.toList css]

644+ anyOfAt beh' (NoMatchingCondition $ SomeCondition <$> ps)

645+ [F.for_ cs $ checkImplication env beh' ps | Conjunct cs <- S.toList css]

642646

643647checkContradiction

644− :: Trace OpenApi Schema

645− -> [Traced OpenApi (Condition t)]

648+ :: Behavior 'TypedSchemaLevel

649+ -> [Condition t]

646650 -> CompatFormula ()

647−checkContradiction tr _ = issueAtTrace tr NoContradiction -- TODO

651+checkContradiction beh _ = issueAt beh NoContradiction -- TODO

648652

649653checkImplication

650− :: (HasAll (CheckEnv Schema) xs, Typeable t)

654+ :: (HasAll (CheckEnv Schema) xs)

651655 => HList xs

652− -> [Traced OpenApi (Condition t)]

653− -> Traced OpenApi (Condition t)

656+ -> Behavior 'TypedSchemaLevel

657+ -> [Condition t]

658+ -> Condition t

654659 -> CompatFormula ()

655−checkImplication env prods cons = case findExactly prods of

660+checkImplication env beh prods cons = case findExactly prods of

656661 Just e

657− | all (satisfiesTyped e) (extract <$> prods) ->

658− if satisfiesTyped e $ extract cons then pure ()

659− else issueAt cons (EnumDoesntSatisfy e)

662+ | all (satisfiesTyped e) prods ->

663+ if satisfiesTyped e cons then pure ()

664+ else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

660665 | otherwise -> pure () -- vacuously true

661− Nothing -> case extract cons of

666+ Nothing -> case cons of

662667 -- the above code didn't catch it, so there's no Exactly condition on the lhs

663− Exactly e -> issueAt cons (NoMatchingEnum e)

668+ Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)

664669 Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of

665670 Just m' -> if m' <= m then pure ()

666− else issueAt cons (MatchingMaximumWeak m m')

667− Nothing -> issueAt cons (NoMatchingMaximum m)

671+ else issueAt beh (MatchingMaximumWeak m m')

672+ Nothing -> issueAt beh (NoMatchingMaximum m)

668673 Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of

669674 Just m' -> if m' >= m then pure ()

670− else issueAt cons (MatchingMinimumWeak (coerce m) (coerce m'))

671− Nothing -> issueAt cons (NoMatchingMinimum (coerce m))

675+ else issueAt beh (MatchingMinimumWeak (coerce m) (coerce m'))

676+ Nothing -> issueAt beh (NoMatchingMinimum (coerce m))

672677 MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of

673678 Just m' -> if lcmScientific m m' == m' then pure ()

674− else issueAt cons (MatchingMultipleOfWeak m m')

675− Nothing -> issueAt cons (NoMatchingMultipleOf m)

676− NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) $ extract <$> prods

677− then pure () else issueAt cons (NoMatchingFormat f)

679+ else issueAt beh (MatchingMultipleOfWeak m m')

680+ Nothing -> issueAt beh (NoMatchingMultipleOf m)

681+ NumberFormat f -> if any (\case NumberFormat f' -> f == f'; _ -> False) prods

682+ then pure () else issueAt beh (NoMatchingFormat f)

678683 MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of

679684 Just m' -> if m' <= m then pure ()

680− else issueAt cons (MatchingMaxLengthWeak m m')

681− Nothing -> issueAt cons (NoMatchingMaxLength m)

685+ else issueAt beh (MatchingMaxLengthWeak m m')

686+ Nothing -> issueAt beh (NoMatchingMaxLength m)

682687 MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of

683688 Just m' -> if m' >= m then pure ()

684− else issueAt cons (MatchingMinLengthWeak m m')

685− Nothing -> issueAt cons (NoMatchingMinLength m)

686− Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ extract <$> prods

687− then pure () else issueAt cons (NoMatchingPattern p)

688− StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ extract <$> prods

689− then pure () else issueAt cons (NoMatchingFormat f)

689+ else issueAt beh (MatchingMinLengthWeak m m')

690+ Nothing -> issueAt beh (NoMatchingMinLength m)

691+ Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) prods

692+ then pure () else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison

693+ StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) prods

694+ then pure () else issueAt beh (NoMatchingFormat f)

690695 Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of

691− Just (rs NE.:| []) -> checkCompatibility env $ ProdCons rs cons'

696+ Just (rs NE.:| []) -> checkCompatibility env (beh >>> step InItems) $ ProdCons rs cons'

692697 Just rs -> do

693698 let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ extract <$> rs }

694− checkCompatibility env $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace

695− Nothing -> issueAt cons NoMatchingItems

699+ checkCompatibility env (beh >>> step InItems) $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace

700+ Nothing -> issueAt beh NoMatchingItems

696701 MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of

697702 Just m' -> if m' <= m then pure ()

698− else issueAt cons (MatchingMaxItemsWeak m m')

699− Nothing -> issueAt cons (NoMatchingMaxItems m)

703+ else issueAt beh (MatchingMaxItemsWeak m m')

704+ Nothing -> issueAt beh (NoMatchingMaxItems m)

700705 MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of

701706 Just m' -> if m' >= m then pure ()

702− else issueAt cons (MatchingMinItemsWeak m m')

703− Nothing -> issueAt cons (NoMatchingMinItems m)

704− UniqueItems -> if any (== UniqueItems) $ extract <$> prods then pure ()

705− else issueAt cons NoMatchingUniqueItems

707+ else issueAt beh (MatchingMinItemsWeak m m')

708+ Nothing -> issueAt beh (NoMatchingMinItems m)

709+ UniqueItems -> if any (== UniqueItems) $ prods then pure ()

710+ else issueAt beh NoMatchingUniqueItems

706711 Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of

707712 Just ((props', madd') NE.:| []) -> do

708713 F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do

709− let go sch sch' = checkCompatibility env (ProdCons sch sch')

714+ let go sch sch' = checkCompatibility env (beh >>> step (InProperty k)) (ProdCons sch sch')

710715 case (M.lookup k props', madd', M.lookup k props, madd) of

711716 (Nothing, Nothing, _, _) -> pure () -- vacuously

712− (_, _, Nothing, Nothing) -> issueAt cons (UnexpectedProperty k)

717+ (_, _, Nothing, Nothing) -> issueAt beh (UnexpectedProperty k)

713718 (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)

714719 (Nothing, Just add', Just p, _) -> go add' (propRefSchema p)

715720 (Just p', _, Nothing, Just add) -> go (propRefSchema p') add

716721 (Nothing, Just _, Nothing, Just _) -> pure ()

717722 case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of

718− (False, True) -> issueAt cons (PropertyNowRequired k)

723+ (False, True) -> issueAt beh (PropertyNowRequired k)

719724 _ -> pure ()

720725 pure ()

721726 case (madd', madd) of

722727 (Nothing, _) -> pure () -- vacuously

723− (_, Nothing) -> issueAt cons NoAdditionalProperties

724− (Just add', Just add) -> checkCompatibility env (ProdCons add' add)

728+ (_, Nothing) -> issueAt beh NoAdditionalProperties

729+ (Just add', Just add) -> checkCompatibility env (beh >>> step InAdditionalProperty) (ProdCons add' add)

725730 pure ()

726− Nothing -> issueAt cons NoMatchingProperties

731+ Nothing -> issueAt beh NoMatchingProperties

727732 MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of

728733 Just m' -> if m' <= m then pure ()

729− else issueAt cons (MatchingMaxPropertiesWeak m m')

730− Nothing -> issueAt cons (NoMatchingMaxProperties m)

734+ else issueAt beh (MatchingMaxPropertiesWeak m m')

735+ Nothing -> issueAt beh (NoMatchingMaxProperties m)

731736 MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of

732737 Just m' -> if m' >= m then pure ()

733− else issueAt cons (MatchingMinPropertiesWeak m m')

734− Nothing -> issueAt cons (NoMatchingMinProperties m)

738+ else issueAt beh (MatchingMinPropertiesWeak m m')

739+ Nothing -> issueAt beh (NoMatchingMinProperties m)

735740 where

736− findExactly ((extract -> Exactly x):_) = Just x

741+ findExactly (Exactly x:_) = Just x

737742 findExactly (_:xs) = findExactly xs

738743 findExactly [] = Nothing

739744 findRelevant combine extr

740− = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extr . extract)

745+ = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr

741746 lcmScientific (toRational -> a) (toRational -> b)

742747 = fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

743748

744−instance Typeable t => Subtree (Condition t) where

745− data CheckIssue (Condition t)

746− = EnumDoesntSatisfy (TypedValue t)

747− | NoMatchingEnum (TypedValue t)

749+instance Issuable 'TypedSchemaLevel where

750+ data Issue 'TypedSchemaLevel

751+ = EnumDoesntSatisfy A.Value

752+ | NoMatchingEnum A.Value

748753 | NoMatchingMaximum (Bound Scientific)

749754 | MatchingMaximumWeak (Bound Scientific) (Bound Scientific)

750755 | NoMatchingMinimum (Bound Scientific)

@@ -771,29 +776,42 @@ instance Typeable t => Subtree (Condition t) where

771776 | MatchingMaxPropertiesWeak Integer Integer

772777 | NoMatchingMinProperties Integer

773778 | MatchingMinPropertiesWeak Integer Integer

779+ | NoMatchingCondition [SomeCondition]

780+ | NoContradiction

774781 deriving stock (Eq, Ord, Show)

775− type CheckEnv (Condition t) = CheckEnv Schema

776− normalizeTrace = undefined

777− checkCompatibility env pc = checkImplication env [producer pc] (consumer pc)

782+ issueIsUnsupported _ = False

778783

779−instance Subtree Schema where

780− data CheckIssue Schema

784+instance Issuable 'SchemaLevel where

785+ data Issue 'SchemaLevel

781786 = NotSupported Text

782787 | InvalidSchema Text

783− | NoMatchingCondition [SomeCondition]

784− | NoContradiction

785788 deriving stock (Eq, Ord, Show)

786− type CheckEnv Schema = '[ProdCons (Definitions Schema)]

787− checkCompatibility env schs = do

789+ issueIsUnsupported _ = True

790+

791+instance Behavable 'SchemaLevel 'TypedSchemaLevel where

792+ data Behave 'SchemaLevel 'TypedSchemaLevel

793+ = OfType JsonType

794+ deriving stock (Eq, Ord, Show)

795+

796+instance Behavable 'TypedSchemaLevel 'SchemaLevel where

797+ data Behave 'TypedSchemaLevel 'SchemaLevel

798+ = InItems

799+ | InProperty Text

800+ | InAdditionalProperty

801+ deriving stock (Eq, Ord, Show)

802+

803+instance Subtree Schema where

804+ type SubtreeLevel Schema = 'SchemaLevel

805+ type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]

806+ checkCompatibility env beh schs = do

788807 let defs = getH env

789− checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs

808+ checkFormulas env beh $ schemaToFormula <$> defs <*> schs

790809

791810instance Subtree (Referenced Schema) where

792− data CheckIssue (Referenced Schema)

793− deriving stock (Eq, Ord, Show)

811+ type SubtreeLevel (Referenced Schema) = 'SchemaLevel

794812 type CheckEnv (Referenced Schema) = CheckEnv Schema

795− checkCompatibility env refs = do

813+ checkCompatibility env beh refs = do

796814 let

797815 defs = getH env

798816 schs = dereference <$> defs <*> refs

799− checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs

817+ checkFormulas env beh $ schemaToFormula <$> defs <*> schs

src/OpenAPI/Checker/Validate/SecurityRequirement.hs+10−5

@@ -1,18 +1,23 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

33module OpenAPI.Checker.Validate.SecurityRequirement

4− ( CheckIssue (..)

4+ ( Issue (..)

55 ) where

77import Data.OpenApi

8+import OpenAPI.Checker.Behavior

89import OpenAPI.Checker.Subtree

910

11+instance Issuable 'SecurityRequirementLevel where

12+ data Issue 'SecurityRequirementLevel

13+ = SecurityRequirementNotMet

14+ deriving stock (Eq, Ord, Show)

15+ issueIsUnsupported _ = False

16+

1017instance Subtree SecurityRequirement where

18+ type SubtreeLevel SecurityRequirement = 'SecurityRequirementLevel

1119 type

1220 CheckEnv SecurityRequirement =

13− '[ ProdCons (Definitions SecurityScheme)

21+ '[ ProdCons (Traced (Definitions SecurityScheme))

1422 ]

15− data CheckIssue SecurityRequirement

16− = SecurityRequirementNotMet

17− deriving (Eq, Ord, Show)

1823 checkCompatibility = undefined

src/OpenAPI/Checker/Validate/Server.hs+50−36

@@ -1,7 +1,7 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

33module OpenAPI.Checker.Validate.Server

4− ( CheckIssue (..)

4+ ( Issue (..)

55 )

66where

@@ -20,41 +20,51 @@ import Data.OpenApi

2020import Data.Text (Text)

2121import qualified Data.Text as T

2222import Data.Traversable

23+import OpenAPI.Checker.Behavior

24+import OpenAPI.Checker.Paths

2325import OpenAPI.Checker.Subtree

24−import OpenAPI.Checker.Trace

26+import OpenAPI.Checker.Validate.MediaTypeObject

2527import Prelude as P

2628

2729tracedParsedServerUrlParts

28− :: Traced' r [Server] Server

29− -> Traced' r ProcessedServer (Either (CheckIssue ProcessedServer) ProcessedServer)

30+ :: Server

31+ -> Either (Issue 'ServerLevel) ProcessedServer

3032tracedParsedServerUrlParts s =

31− let rawURL = _serverUrl $ extract s

32− parsedUrl = parseServerUrl rawURL

33− serverVariables = _serverVariables $ extract s

34− in traced (ask s >>> step (ServerStep rawURL)) $

35− parsedUrl

36− & (traverse . traverse)

37− (\var -> case IOHM.lookup var serverVariables of

38− Nothing -> Left VariableNotDefined

39− Just x -> Right x)

33+ let parsedUrl = parseServerUrl $ _serverUrl s

34+ lookupVar var = case IOHM.lookup var (_serverVariables s) of

35+ Nothing -> Left $ ServerVariableNotDefined var

36+ Just x -> Right x

37+ in (traverse @[] . traverse @ServerUrlPart) lookupVar parsedUrl

38+

39+instance Behavable 'OperationLevel 'ServerLevel where

40+ data Behave 'OperationLevel 'ServerLevel

41+ = InServer Text

42+ deriving stock (Eq, Ord, Show)

4043

4144instance Subtree [Server] where

45+ type SubtreeLevel [Server] = 'OperationLevel

4246 type CheckEnv [Server] = '[]

43− data CheckIssue [Server]

44− deriving (Eq, Ord, Show)

45− checkCompatibility env pcServer = do

47+ checkCompatibility env beh pcServer = do

4648 let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =

47− pcServer <&> partitionEithers . fmap (bicosequence . tracedParsedServerUrlParts) . sequence

48− bicosequence :: Comonad f => f (Either a b) -> Either (f a) (f b)

49− bicosequence x = case extract x of

50− Left e -> Left $ x $> e

51− Right a -> Right $ x $> a

52− throwAllErrors = traverse_ tracedIssue

53− throwAllErrors pErrs

54− throwAllErrors cErrs

55− for_ pUrls $ \cUrl -> do

56− let potentiallyCompatible = P.filter ((staticCompatible `on` extract) cUrl) cUrls

57− anyOfSubtreeAt cUrl ServerNotMatched $ potentiallyCompatible <&> (checkCompatibility env . ProdCons cUrl)

49+ pcServer

50+ <&> partitionEithers

51+ . fmap

52+ (\(Traced t s) ->

53+ let bhv = beh >>> step (InServer $ _serverUrl s)

54+ in case tracedParsedServerUrlParts s of

55+ Left e -> Left $ issueAt bhv e

56+ Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u))

57+ . sequence

58+ sequenceA_ pErrs

59+ sequenceA_ cErrs

60+ for_ pUrls $ \(bhv, pUrl) -> do

61+ let potentiallyCompatible = P.filter ((staticCompatible `on` extract) pUrl) $ fmap snd cUrls

62+ anyOfAt

63+ bhv

64+ ServerNotMatched

65+ [ checkCompatibility env bhv (ProdCons pUrl cUrl)

66+ | cUrl <- potentiallyCompatible

67+ ]

5868 pure ()

5969

6070type ProcessedServer = [ServerUrlPart ServerVariable]

@@ -108,22 +118,26 @@ instance Steppable [Server] ProcessedServer where

108118 data Step [Server] ProcessedServer = ServerStep Text

109119 deriving (Eq, Ord, Show)

110120

121+instance Issuable 'ServerLevel where

122+ data Issue 'ServerLevel

123+ = EnumValueNotConsumed Int Text

124+ | ConsumerNotOpen Int

125+ | ServerVariableNotDefined Text

126+ | ServerNotMatched

127+ deriving stock (Eq, Ord, Show)

128+ issueIsUnsupported _ = False

129+

111130instance Subtree ProcessedServer where

131+ type SubtreeLevel ProcessedServer = 'ServerLevel

112132 type CheckEnv ProcessedServer = '[]

113− data CheckIssue ProcessedServer

114− = VariableNotDefined

115− | ServerNotMatched

116− | EnumValueNotConsumed Int Text

117− | ConsumerNotOpen Int

118− deriving (Eq, Ord, Show)

119− checkCompatibility _ pc@(ProdCons p _) =

133+ checkCompatibility _ beh pc =

120134 -- traversing here is fine because we have already filtered for length

121135 for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of

122− (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt p $ EnumValueNotConsumed i v)

136+ (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt beh $ EnumValueNotConsumed i v)

123137 -- Consumer can consume anything

124138 (_, Nothing) -> pure ()

125139 -- Producer can produce anythings, but consumer has a finite enum ;(

126− (Nothing, Just _) -> issueAt p (ConsumerNotOpen i)

140+ (Nothing, Just _) -> issueAt beh (ConsumerNotOpen i)

127141 where

128142 zipProdCons :: ProdCons [a] -> [(a, a)]

129143 zipProdCons (ProdCons x y) = zip x y

src/OpenAPI/Checker/Validate/Sums.hs+11−13

@@ -5,22 +5,20 @@ module OpenAPI.Checker.Validate.Sums

55import Data.Foldable

66import Data.Map.Strict (Map)

77import qualified Data.Map.Strict as M

8+import OpenAPI.Checker.Behavior

89import OpenAPI.Checker.Subtree

9−import OpenAPI.Checker.Trace

10−

10+import OpenAPI.Checker.Paths

1111

1212checkSums

13− :: forall k r t

14− . (Ord k, Subtree t)

15− => (k -> CheckIssue t)

16− -> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())

17− -> ProdCons (Map k (Traced r t))

18− -> CompatFormula' SubtreeCheckIssue r ()

19−checkSums noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

13+ :: (Ord k, Issuable l)

14+ => Paths q r l

15+ -> (k -> Issue l)

16+ -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())

17+ -> ProdCons (Map k t)

18+ -> CompatFormula' q AnIssue r ()

19+checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

2020 case M.lookup key c of

21− Nothing -> issueAt prodElt $ noElt key

21+ Nothing -> issueAt xs $ noElt key

2222 Just consElt ->

23− let

24− sumElts :: ProdCons (Traced r t)

25− sumElts = ProdCons prodElt consElt

23+ let sumElts = ProdCons prodElt consElt

2624 in check key sumElts

test/Spec/Golden/TraceTree.hs+2−2

@@ -7,7 +7,7 @@ import Control.Category

77import Data.HList

88import qualified Data.Yaml as Yaml

99import OpenAPI.Checker.Subtree

10−import OpenAPI.Checker.Trace

10+import OpenAPI.Checker.Paths

1111import OpenAPI.Checker.Validate.OpenApi ()

1212import Spec.Golden.Extra

1313import Test.Tasty (TestTree)

@@ -21,4 +21,4 @@ tests =

2121 "trace-tree.yaml"

2222 ("a.yaml", "b.yaml")

2323 Yaml.decodeFileThrow

24− (runCompatFormula . checkCompatibility HNil . fmap (traced Root) . uncurry ProdCons)

24+ (runCompatFormula . checkCompatibility HNil Root . fmap (traced Root) . uncurry ProdCons)

test/golden/common/maximum-lowered/trace-tree.yaml+6−9

@@ -1,10 +1,7 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationRequestBodyStep:

6− InlineStep:

7− RequestMediaTypeObject application/json:

8− MediaTypeSchema:

9− ReferencedStep (Reference {getReference = "Test"}):

10− MaximumFields: MatchingMaximumWeak (Inclusive 2.0) (Inclusive 3.0)

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ InRequest:

5+ InPayload:

6+ PayloadSchema:

7+ OfType Number: MatchingMaximumWeak (Inclusive 2.0) (Inclusive 3.0)

test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/trace-tree.yaml+3−5

@@ -1,6 +1,4 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationParamsStep 0:

6− InlineStep: ParamEmptinessIncompatible

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ InParam "test1": ParamEmptinessIncompatible

test/golden/common/pathItem/operation/parameters/change/trace-tree.yaml+5−7

@@ -1,8 +1,6 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationParamsStep 0:

6− InlineStep:

7− ParamSchema:

8− InlineStep: NoContradiction

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ InParam "test":

5+ InParamSchema:

6+ OfType String: NoContradiction

test/golden/common/pathItem/operation/parameters/required/set/trace-tree.yaml+3−5

@@ -1,6 +1,4 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationParamsStep 0:

6− InlineStep: ParamRequired

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ InParam "test1": ParamRequired

test/golden/common/pathItem/operation/parameters/required/true/add/trace-tree.yaml+2−5

@@ -1,6 +1,3 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationParamsStep 1:

6− InlineStep: ParamNotMatched "test2"

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod: ParamNotMatched "test2"

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/trace-tree.yaml+6−8

@@ -1,9 +1,7 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationRequestBodyStep:

6− InlineStep:

7− RequestMediaTypeObject application/json:

8− MediaTypeSchema:

9− InlineStep: NoContradiction

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ InRequest:

5+ InPayload:

6+ PayloadSchema:

7+ OfType String: NoContradiction

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/trace-tree.yaml+3−6

@@ -1,7 +1,4 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationRequestBodyStep:

6− InlineStep:

7− RequestMediaTypeObject application/x-www-form-urlencoded: RequestMediaTypeNotFound

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ InRequest: RequestMediaTypeNotFound application/x-www-form-urlencoded

test/golden/common/pathItem/operation/requestBody/required/set/trace-tree.yaml+3−5

@@ -1,6 +1,4 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationRequestBodyStep:

6− InlineStep: RequestBodyRequired

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ InRequest: RequestBodyRequired

test/golden/common/pathItem/operation/responses/add/trace-tree.yaml+2−6

@@ -1,7 +1,3 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationResponsesStep:

6− ResponseCodeStep 500:

7− InlineStep: ResponseCodeNotFound

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod: ResponseCodeNotFound 500

test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/trace-tree.yaml+3−8

@@ -1,9 +1,4 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationResponsesStep:

6− ResponseCodeStep 200:

7− InlineStep:

8− ResponseHeader "Test2":

9− InlineStep: ResponseHeaderMissing

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ WithStatusCode 200: ResponseHeaderMissing "Test2"

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/trace-tree.yaml+3−7

@@ -1,8 +1,4 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationResponsesStep:

6− ResponseCodeStep 200:

7− InlineStep:

8− ResponseMediaObject application/x-www-form-urlencoded: ResponseMediaTypeMissing

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ WithStatusCode 200: ResponseMediaTypeMissing application/x-www-form-urlencoded

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/trace-tree.yaml+6−9

@@ -1,10 +1,7 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationResponsesStep:

6− ResponseCodeStep 200:

7− InlineStep:

8− ResponseMediaObject application/json:

9− MediaTypeSchema:

10− InlineStep: NoContradiction

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ WithStatusCode 200:

5+ ResponsePayload:

6+ PayloadSchema:

7+ OfType Boolean: NoContradiction

test/golden/common/property-removed/trace-tree.yaml+10−16

@@ -1,17 +1,11 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationResponsesStep:

6− ResponseCodeStep 200:

7− InlineStep:

8− ResponseMediaObject application/json:

9− MediaTypeSchema:

10− ReferencedStep (Reference {getReference = "Test"}):

11− PropertiesFields: PropertyNowRequired "property2"

12− OperationRequestBodyStep:

13− InlineStep:

14− RequestMediaTypeObject application/json:

15− MediaTypeSchema:

16− ReferencedStep (Reference {getReference = "Test"}):

17− PropertiesFields: UnexpectedProperty "property2"

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ InRequest:

5+ InPayload:

6+ PayloadSchema:

7+ OfType Object: UnexpectedProperty "property2"

8+ WithStatusCode 200:

9+ ResponsePayload:

10+ PayloadSchema:

11+ OfType Object: PropertyNowRequired "property2"

test/golden/common/property-required/trace-tree.yaml+6−9

@@ -1,10 +1,7 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationRequestBodyStep:

6− InlineStep:

7− RequestMediaTypeObject application/json:

8− MediaTypeSchema:

9− ReferencedStep (Reference {getReference = "Test"}):

10− PropertiesFields: PropertyNowRequired "property2"

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3+ InOperation PostMethod:

4+ InRequest:

5+ InPayload:

6+ PayloadSchema:

7+ OfType Object: PropertyNowRequired "property2"

test/golden/common/servers/trace-tree.yaml+6−8

@@ -1,9 +1,7 @@

11Left:

2− OpenApiPathsStep:

3− MatchedPathStep "/pets":

4− OperationMethodStep GetMethod:

5− OperationServersStep:

6− ServerStep "http://missing.url": ServerNotMatched

7− ServerStep "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":

8− - EnumValueNotConsumed 1 "a"

9− - ConsumerNotOpen 7

2+ AtPath (ProdCons {producer = "/pets", consumer = "/pets"}):

3+ InOperation GetMethod:

4+ InServer "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":

5+ - EnumValueNotConsumed 1 "a"

6+ - ConsumerNotOpen 7

7+ InServer "http://missing.url": ServerNotMatched