8687e5f · compaREST · git.iko.soy

git.iko.soy/compaREST

on master help sign in

Traces (#50)

8687e5fmniip5 years ago

openapi-diff.cabal+3−2

compare with master

unifiedsplit

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

98 import: common-options

99 hs-source-dirs: src

100 exposed-modules: Data.HList

101+ , OpenAPI.Checker.Behavior

101 , OpenAPI.Checker.Formula

102 , OpenAPI.Checker.Formula

102 , OpenAPI.Checker.Memo

103 , OpenAPI.Checker.Memo

103 , OpenAPI.Checker.Options

104 , OpenAPI.Checker.Options

104 , OpenAPI.Checker.Orphans

105 , OpenAPI.Checker.Orphans

106+ , OpenAPI.Checker.Paths

107+ , OpenAPI.Checker.PathsPrefixTree

105 , OpenAPI.Checker.References

108 , OpenAPI.Checker.References

106 , OpenAPI.Checker.Run

109 , OpenAPI.Checker.Run

107 , OpenAPI.Checker.Subtree

110 , OpenAPI.Checker.Subtree

108− , OpenAPI.Checker.Trace

109− , OpenAPI.Checker.TracePrefixTree

110 , OpenAPI.Checker.Validate.MediaTypeObject

111 , OpenAPI.Checker.Validate.MediaTypeObject

111 , OpenAPI.Checker.Validate.OpenApi

112 , OpenAPI.Checker.Validate.OpenApi

112 , OpenAPI.Checker.Validate.Operation

113 , 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

12import Data.Kind

13import Data.Monoid

14import qualified Data.List.NonEmpty as NE

15−import OpenAPI.Checker.Trace

15+import OpenAPI.Checker.Paths

16−import qualified OpenAPI.Checker.TracePrefixTree as T

16+import qualified OpenAPI.Checker.PathsPrefixTree as P

18type VarRef = Int

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

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

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

23-- 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

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

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

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

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

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

27 -- ^ 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

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

30 -- both not 'Result'

31 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

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

34 -- 'SelectFirst'

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

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

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

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

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

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

41mkApply f x h = Apply f x h

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

44mkSelectFirst fs allE h = case foldMap check fs of

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

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

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

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

48 where

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

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

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

53 check x = (mempty, [x])

55data SomeFormulaF (a :: Type) where

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

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

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

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

59−anError e = Errors $ T.singleton e

59+anError e = Errors $ P.singleton e

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

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

62errors t

63− | T.null t = Result ()

63+ | P.null t = Result ()

64 | otherwise = Errors t

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

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

67variable v = Variable v ()

69−instance Functor (FormulaF f r) where

69+instance Functor (FormulaF q f r) where

70 fmap f (Result x) = Result (f x)

71 fmap _ (Errors e) = Errors e

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

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

76instance Functor SomeFormulaF where

77 fmap f (SomeFormulaF x) = SomeFormulaF (fmap f x)

79−instance Applicative (FormulaF f r) where

79+instance Applicative (FormulaF q f r) where

80 pure = Result

81 f <*> x = mkApply f x id

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

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

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

87calculate (Result x) = Right x

88calculate (Errors e) = Left e

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

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

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

99 Left _ -> go rs

100 Right x -> Right (h x)

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

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

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

103

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

105-- super accurate. TODO: improve

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

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

107maxFixpoint i = go

108 where

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

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

110 go (Result x) = Result x

111 go (Errors e) = Errors e

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

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

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

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

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

3+module OpenAPI.Checker.Orphans () where

5import Control.Comonad.Env

6import Data.OpenApi

7−import Data.Typeable

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

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

9−import OpenAPI.Checker.Trace

11deriving newtype instance Ord Reference

9deriving newtype instance Ord Reference

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−

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

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

20deriving stock instance Ord Schema

12deriving stock instance Ord Schema

21deriving stock instance Ord AdditionalProperties

13deriving stock instance Ord AdditionalProperties

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

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

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

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

3-- structure.

4−module OpenAPI.Checker.Trace

4+module OpenAPI.Checker.Paths

5− ( Steppable (..)

5+ ( NiceQuiver

6− , Trace (..)

6+ , Paths (..)

7− , DiffTrace (..)

7+ , DiffPaths (..)

8− , catDiffTrace

8+ , catDiffPaths

9− , _DiffTrace

9+ , _DiffPaths

10 , AnItem (..)

11 , step

12− , Traced

13− , Traced'

14− , traced

16 -- * Reexports

13 -- * Reexports

17 , (>>>)

14 , (>>>)

18 , (<<<)

15 , (<<<)

19− , extract

20− , ask

21− , asks

22− , local

23 )

16 )

24where

17where

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

31import Type.Reflection

24import Type.Reflection

32import Prelude hiding ((.))

25import Prelude hiding ((.))

34−class

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

27+type NiceQuiver q a b = (Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q 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

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

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

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

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

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

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

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

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

45− Root :: Trace a a

35+ Root :: Paths q a a

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

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

47−

48−deriving stock instance Show (Trace a b)

50infixl 5 `Snoc`

38infixl 5 `Snoc`

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

53step s = Root `Snoc` s

43step s = Root `Snoc` s

55−instance Category Trace where

45+instance Category (Paths q) where

56 id = Root

46 id = Root

57 Root . xs = xs

47 Root . xs = xs

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

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

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

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

61typeRepRHS _ = typeRep

51typeRepRHS _ = typeRep

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

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

64typeRepLHS Root = typeRep

54typeRepLHS Root = typeRep

65typeRepLHS (Snoc xs _) = typeRepLHS xs

55typeRepLHS (Snoc xs _) = typeRepLHS xs

67−instance TestEquality (Trace a) where

57+instance TestEquality (Paths q a) where

68 testEquality Root Root = Just Refl

58 testEquality Root Root = Just Refl

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

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

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

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

71 testEquality (Snoc _ _) (Snoc _ _) = testEquality typeRep typeRep

61 testEquality (Snoc _ _) (Snoc _ _) = testEquality typeRep typeRep

73−instance Eq (Trace a b) where

63+instance Eq (Paths q a b) where

74 Root == Root = True

64 Root == Root = True

75 Snoc xs x == Snoc ys y

65 Snoc xs x == Snoc ys y

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

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

77 xs == ys && x == y

67 xs == ys && x == y

78 _ == _ = False

68 _ == _ = False

80−instance Ord (Trace a b) where

70+instance Ord (Paths q a b) where

81 compare Root Root = EQ

71 compare Root Root = EQ

82 compare Root (Snoc _ _) = LT

72 compare Root (Snoc _ _) = LT

83 compare (Snoc _ _) Root = GT

73 compare (Snoc _ _) Root = GT

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

103

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

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

105

106−instance Eq (AnItem f r) where

96+instance Eq (AnItem q f r) where

107 AnItem xs fx == AnItem ys fy

97 AnItem xs fx == AnItem ys fy

108 | Just Refl <- testEquality xs ys =

98 | Just Refl <- testEquality xs ys =

109 xs == ys && fx == fy

99 xs == ys && fx == fy

110 _ == _ = False

100 _ == _ = False

111

101

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

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

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

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

114 case testEquality xs ys of

104 case testEquality xs ys of

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

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

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

120 Snoc _ _ -> case ys of

110 Snoc _ _ -> case ys of

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

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

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

112 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 @@

1{-# LANGUAGE QuantifiedConstraints #-}

3−module OpenAPI.Checker.TracePrefixTree

3+module OpenAPI.Checker.PathsPrefixTree

4− ( TracePrefixTree

4+ ( PathsPrefixTree

5 , empty

6 , singleton

7 , fromList

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

9 , foldWith

10 , toList

11 , filter

12+ , embed

12 )

13 )

13where

14where

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

24import qualified Data.TypeRepMap as TRM

25import qualified Data.TypeRepMap as TRM

25import qualified Data.Vector as V

26import qualified Data.Vector as V

26import qualified GHC.Exts as TRM

27import qualified GHC.Exts as TRM

27−import OpenAPI.Checker.Trace

28+import OpenAPI.Checker.Paths

28import Type.Reflection

29import Type.Reflection

29import Prelude hiding (filter, null)

30import Prelude hiding (filter, null)

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

32-- | 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

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

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

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

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

35 }

36 }

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

38 toJSON =

39 toJSON =

39 Object . getMergableObject

40 Object . getMergableObject

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

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

42−deriving instance Eq (TracePrefixTree f a)

43+deriving instance Eq (PathsPrefixTree q f a)

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

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

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

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

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

69 M.fromList

70 M.fromList

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

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

72−instance Ord (TracePrefixTree f a) where

73+instance Ord (PathsPrefixTree q f a) where

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

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

74 compare r1 r2 <> compareTRM s1 s2

75 compare r1 r2 <> compareTRM s1 s2

76data ASet (a :: Type) where

77data ASet (a :: Type) where

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

97instance Monoid (ASet a) where

98instance Monoid (ASet a) where

98 mempty = AnEmptySet

99 mempty = AnEmptySet

100

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

101 AStep

102 AStep

102− :: Steppable r a =>

103+ :: NiceQuiver q r a =>

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

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

104− -> AStep f r a

105+ -> AStep q f r a

105

106

106−deriving instance Eq (AStep f r a)

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

107

108

108−deriving instance Ord (AStep f r a)

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

109

110

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

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

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

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

112 where

113 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

114 go Root !t = t

115 go Root !t = t

115 go (Snoc xs x) !t =

116 go (Snoc xs x) !t =

116 go xs $

117 go xs $

117− TracePrefixTree AnEmptySet $

118+ PathsPrefixTree AnEmptySet $

118 TRM.one $

119 TRM.one $

119 AStep $ M.singleton x t

120 AStep $ M.singleton x t

120

121

121−instance Semigroup (TracePrefixTree f r) where

122+instance Semigroup (PathsPrefixTree q f r) where

122− TracePrefixTree r1 s1 <> TracePrefixTree r2 s2 =

123+ PathsPrefixTree r1 s1 <> PathsPrefixTree r2 s2 =

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

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

124 where

125 where

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

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

126

127

127−instance Monoid (TracePrefixTree f r) where

128+instance Monoid (PathsPrefixTree q f r) where

128− mempty = TracePrefixTree mempty TRM.empty

129+ mempty = PathsPrefixTree mempty TRM.empty

129

130

130−empty :: TracePrefixTree f r

131+empty :: PathsPrefixTree q f r

131empty = mempty

132empty = mempty

132

133

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

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

134fromList = foldMap singleton

135fromList = foldMap singleton

135

136

136−null :: TracePrefixTree f r -> Bool

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

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

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

138null _ = False

139null _ = False

139

140

140foldWith

141foldWith

141− :: forall f m r.

142+ :: forall q f m r.

142 Monoid m

143 Monoid m

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

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

144− -> TracePrefixTree f r

145+ -> PathsPrefixTree q f r

145 -> m

146 -> m

146foldWith k = goTPT Root

147foldWith k = goTPT Root

147 where

148 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

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

150 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

151 goASet _ AnEmptySet = mempty

152 goASet _ AnEmptySet = mempty

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

153 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

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

155 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

156 goAStep xs (AStep m) =

157 goAStep xs (AStep m) =

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

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

158

159

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

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

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

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

161

162

162-- | Select a subtree by prefix

163-- | 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

164filter Root t = t

165filter Root t = t

165filter (Snoc xs x) t =

166filter (Snoc xs x) t =

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

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

167 TRM.lookup $ snocItems $ filter xs t

168 TRM.lookup $ snocItems $ filter xs t

168

169

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+

169newtype MergableObject = MergableObject {getMergableObject :: Object}

175newtype MergableObject = MergableObject {getMergableObject :: Object}

170

176

171instance Semigroup MergableObject where

177instance Semigroup MergableObject where

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

183instance Monoid MergableObject where

189instance Monoid MergableObject where

184 mempty = MergableObject mempty

190 mempty = MergableObject mempty

185

191

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

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

187traceObject Root (Object o) = o

193traceObject Root (Object o) = o

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

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

189traceObject (root `Snoc` s) v =

195traceObject (root `Snoc` s) v =

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

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

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

1module OpenAPI.Checker.References

2module OpenAPI.Checker.References

2− ( TracedReferences

3+ ( Step (..)

3 , dereference

4 , dereference

4 )

5 )

5where

6where

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

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

8−import Data.Map (Map)

9import Data.Maybe

10import Data.OpenApi

11import Data.Typeable

12−import OpenAPI.Checker.Orphans

12+import OpenAPI.Checker.Orphans ()

13−import OpenAPI.Checker.Trace

13+import OpenAPI.Checker.Subtree

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)

17dereference

23dereference

18 :: Typeable a

24 :: Typeable a

19− => Definitions a

25+ => Traced (Definitions a)

20− -> Traced r (Referenced a)

26+ -> Traced (Referenced a)

21− -> Traced r a

27+ -> Traced a

22dereference defs x = case extract x of

28dereference defs x = case extract x of

23 Inline a

29 Inline a

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

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

25 Ref r@(Reference ref)

31 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

6import qualified Data.Yaml as Yaml

7import OpenAPI.Checker.Options

8import OpenAPI.Checker.Subtree

9−import OpenAPI.Checker.Trace

9+import OpenAPI.Checker.Paths

10import OpenAPI.Checker.Validate.OpenApi ()

11import Prelude hiding (id, (.))

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

26 Right s -> pure s

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

28 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)

30 BSC.putStrLn $ Yaml.encode report

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

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

1module OpenAPI.Checker.Subtree

2− ( APIStep (..)

2+ ( Steppable (..)

3+ , Trace

4+ , Traced

5+ , Traced'

6+ , pattern Traced

7+ , traced

3 , Subtree (..)

8 , Subtree (..)

4 , CompatM (..)

9 , CompatM (..)

5 , CompatFormula'

10 , CompatFormula'

6 , CompatFormula

11 , CompatFormula

7 , ProdCons (..)

12 , ProdCons (..)

8− , anyOfSubtreeAt

9 , HasUnsupportedFeature (..)

13 , HasUnsupportedFeature (..)

10 , swapProdCons

14 , swapProdCons

11− , SubtreeCheckIssue (..)

12 , runCompatFormula

15 , runCompatFormula

13− , anyOfM

14− , anyOfAt

15− , issueAtTrace

16 , issueAt

17− , tracedIssue

17+ , anyOfAt

18 , memo

19+

20+ -- * Reexports

21+ , (>>>)

22+ , (<<<)

23+ , extract

24+ , ask

25+ , local

26+ , step

19 )

27 )

20where

28where

22import Control.Comonad.Env

30import Control.Comonad.Env

23import Control.Monad.Identity

31import Control.Monad.Identity

24import Control.Monad.State

32import Control.Monad.State

25−import Data.Aeson

26import Data.Functor.Compose

33import Data.Functor.Compose

27import Data.HList

34import Data.HList

28import Data.Kind

35import Data.Kind

29import Data.Monoid

36import Data.Monoid

30import Data.OpenApi

37import Data.OpenApi

31−import Data.Text

32import Data.Typeable

38import Data.Typeable

39+import OpenAPI.Checker.Behavior

33import OpenAPI.Checker.Formula

40import OpenAPI.Checker.Formula

34import OpenAPI.Checker.Memo

41import OpenAPI.Checker.Memo

35−import OpenAPI.Checker.Trace

42+import OpenAPI.Checker.Paths

36−import qualified OpenAPI.Checker.TracePrefixTree as T

43+import qualified OpenAPI.Checker.PathsPrefixTree as P

38class

45class

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

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

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

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

41 where

48 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

44data ProdCons a = ProdCons

66data ProdCons a = ProdCons

45 { producer :: a

67 { producer :: a

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

57newtype CompatM a = CompatM

79newtype CompatM a = CompatM

58 { unCompatM

80 { unCompatM

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

81+ :: StateT (MemoState VarRef) Identity a

60 }

82 }

61 deriving newtype

83 deriving newtype

62 ( Functor

84 ( Functor

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

65 , MonadState (MemoState VarRef)

87 , MonadState (MemoState VarRef)

66 )

88 )

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

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

70−type CompatFormula = CompatFormula' SubtreeCheckIssue OpenApi

92+type CompatFormula = CompatFormula' Behave AnIssue 'APILevel

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

73 type CheckEnv t :: [Type]

95 type CheckEnv t :: [Type]

74− data CheckIssue t :: Type

96+ type SubtreeLevel t :: BehaviorLevel

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

83 checkCompatibility

98 checkCompatibility

84 :: HasAll (CheckEnv t) xs

99 :: HasAll (CheckEnv t) xs

85 => HList xs

100 => HList xs

101+ -> Behavior (SubtreeLevel t)

86− -> ProdCons (Traced OpenApi t)

102+ -> ProdCons (Traced t)

87 -> CompatFormula ()

103 -> CompatFormula ()

104

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

90−

91class HasUnsupportedFeature x where

105class HasUnsupportedFeature x where

92 hasUnsupportedFeature :: x -> Bool

106 hasUnsupportedFeature :: x -> Bool

107

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

101 hasUnsupportedFeature (Left x) = hasUnsupportedFeature x

115 hasUnsupportedFeature (Left x) = hasUnsupportedFeature x

102 hasUnsupportedFeature (Right x) = hasUnsupportedFeature x

116 hasUnsupportedFeature (Right x) = hasUnsupportedFeature x

103

117

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

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

105 hasUnsupportedFeature = issueIsUnsupported

119 hasUnsupportedFeature = issueIsUnsupported

106

120

121+instance HasUnsupportedFeature (AnIssue l) where

122+ hasUnsupportedFeature (AnIssue issue) = hasUnsupportedFeature issue

123+

107instance

124instance

108 (forall x. HasUnsupportedFeature (f x))

125 (forall x. HasUnsupportedFeature (f x))

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

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

110 where

127 where

111 hasUnsupportedFeature =

128 hasUnsupportedFeature =

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

129+ getAny . P.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

130

130runCompatFormula

131runCompatFormula

131− :: CompatFormula' f r a

132+ :: CompatFormula' q f r a

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

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

133runCompatFormula (Compose f) =

134runCompatFormula (Compose f) =

134 calculate . runIdentity . runMemo 0 . unCompatM $ f

135 calculate . runIdentity . runMemo 0 . unCompatM $ f

135

136

136−issueAtTrace

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

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

138+issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ AnIssue 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)

164

139

165anyOfAt

140anyOfAt

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

141+ :: Issuable l

167− => w x

142+ => Paths q r l

168− -> CheckIssue t

143+ -> Issue l

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]

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

178− -> CompatFormula' SubtreeCheckIssue r a

145+ -> CompatFormula' q AnIssue r a

179−anyOfSubtreeAt _ _ [x] = x

146+anyOfAt _ _ [x] = x

180−anyOfSubtreeAt f i fs = anyOfAt f i fs

147+anyOfAt xs issue fs =

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

181

149

182fixpointKnot

150fixpointKnot

183 :: MonadState (MemoState VarRef) m

151 :: MonadState (MemoState VarRef) m

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

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

185fixpointKnot =

153fixpointKnot =

186 KnotTier

154 KnotTier

187 { onKnotFound = modifyMemoNonce succ

155 { onKnotFound = modifyMemoNonce succ

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

190 }

158 }

191

159

192memo

160memo

193− :: (Typeable r, Subtree t)

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

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

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

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

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

196memo f pc = Compose $ do

164memo f pc = Compose $ do

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

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

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

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

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

3module OpenAPI.Checker.Validate.MediaTypeObject

4− ( CheckIssue(..)

4+ ( Issue(..)

5+ , Behave(..)

5 ) where

6 ) where

7import Control.Lens

8import Control.Lens

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

12import Data.OpenApi

13import Data.OpenApi

13import Data.Text (Text)

14import Data.Text (Text)

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

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

16+import OpenAPI.Checker.Behavior

15import OpenAPI.Checker.Subtree

17import OpenAPI.Checker.Subtree

16−import OpenAPI.Checker.Trace

17import OpenAPI.Checker.Validate.Products

18import OpenAPI.Checker.Validate.Products

18import OpenAPI.Checker.Validate.Schema ()

19import OpenAPI.Checker.Validate.Schema ()

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

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

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

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

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

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

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

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

25 $ _mediaTypeObjectEncoding $ extract mto

26 $ _mediaTypeObjectEncoding $ extract mto

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+

27instance Subtree MediaTypeObject where

45instance Subtree MediaTypeObject where

46+ type SubtreeLevel MediaTypeObject = 'PayloadLevel

28 type CheckEnv MediaTypeObject =

47 type CheckEnv MediaTypeObject =

29 '[ MediaType

48 '[ MediaType

30− , ProdCons (Definitions Schema)

49+ , ProdCons (Traced (Definitions Schema))

31 ]

50 ]

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

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

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

40 | "application" == mainType mediaType &&

53 | "application" == mainType mediaType &&

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

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

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

44 -- request

57 -- request

45 for_ (tracedSchema c) $ \consRef ->

58 for_ (tracedSchema c) $ \consRef ->

46 case tracedSchema p of

59 case tracedSchema p of

47− Nothing -> issueAt p MediaTypeSchemaRequired

60+ Nothing -> issueAt beh MediaTypeSchemaRequired

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

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

62+ $ ProdCons prodRef consRef

49 pure ()

63 pure ()

50 where

64 where

51 mediaType = getH @MediaType env

65 mediaType = getH @MediaType env

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

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

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

57 ( k

71 ( k

58 , ProductLike

72 , ProductLike

59− { tracedValue = enc

73+ { productValue = enc

60 , required = True } )

74 , required = True } )

61 encProdCons = getEncoding <$> prodCons

75 encProdCons = getEncoding <$> prodCons

62− in checkProducts (const MediaEncodingMissing)

76+ in checkProducts beh MediaEncodingMissing

63− (const $ checkCompatibility HNil) encProdCons

77+ (const $ checkCompatibility HNil beh) encProdCons

65instance Subtree Encoding where

79instance Subtree Encoding where

80+ type SubtreeLevel Encoding = 'PayloadLevel

66 type CheckEnv Encoding = '[]

81 type CheckEnv Encoding = '[]

67− data CheckIssue Encoding

68− = MediaEncodingMissing

69− | EncodingNotSupported

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

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

71 -- multipart/form-url-encoded

83 -- multipart/form-url-encoded

72− deriving (Eq, Ord, Show)

73− checkCompatibility _env pc =

84+ checkCompatibility _env beh _pc =

74− issueAt (producer pc) EncodingNotSupported

85+ issueAt beh EncodingNotSupported

76instance Steppable MediaTypeObject (Referenced Schema) where

87instance Steppable MediaTypeObject (Referenced Schema) where

77 data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema

88 data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema

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

80instance Steppable MediaTypeObject Encoding where

91instance Steppable MediaTypeObject Encoding where

81 data Step MediaTypeObject Encoding = MediaTypeParamEncoding Text

92 data Step MediaTypeObject Encoding = MediaTypeParamEncoding Text

82 deriving (Eq, Ord, Show)

93 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

10import Data.HList

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

12import Data.OpenApi

13+import OpenAPI.Checker.Behavior

14+import OpenAPI.Checker.Paths

13import OpenAPI.Checker.Subtree

15import OpenAPI.Checker.Subtree

14−import OpenAPI.Checker.Trace

15import OpenAPI.Checker.Validate.ProcessedPathItem

16import OpenAPI.Checker.Validate.ProcessedPathItem

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

18+tracedPaths :: Traced OpenApi -> Traced ProcessedPathItems

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

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

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

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

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+

21instance Subtree OpenApi where

46instance Subtree OpenApi where

47+ type SubtreeLevel OpenApi = 'APILevel

22 type CheckEnv OpenApi = '[]

48 type CheckEnv OpenApi = '[]

23− data CheckIssue OpenApi

24− deriving (Eq, Ord, Show)

25− checkCompatibility _ prodCons = do

49+ checkCompatibility _ beh prodCons = do

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

27 checkCompatibility @ProcessedPathItems

50 checkCompatibility @ProcessedPathItems

28− ((_componentsRequestBodies <$> cs)

51+ ((tracedRequestBodies <$> prodCons)

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

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

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

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

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

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

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

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

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

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

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

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

35 `HCons` HNil)

58 `HCons` HNil)

36− (tracedPaths <$> prodCons)

59+ beh (tracedPaths <$> prodCons)

38instance Steppable OpenApi ProcessedPathItems where

61instance Steppable OpenApi ProcessedPathItems where

39 data Step OpenApi ProcessedPathItems = OpenApiPathsStep

62 data Step OpenApi ProcessedPathItems = OpenApiPathsStep

40 deriving (Eq, Ord, Show)

63 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 @@

4module OpenAPI.Checker.Validate.Operation

5 ( MatchedOperation (..)

6− , CheckIssue (..)

7 , OperationMethod(..)

6 , OperationMethod(..)

8 , pathItemMethod

7 , pathItemMethod

9 ) where

8 ) where

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

17import Data.Maybe

16import Data.Maybe

18import Data.OpenApi

17import Data.OpenApi

19import Data.Text (Text)

18import Data.Text (Text)

19+import OpenAPI.Checker.Behavior

20import OpenAPI.Checker.References

21import OpenAPI.Checker.Subtree

22−import OpenAPI.Checker.Trace

22+import OpenAPI.Checker.Validate.MediaTypeObject

23−import OpenAPI.Checker.Validate.Param

24import OpenAPI.Checker.Validate.PathFragment

23import OpenAPI.Checker.Validate.PathFragment

25import OpenAPI.Checker.Validate.Products

24import OpenAPI.Checker.Validate.Products

26−import OpenAPI.Checker.Validate.RequestBody

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

27import OpenAPI.Checker.Validate.Responses ()

26import OpenAPI.Checker.Validate.Responses ()

28import OpenAPI.Checker.Validate.Server ()

27import OpenAPI.Checker.Validate.Server ()

30data MatchedOperation = MatchedOperation

29data MatchedOperation = MatchedOperation

31 { operation :: !Operation

30 { operation :: !Operation

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

31+ , pathParams :: ![Traced Param]

33 -- ^ Params from the PathItem

32 -- ^ Params from the PathItem

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

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

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

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

36 -- operation-specific parameters

35 -- operation-specific parameters

37 }

36 }

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

41paramKey :: Param -> ParamKey

40paramKey :: Param -> ParamKey

42paramKey param = (_paramIn param, _paramName param)

41paramKey param = (_paramIn param, _paramName param)

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

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

45tracedParameters oper =

44tracedParameters oper =

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

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

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

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

48 ]

47 ]

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

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

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

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

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

52+tracedResponses :: Traced MatchedOperation -> Traced Responses

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

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

55 $ _operationResponses . operation $ extract oper

54 $ _operationResponses . operation $ extract oper

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

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

58tracedSecurity oper =

57tracedSecurity oper =

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

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

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

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

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

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

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

64tracedServers

63tracedServers

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

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

66− -> Traced r MatchedOperation

65+ -> Traced MatchedOperation

67− -> Traced r [Server]

66+ -> Traced [Server]

68tracedServers env oper =

67tracedServers env oper =

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

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

70 case _operationServers . operation $ extract oper of

69 case _operationServers . operation $ extract oper of

71 [] -> env

70 [] -> env

72 ss -> ss

71 ss -> ss

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+

74instance Subtree MatchedOperation where

84instance Subtree MatchedOperation where

85+ type SubtreeLevel MatchedOperation = 'OperationLevel

75 type CheckEnv MatchedOperation =

86 type CheckEnv MatchedOperation =

76− '[ ProdCons (Definitions Param)

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

77− , ProdCons (Definitions RequestBody)

88+ , ProdCons (Traced (Definitions RequestBody))

78− , ProdCons (Definitions SecurityScheme)

89+ , ProdCons (Traced (Definitions SecurityScheme))

79− , ProdCons (Definitions Response)

90+ , ProdCons (Traced (Definitions Response))

80− , ProdCons (Definitions Header)

91+ , ProdCons (Traced (Definitions Header))

81− , ProdCons (Definitions Schema)

92+ , ProdCons (Traced (Definitions Schema))

82 , ProdCons [Server]

93 , ProdCons [Server]

83 ]

94 ]

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

89 checkParameters

96 checkParameters

90 checkRequestBodies

97 checkRequestBodies

91 checkResponses

98 checkResponses

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

98 let

105 let

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

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

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

107 -- 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])

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

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

103 getParams defs mp =

110 getParams defs mp =

104 let

111 let

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

112+ operationParamsMap :: Map ParamKey (Traced Param)

106 operationParamsMap = M.fromList $ do

113 operationParamsMap = M.fromList $ do

107 paramRef <- tracedParameters mp

114 paramRef <- tracedParameters mp

108 let

115 let

109 param = dereference defs paramRef

116 param = dereference defs paramRef

110 key = paramKey . extract $ param

117 key = paramKey . extract $ param

111 pure (key, param)

118 pure (key, param)

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

119+ pathParamsMap :: Map ParamKey (Traced Param)

113 pathParamsMap = M.fromList $ do

120 pathParamsMap = M.fromList $ do

114 param <- pathParams . extract $ mp

121 param <- pathParams . extract $ mp

115 pure (paramKey . extract $ param, param)

122 pure (paramKey . extract $ param, param)

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

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

117− -- We prefer params from Operation

118 splitted = L.partition

124 splitted = L.partition

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

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

120 in splitted

126 in splitted

121 checkNonPathParams $ snd <$> tracedParams

127 checkNonPathParams $ snd <$> tracedParams

122 checkPathParams $ fst <$> tracedParams

128 checkPathParams $ fst <$> tracedParams

123 pure ()

129 pure ()

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

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

125 checkNonPathParams params = do

131 checkNonPathParams params = do

126 let

132 let

127 elements = getEls <$> params

133 elements = getEls <$> params

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

130 let

136 let

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

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

132 v = ProductLike

138 v = ProductLike

133− { tracedValue = p

139+ { productValue = p

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

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

135 }

141 }

136 pure (k, v)

142 pure (k, v)

137− check param = do

143+ check (_, name) param = do

138− checkCompatibility @Param (singletonH schemaDefs) param

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

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

145+ checkProducts beh (ParamNotMatched . snd) check elements

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

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

141 checkPathParams pathParams = do

147 checkPathParams pathParams = do

142 let

148 let

143− fragments :: ProdCons [Traced OpenApi PathFragmentParam]

149+ fragments :: ProdCons [Traced PathFragmentParam]

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

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

145 getFragments params mop = getPathFragments (extract mop) params

151 getFragments params mop = getPathFragments (extract mop) params

146 -- Feed path parameters to the fragments getter

152 -- 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

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

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

149 frag <- frags

155 frag <- frags

150 pure $ ProductLike

156 pure $ ProductLike

151− { tracedValue = frag

157+ { productValue = frag

152 , required = True }

158 , required = True }

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

159+ checkProducts beh PathFragmentNotMatched check elements

154 checkRequestBodies = do

160 checkRequestBodies = do

155 let

161 let

156− check reqBody = checkCompatibility @RequestBody env reqBody

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

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

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

158 getReqBody bodyDef mop = M.fromList $ do

164 getReqBody bodyDef mop = M.fromList $ do

159 bodyRef <- F.toList . tracedRequestBody $ mop

165 bodyRef <- F.toList . tracedRequestBody $ mop

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

161 body = dereference bodyDef bodyRef

167 body = dereference bodyDef bodyRef

162 -- Single element map

168 -- Single element map

163 pure ((), ProductLike

169 pure ((), ProductLike

164− { tracedValue = body

170+ { productValue = body

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

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

166 })

172 })

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

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

168 checkResponses = do

174 checkResponses = do

169 let

175 let

170 respEnv = HCons (swapProdCons respDefs)

176 respEnv = HCons (swapProdCons respDefs)

171 $ HCons (swapProdCons headerDefs)

177 $ HCons (swapProdCons headerDefs)

172 $ HCons (swapProdCons schemaDefs) HNil

178 $ HCons (swapProdCons schemaDefs) HNil

173 resps = tracedResponses <$> prodCons

179 resps = tracedResponses <$> prodCons

174− checkCompatibility respEnv $ swapProdCons resps

180+ checkCompatibility respEnv beh $ swapProdCons resps

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

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

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

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

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

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

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

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

179 checkServers =

185 checkServers =

180− checkCompatibility env $

186+ checkCompatibility env beh $

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

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

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

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

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

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

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

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

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

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

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

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

187

193

188−data OperationMethod =

194+data OperationMethod =

189 GetMethod

195 GetMethod

190 | PutMethod

196 | PutMethod

191 | PostMethod

197 | PostMethod

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

196 | TraceMethod

202 | TraceMethod

197 deriving (Eq, Ord, Show)

203 deriving (Eq, Ord, Show)

198

204

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

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

200pathItemMethod = \case

206pathItemMethod = \case

201 GetMethod -> _pathItemGet

207 GetMethod -> _pathItemGet

202 PutMethod -> _pathItemPut

208 PutMethod -> _pathItemPut

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

209

215

210instance Steppable MatchedOperation (Referenced Param) where

216instance Steppable MatchedOperation (Referenced Param) where

211 data Step MatchedOperation (Referenced Param) = OperationParamsStep Int

217 data Step MatchedOperation (Referenced Param) = OperationParamsStep Int

212− deriving (Eq, Ord, Show)

218+ deriving stock (Eq, Ord, Show)

213

219

214instance Steppable MatchedOperation (Referenced RequestBody) where

220instance Steppable MatchedOperation (Referenced RequestBody) where

215 data Step MatchedOperation (Referenced RequestBody) = OperationRequestBodyStep

221 data Step MatchedOperation (Referenced RequestBody) = OperationRequestBodyStep

216− deriving (Eq, Ord, Show)

222+ deriving stock (Eq, Ord, Show)

217

223

218instance Steppable MatchedOperation Responses where

224instance Steppable MatchedOperation Responses where

219 data Step MatchedOperation Responses = OperationResponsesStep

225 data Step MatchedOperation Responses = OperationResponsesStep

220− deriving (Eq, Ord, Show)

226+ deriving stock (Eq, Ord, Show)

221

227

222instance Steppable MatchedOperation SecurityRequirement where

228instance Steppable MatchedOperation SecurityRequirement where

223 data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int

229 data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int

224− deriving (Eq, Ord, Show)

230+ deriving stock (Eq, Ord, Show)

225

231

226instance Steppable MatchedOperation [Server] where

232instance Steppable MatchedOperation [Server] where

227− data Step MatchedOperation [Server]

233+ data Step MatchedOperation [Server]

228− = OperationServersStep

234+ = OperationServersStep

229 | EnvServerStep

235 | EnvServerStep

230 deriving (Eq, Ord, Show)

236 deriving (Eq, Ord, Show)

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

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

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

4module OpenAPI.Checker.Validate.Param

5− ( CheckIssue (..)

5+ ( Behave (..)

6+ , Issue (..)

6 ) where

7 ) where

8import Control.Lens

9import Control.Lens

9import Control.Monad

10import Control.Monad

10import Data.Maybe

11import Data.Maybe

11import Data.OpenApi

12import Data.OpenApi

12−import Data.Text

13+import Data.Text as T

14+import OpenAPI.Checker.Behavior

13−import OpenAPI.Checker.Orphans

15+import OpenAPI.Checker.Orphans ()

14import OpenAPI.Checker.Subtree

16import OpenAPI.Checker.Subtree

15−import OpenAPI.Checker.Trace

16import OpenAPI.Checker.Validate.Schema ()

17import OpenAPI.Checker.Validate.Schema ()

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

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

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

42 ParamQuery -> Just $ fromMaybe False $ _paramAllowReserved p

43 ParamQuery -> Just $ fromMaybe False $ _paramAllowReserved p

43 _ -> Nothing

44 _ -> Nothing

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

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

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

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

48−instance Subtree Param where

49+instance Issuable 'PathFragmentLevel where

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

50+ data Issue 'PathFragmentLevel

50− data CheckIssue Param

51− = ParamNotMatched Text

52− | ParamNameMismatch

51+ = ParamNameMismatch

53 -- ^ Params have different names

52 -- ^ Params have different names

54 | ParamEmptinessIncompatible

53 | ParamEmptinessIncompatible

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

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

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

60 -- ^ Params encoded in different styles

59 -- ^ Params encoded in different styles

61 | ParamSchemaMismatch

60 | ParamSchemaMismatch

62 -- ^ One of schemas not presented

61 -- ^ 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

63 deriving (Eq, Ord, Show)

69 deriving (Eq, Ord, Show)

70+

71+instance Subtree Param where

72+ type SubtreeLevel Param = 'PathFragmentLevel

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

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

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

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

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

66− $ issueAt p ParamNameMismatch

76+ $ issueAt beh ParamNameMismatch

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

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

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

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

69− $ issueAt p ParamRequired

79+ $ issueAt beh ParamRequired

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

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

71 (ParamQuery, ParamQuery) -> do

81 (ParamQuery, ParamQuery) -> do

72 -- Emptiness is only for query params

82 -- Emptiness is only for query params

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

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

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

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

75− $ issueAt p ParamEmptinessIncompatible

85+ $ issueAt beh ParamEmptinessIncompatible

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

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

77− _ -> issueAt p ParamPlaceIncompatible

87+ _ -> issueAt beh ParamPlaceIncompatible

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

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

79− $ issueAt p ParamStyleMismatch

89+ $ issueAt beh ParamStyleMismatch

80 case tracedSchema <$> pc of

90 case tracedSchema <$> pc of

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

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

82− checkCompatibility env $ ProdCons prodSchema consSchema

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

83 ProdCons Nothing Nothing -> pure ()

93 ProdCons Nothing Nothing -> pure ()

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

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

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

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

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

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

87 pure ()

97 pure ()

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

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

2 ( parsePath

3 , PathFragment (..)

4 , PathFragmentParam

5− , CheckIssue (..)

6 )

5 )

7where

6where

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

11import Data.Text (Text)

10import Data.Text (Text)

12import qualified Data.Text as T

11import qualified Data.Text as T

13import Data.Typeable

12import Data.Typeable

13+import OpenAPI.Checker.Behavior

14import OpenAPI.Checker.Subtree

15−import OpenAPI.Checker.Trace

15+import OpenAPI.Checker.Validate.Param

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

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

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

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

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

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

35 | DynamicPath param

34 | DynamicPath param

36 deriving stock (Eq, Ord)

35 deriving stock (Eq, Ord)

38−type PathFragmentParam = PathFragment (Traced OpenApi Param)

37+type PathFragmentParam = PathFragment (Traced Param)

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

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

41 data Step (PathFragment param) Param = StaticPathParam Text

40 data Step (PathFragment param) Param = StaticPathParam Text

42 deriving (Eq, Ord, Show)

41 deriving (Eq, Ord, Show)

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

43+tracedPathFragmentParam :: Traced PathFragmentParam -> Traced Param

45tracedPathFragmentParam pfp = case extract pfp of

44tracedPathFragmentParam pfp = case extract pfp of

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

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

47 $ mempty

46 $ mempty

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

61 }

60 }

63instance Subtree PathFragmentParam where

62instance Subtree PathFragmentParam where

63+ type SubtreeLevel PathFragmentParam = 'PathFragmentLevel

64 type CheckEnv PathFragmentParam =

65− '[ ProdCons (Definitions Schema) ]

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

66− data CheckIssue PathFragmentParam

67− = PathFragmentNotMatched

68− | PathFragmentsDontMatch Text Text

69− deriving (Eq, Ord, Show)

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

66 -- 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))

72 = if x == y

68 = if x == y

73 then pure ()

69 then pure ()

74− else issueAt c (PathFragmentsDontMatch x y)

70+ else issueAt beh (PathFragmentsDontMatch x y)

75− checkCompatibility env prodCons = do

71+ checkCompatibility env beh prodCons = do

76− checkCompatibility env (tracedPathFragmentParam <$> prodCons)

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

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

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

9 )

10where

12+import Control.Arrow

12import Control.Comonad.Env

13import Control.Comonad.Env

13import Control.Monad

14import Control.Monad

14import Data.Foldable as F

15import Data.Foldable as F

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

19import Data.Maybe

20import Data.Maybe

20import Data.OpenApi

21import Data.OpenApi

21import Data.Text as T

22import Data.Text as T

23+import OpenAPI.Checker.Behavior

24+import OpenAPI.Checker.Orphans ()

25+import OpenAPI.Checker.Paths

22import OpenAPI.Checker.References

26import OpenAPI.Checker.References

23import OpenAPI.Checker.Subtree

27import OpenAPI.Checker.Subtree

24−import OpenAPI.Checker.Trace

25import OpenAPI.Checker.Validate.Operation

28import OpenAPI.Checker.Validate.Operation

26import OpenAPI.Checker.Validate.PathFragment

29import OpenAPI.Checker.Validate.PathFragment

27import OpenAPI.Checker.Validate.Sums

30import OpenAPI.Checker.Validate.Sums

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

38newtype ProcessedPathItems =

41newtype ProcessedPathItems =

39 ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}

42 ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}

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+

41instance Subtree ProcessedPathItems where

57instance Subtree ProcessedPathItems where

58+ type SubtreeLevel ProcessedPathItems = 'APILevel

42 type

59 type

43 CheckEnv ProcessedPathItems =

60 CheckEnv ProcessedPathItems =

44− '[ ProdCons (Definitions Param)

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

45− , ProdCons (Definitions RequestBody)

62+ , ProdCons (Traced (Definitions RequestBody))

46− , ProdCons (Definitions SecurityScheme)

63+ , ProdCons (Traced (Definitions SecurityScheme))

47− , ProdCons (Definitions Response)

64+ , ProdCons (Traced (Definitions Response))

48− , ProdCons (Definitions Header)

65+ , ProdCons (Traced (Definitions Header))

49− , ProdCons (Definitions Schema)

66+ , ProdCons (Traced (Definitions Schema))

50 , ProdCons [Server]

67 , ProdCons [Server]

51 ]

68 ]

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

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

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

59 -- one way

71 -- one way

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

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

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

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

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

66 return matched

78 return matched

67 case matchedItems of

79 case matchedItems of

68− [] -> issueAt p $ NoPathsMatched prodPath

80+ [] -> issueAt beh $ NoPathsMatched prodPath

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

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

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

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

71 match <- matches

83 match <- matches

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

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

73 where

85 where

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

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

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

106 -- ^ Pre-parsed path from PathItem

118 -- ^ Pre-parsed path from PathItem

107 }

119 }

108

120

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

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

110tracedParameters mpi =

122tracedParameters mpi =

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

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

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

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

113 ]

125 ]

114

126

115-- TODO: simplify?

127-- TODO: simplify?

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

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

117tracedFragments mpi =

129tracedFragments mpi =

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

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

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

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

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

121

133

122tracedMethod

134tracedMethod

123 :: OperationMethod

135 :: OperationMethod

124− -> Traced r MatchedPathItem

136+ -> Traced MatchedPathItem

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

137+ -> Maybe (Traced' MatchedOperation Operation)

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

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

127

139

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+

128instance Subtree MatchedPathItem where

151instance Subtree MatchedPathItem where

152+ type SubtreeLevel MatchedPathItem = 'PathLevel

129 type CheckEnv MatchedPathItem =

153 type CheckEnv MatchedPathItem =

130− '[ ProdCons (Definitions Param)

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

131− , ProdCons (Definitions RequestBody)

155+ , ProdCons (Traced (Definitions RequestBody))

132− , ProdCons (Definitions SecurityScheme)

156+ , ProdCons (Traced (Definitions SecurityScheme))

133− , ProdCons (Definitions Response)

157+ , ProdCons (Traced (Definitions Response))

134− , ProdCons (Definitions Header)

158+ , ProdCons (Traced (Definitions Header))

135− , ProdCons (Definitions Schema)

159+ , ProdCons (Traced (Definitions Schema))

136 , ProdCons [Server]

160 , ProdCons [Server]

137 ]

161 ]

138− data CheckIssue MatchedPathItem

139− deriving (Eq, Ord, Show)

140− checkCompatibility env prodCons = do

162+ checkCompatibility env beh prodCons = do

141 let

163 let

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

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

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

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

144 getPathParams

166 getPathParams

145− :: Definitions Param

167+ :: Traced (Definitions Param)

146− -> Traced r MatchedPathItem

168+ -> Traced MatchedPathItem

147− -> [Traced r Param]

169+ -> [Traced Param]

148 getPathParams defs mpi = do

170 getPathParams defs mpi = do

149 paramRef <- tracedParameters mpi

171 paramRef <- tracedParameters mpi

150 pure $ dereference defs paramRef

172 pure $ dereference defs paramRef

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

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

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

154 -- function, returning fragments

176 -- function, returning fragments

155 let

177 let

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

178+ paramsMap :: Map Text (Traced Param)

157 paramsMap = M.fromList $ do

179 paramsMap = M.fromList $ do

158 tracedParam <- operationParams

180 tracedParam <- operationParams

159 let pname = _paramName . extract $ tracedParam

181 let pname = _paramName . extract $ tracedParam

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

166 in tracedFragments mpi <&> fmap convertFragment

188 in tracedFragments mpi <&> fmap convertFragment

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

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

168 getOperations pathParams getPathFragments mpi = M.fromList $ do

190 getOperations pathParams getPathFragments mpi = M.fromList $ do

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

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

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

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

171 operation <- F.toList $ getOp mpi

193 operation <- F.toList $ getOp mpi

172 -- Got only Justs here

194 -- Got only Justs here

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

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

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

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

175− check pc = checkCompatibility @MatchedOperation env pc

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

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

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

177 -- why not

199 -- why not

178− checkSums OperationMissing (const check) operations

200+ checkSums beh OperationMissing check operations

179

201

180

202

181instance Steppable ProcessedPathItems MatchedPathItem where

203instance Steppable ProcessedPathItems MatchedPathItem where

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

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

20import Data.Foldable

21import Data.Map.Strict (Map)

22import qualified Data.Map.Strict as M

23+import OpenAPI.Checker.Behavior

24+import OpenAPI.Checker.Paths

23import OpenAPI.Checker.Subtree

25import OpenAPI.Checker.Subtree

24−import OpenAPI.Checker.Trace

26-- | Some entity which is product-like

27-- | Some entity which is product-like

27−data ProductLike root a = ProductLike

28+data ProductLike a = ProductLike

28− { tracedValue :: Traced root a

29+ { productValue :: a

29 , required :: Bool

30 , required :: Bool

30 }

31 }

32checkProducts

33checkProducts

33− :: forall k r t

34+ :: (Ord k, Issuable l)

34− . (Subtree t, Ord k)

35+ => Paths q r l

35− => (k -> CheckIssue t)

36+ -> (k -> Issue l)

36 -- ^ No required element found

37 -- ^ No required element found

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

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

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

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

39− -> CompatFormula' SubtreeCheckIssue r ()

40+ -> CompatFormula' q AnIssue r ()

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

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

41 case M.lookup key p of

42 case M.lookup key p of

42 Nothing -> case required consElt of

43 Nothing -> case required consElt of

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

44+ True -> issueAt xs $ noElt key

44 False -> pure ()

45 False -> pure ()

45 Just prodElt -> do

46 Just prodElt -> do

46 let

47 let

47− elts :: ProdCons (ProductLike r t)

48 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 @@

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

3module OpenAPI.Checker.Validate.RequestBody

4− ( CheckIssue (..)

4+ ( Issue (..)

5 )

6where

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

11import Data.Maybe

12import Data.OpenApi

13import Network.HTTP.Media (MediaType)

14+import OpenAPI.Checker.Behavior

14import OpenAPI.Checker.Subtree

15import OpenAPI.Checker.Subtree

15−import OpenAPI.Checker.Trace

16import OpenAPI.Checker.Validate.MediaTypeObject

17import OpenAPI.Checker.Validate.Sums

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

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

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

21 $ _requestBodyContent $ extract resp

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+

23instance Subtree RequestBody where

35instance Subtree RequestBody where

36+ type SubtreeLevel RequestBody = 'RequestLevel

24 type CheckEnv RequestBody =

37 type CheckEnv RequestBody =

25− '[ ProdCons (Definitions Schema) ]

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

26− data CheckIssue RequestBody

27− = NoRequestBody

28− | RequestBodyRequired

29− deriving (Eq, Ord, Show)

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

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

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

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

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

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

33− then issueAt p RequestBodyRequired

42+ then issueAt beh RequestBodyRequired

34 else

43 else

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

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

36 let

45 let

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

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

38 sumElts = getSum <$> prodCons

47 sumElts = getSum <$> prodCons

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

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

40− in checkSums (const RequestMediaTypeNotFound) check sumElts

49+ in checkSums beh RequestMediaTypeNotFound check sumElts

42instance Steppable RequestBody MediaTypeObject where

51instance Steppable RequestBody MediaTypeObject where

43 data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType

52 data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType

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

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

14import Data.Maybe

15import Data.OpenApi

16import Network.HTTP.Media (MediaType)

17+import OpenAPI.Checker.Behavior

17import OpenAPI.Checker.References

18import OpenAPI.Checker.References

18import OpenAPI.Checker.Subtree

19import OpenAPI.Checker.Subtree

19−import OpenAPI.Checker.Trace

20import OpenAPI.Checker.Validate.MediaTypeObject

21import OpenAPI.Checker.Validate.Products

22import OpenAPI.Checker.Validate.Schema ()

23import OpenAPI.Checker.Validate.Sums

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

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

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

27 $ _responsesResponses $ extract resp

29instance Subtree Responses where

30+ type SubtreeLevel Responses = 'OperationLevel

30 type CheckEnv Responses =

31 type CheckEnv Responses =

31− '[ ProdCons (Definitions Response)

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

32− , ProdCons (Definitions Header)

33+ , ProdCons (Traced (Definitions Header))

33− , ProdCons (Definitions Schema)

34+ , ProdCons (Traced (Definitions Schema))

34 ]

35 ]

35− data CheckIssue Responses

36− deriving (Eq, Ord, Show)

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

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

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

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

39 -- one element

38 -- one element

40− checkCompatibility env prodCons = do

39+ checkCompatibility env beh prodCons = do

41 let

40 let

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

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

43− check resps = checkCompatibility @Response env resps

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

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

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

45 getEls respDef resps = M.fromList $ do

44 getEls respDef resps = M.fromList $ do

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

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

47 pure (code, dereference respDef respRef)

46 pure (code, dereference respDef respRef)

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

47+ checkSums beh ResponseCodeNotFound check elements

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

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

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

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

52 $ _responseContent $ extract resp

51 $ _responseContent $ extract resp

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

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

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

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

56 $ _responseHeaders $ extract resp

55 $ _responseHeaders $ extract resp

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+

58instance Subtree Response where

74instance Subtree Response where

75+ type SubtreeLevel Response = 'ResponseLevel

59 type CheckEnv Response =

76 type CheckEnv Response =

60− '[ ProdCons (Definitions Header)

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

61− , ProdCons (Definitions Schema)

78+ , ProdCons (Traced (Definitions Schema))

62 ]

79 ]

63− data CheckIssue Response

64− = ResponseCodeNotFound

65− deriving (Eq, Ord, Show)

66− checkCompatibility env prodCons = do

80+ checkCompatibility env beh prodCons = do

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

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

68 checkMediaTypes

82 checkMediaTypes

69 checkHeaders

83 checkHeaders

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

74 let

88 let

75 check mediaType mtObj =

89 check mediaType mtObj =

76 let mtEnv = HCons mediaType $ env

90 let mtEnv = HCons mediaType $ env

77− in checkCompatibility @MediaTypeObject mtEnv mtObj

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

78 elements = getEls <$> prodCons

92 elements = getEls <$> prodCons

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

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

80− checkSums (const ResponseMediaTypeMissing) check elements

94+ checkSums beh ResponseMediaTypeMissing check elements

82 checkHeaders = do

96 checkHeaders = do

83 -- Headers are product-like entities

97 -- Headers are product-like entities

84 let

98 let

85− check hdrs = checkCompatibility @Header env hdrs

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

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

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

87 getEls headerDef resp = M.fromList $ do

101 getEls headerDef resp = M.fromList $ do

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

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

89 let header = dereference headerDef headerRef

103 let header = dereference headerDef headerRef

90 pure (hname, ProductLike

104 pure (hname, ProductLike

91− { tracedValue = header

105+ { productValue = header

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

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

93 })

107 })

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

108+ checkProducts beh ResponseHeaderMissing check elements

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

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

110

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

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

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

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

113

100−instance Subtree Header where

114+instance Issuable 'HeaderLevel where

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

115+ data Issue 'HeaderLevel

102− data CheckIssue Header

103− = ResponseHeaderMissing

104− | RequiredHeaderMissing

116+ = RequiredHeaderMissing

105 | NonEmptyHeaderRequired

117 | NonEmptyHeaderRequired

106 | HeaderSchemaRequired

118 | HeaderSchemaRequired

119+ deriving stock (Eq, Ord, Show)

120+ issueIsUnsupported _ = False

121+

122+instance Behavable 'HeaderLevel 'SchemaLevel where

123+ data Behave 'HeaderLevel 'SchemaLevel

124+ = InSchema

107− deriving (Eq, Ord, Show)

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))]

108− checkCompatibility env (ProdCons p c) = do

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

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

131 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 ()

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

133 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 ()

113 for_ (tracedSchema c) $ \consRef ->

135 for_ (tracedSchema c) $ \consRef ->

114 case tracedSchema p of

136 case tracedSchema p of

115− Nothing -> issueAt p HeaderSchemaRequired

137+ Nothing -> issueAt beh HeaderSchemaRequired

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

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

117 pure ()

139 pure ()

118

140

119instance Steppable Responses (Referenced Response) where

141instance Steppable Responses (Referenced Response) where

120 data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode

142 data Step Responses (Referenced Response) = ResponseCodeStep HttpStatusCode

121− deriving (Eq, Ord, Show)

143+ deriving stock (Eq, Ord, Show)

122

144

123instance Steppable Header (Referenced Schema) where

145instance Steppable Header (Referenced Schema) where

124 data Step Header (Referenced Schema) = HeaderSchema

146 data Step Header (Referenced Schema) = HeaderSchema

125− deriving (Eq, Ord, Show)

147+ deriving stock (Eq, Ord, Show)

126

148

127instance Steppable Response (Referenced Header) where

149instance Steppable Response (Referenced Header) where

128 data Step Response (Referenced Header) = ResponseHeader HeaderName

150 data Step Response (Referenced Header) = ResponseHeader HeaderName

129− deriving (Eq, Ord, Show)

151+ deriving stock (Eq, Ord, Show)

130

152

131instance Steppable Response MediaTypeObject where

153instance Steppable Response MediaTypeObject where

132 data Step Response MediaTypeObject = ResponseMediaObject MediaType

154 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

39import Data.Text (Text)

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

41import Data.Typeable

42+import OpenAPI.Checker.Behavior

42import OpenAPI.Checker.Orphans ()

43import OpenAPI.Checker.Orphans ()

43import OpenAPI.Checker.References

44import OpenAPI.Checker.References

45+import OpenAPI.Checker.Paths

46+import qualified OpenAPI.Checker.PathsPrefixTree as P

44import OpenAPI.Checker.Subtree

47import OpenAPI.Checker.Subtree

45−import OpenAPI.Checker.Trace

46−import qualified OpenAPI.Checker.TracePrefixTree as T

48-- | Type of a JSON value

49-- | Type of a JSON value

49data JsonType

50data JsonType

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

53 | String

54 | String

54 | Array

55 | Array

55 | Object

56 | Object

56− deriving (Eq, Show)

57+ deriving stock (Eq, Ord, Show)

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

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

59data TypedValue :: JsonType -> Type where

60data TypedValue :: JsonType -> Type where

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

89data Property = Property

90data Property = Property

90 { propRequired :: Bool

91 { propRequired :: Bool

91− , propFormula :: ForeachType (JsonFormula OpenApi)

92+ , propFormula :: ForeachType JsonFormula

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

93+ , propRefSchema :: Traced (Referenced Schema)

93 }

94 }

94 deriving stock (Eq, Ord, Show)

95 deriving stock (Eq, Ord, Show)

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

106 Pattern :: !Pattern -> Condition 'String

107 Pattern :: !Pattern -> Condition 'String

107 StringFormat :: !Format -> Condition 'String

108 StringFormat :: !Format -> Condition 'String

108 Items

109 Items

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

110+ :: !(ForeachType JsonFormula)

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

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

111 -> Condition 'Array

112 -> Condition 'Array

112 MaxItems :: !Integer -> Condition 'Array

113 MaxItems :: !Integer -> Condition 'Array

113 MinItems :: !Integer -> Condition 'Array

114 MinItems :: !Integer -> Condition 'Array

114 UniqueItems :: Condition 'Array

115 UniqueItems :: Condition 'Array

115 Properties

116 Properties

116 :: !(M.Map Text Property)

117 :: !(M.Map Text Property)

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

118+ -> !(ForeachType JsonFormula)

118 -- ^ formula for additional properties

119 -- ^ formula for additional properties

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

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

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

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

121 -> Condition 'Object

122 -> Condition 'Object

122 MaxProperties :: !Integer -> Condition 'Object

123 MaxProperties :: !Integer -> Condition 'Object

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

158deriving stock instance Show (Condition t)

159deriving stock instance Show (Condition t)

159

160

160data SomeCondition where

161data SomeCondition where

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

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

162

163

163instance Eq SomeCondition where

164instance Eq SomeCondition where

164 SomeCondition x == SomeCondition y = case cast x of

165 SomeCondition x == SomeCondition y = case cast x of

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

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

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

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

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

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

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

178−newtype JsonFormula r t

179+newtype JsonFormula t

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

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

180 deriving stock (Eq, Ord, Show)

181 deriving stock (Eq, Ord, Show)

181

182

182disjAdd

183disjAdd

183− :: JsonFormula r t

184+ :: JsonFormula t

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

185+ -> S.Set (Condition t)

185− -> JsonFormula r t

186+ -> JsonFormula t

186disjAdd (DNF yss) xs

187disjAdd (DNF yss) xs

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

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

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

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

189− where

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

191

190

192−instance Lattice (JsonFormula r t) where

191+instance Lattice (JsonFormula t) where

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

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

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

193 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)

196

195

197−pattern BottomFormula :: JsonFormula r t

196+pattern BottomFormula :: JsonFormula t

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

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

199 where BottomFormula = DNF S.empty

198 where BottomFormula = DNF S.empty

200

199

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

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

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

204 | otherwise = Nothing

203 | otherwise = Nothing

205

204

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

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

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

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

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

207+ where Conjunct = S.fromList

209{-# COMPLETE Conjunct #-}

208{-# COMPLETE Conjunct #-}

210

209

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

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

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

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

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

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

214

213

215−pattern TopFormula :: JsonFormula r t

214+pattern TopFormula :: JsonFormula t

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

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

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

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

218

217

219−instance BoundedJoinSemiLattice (JsonFormula r t) where

218+instance BoundedJoinSemiLattice (JsonFormula t) where

220 bottom = BottomFormula

219 bottom = BottomFormula

221

220

222−instance BoundedMeetSemiLattice (JsonFormula r t) where

221+instance BoundedMeetSemiLattice (JsonFormula t) where

223 top = TopFormula

222 top = TopFormula

224

223

225foldLattice

224foldLattice

226 :: BoundedLattice l

225 :: BoundedLattice l

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

226+ => (Condition t -> l)

228− -> JsonFormula r t

227+ -> JsonFormula t

229 -> l

228 -> l

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

229foldLattice 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

232

231

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

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

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

233+satisfiesFormula val = foldLattice (satisfiesTyped val)

235

234

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

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

237 { forNull :: f 'Null

236 { forNull :: f 'Null

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

242 , forObject :: f 'Object

241 , forObject :: f 'Object

243 }

242 }

244

243

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

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

246satisfies val p = case val of

245satisfies val p = case val of

247 A.Null -> satisfiesFormula TNull $ forNull p

246 A.Null -> satisfiesFormula TNull $ forNull p

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

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

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

257

256

258foldType

257foldType

259 :: Monoid m

258 :: Monoid m

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

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

261 -> m

260 -> m

262foldType k =

261foldType k =

263− k forNull <>

262+ k Null forNull <>

264− k forBoolean <>

263+ k Boolean forBoolean <>

265− k forNumber <>

264+ k Number forNumber <>

266− k forString <>

265+ k String forString <>

267− k forArray <>

266+ k Array forArray <>

268− k forObject

267+ k Object forObject

269

268

270forType_

269forType_

271 :: Applicative m

270 :: Applicative m

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

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

273 -> m ()

272 -> m ()

274forType_ k = do

273forType_ k = do

275− k forNull

274+ k Null forNull

276− k forBoolean

275+ k Boolean forBoolean

277− k forNumber

276+ k Number forNumber

278− k forString

277+ k String forString

279− k forArray

278+ k Array forArray

280− k forObject

279+ k Object forObject

281 pure ()

280 pure ()

282

281

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

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

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

320 , forObject = top

319 , forObject = top

321 }

320 }

322

321

322+{- TODO: remove

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

324 data Step Schema (Condition t)

325 = EnumField

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

340 | NullableField

341 | IntegerType -- type=integer

342 deriving (Eq, Ord, Show)

343+-}

344+

345+instance Behavable 'SchemaLevel 'SchemaLevel where

346+ data Behave 'SchemaLevel 'SchemaLevel

347+ deriving (Eq, Ord, Show)

343

348

344instance Steppable Schema (Referenced Schema) where

349instance Steppable Schema (Referenced Schema) where

345 data Step Schema (Referenced Schema)

350 data Step Schema (Referenced Schema)

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

352 | PropertiesStep Text

357 | PropertiesStep Text

353 deriving (Eq, Ord, Show)

358 deriving (Eq, Ord, Show)

354

359

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

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

356

361

357−warn

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

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

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

361

364

362processRefSchema

365processRefSchema

363− :: Traced OpenApi (Referenced Schema)

366+ :: Traced (Referenced Schema)

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

367+ -> ProcessM (ForeachType JsonFormula)

365processRefSchema x = do

368processRefSchema x = do

366 defs <- R.ask

369 defs <- R.ask

367 processSchema $ dereference defs x

370 processSchema $ dereference defs x

368

371

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

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

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

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

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

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

372

375

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

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

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

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

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

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

376

379

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

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

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

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

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

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

380

383

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)])

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

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

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

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

384 OpenApiItemsArray xs -> Right

387 OpenApiItemsArray xs -> Right

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

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

386

389

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

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

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

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

389 AdditionalPropertiesAllowed b -> Left b

392 AdditionalPropertiesAllowed b -> Left b

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

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

391

394

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

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

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

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

394 $ _schemaProperties $ extract sch

397 $ _schemaProperties $ extract sch

395

398

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

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

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

398-- are thus checked independently.

401-- are thus checked independently.

399processSchema

402processSchema

400− :: Traced OpenApi Schema

403+ :: Traced Schema

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

404+ -> ProcessM (ForeachType JsonFormula)

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

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

403 let

406 let

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

407+ singletonFormula :: Condition t -> JsonFormula t

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

408+ singletonFormula f = SingleConjunct [f]

406

409

407 allClauses <- case tracedAllOf sch of

410 allClauses <- case tracedAllOf sch of

408 Nothing -> pure []

411 Nothing -> pure []

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

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

410 Just xs -> mapM processRefSchema xs

413 Just xs -> mapM processRefSchema xs

411

414

412 anyClause <- case tracedAnyOf sch of

415 anyClause <- case tracedAnyOf sch of

413 Nothing -> pure top

416 Nothing -> pure top

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

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

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

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

416

419

417 oneClause <- case tracedOneOf sch of

420 oneClause <- case tracedOneOf sch of

418 Nothing -> pure top

421 Nothing -> pure top

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

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

420 Just xs -> do

423 Just xs -> do

421 checkOneOfDisjoint xs >>= \case

424 checkOneOfDisjoint xs >>= \case

422 True -> pure ()

425 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")

424 joins <$> mapM processRefSchema xs

427 joins <$> mapM processRefSchema xs

425

428

426 case _schemaNot of

429 case _schemaNot of

427 Nothing -> pure ()

430 Nothing -> pure ()

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

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

429

432

430 let

433 let

431 typeClause = case _schemaType of

434 typeClause = case _schemaType of

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

437 Just OpenApiNumber -> bottom

440 Just OpenApiNumber -> bottom

438 { forBoolean = top }

441 { forBoolean = top }

439 Just OpenApiInteger -> bottom

442 Just OpenApiInteger -> bottom

440− { forNumber = singletonFormula IntegerType $ MultipleOf 1 }

443+ { forNumber = singletonFormula $ MultipleOf 1 }

441 Just OpenApiString -> bottom

444 Just OpenApiString -> bottom

442 { forString = top }

445 { forString = top }

443 Just OpenApiArray -> bottom

446 Just OpenApiArray -> bottom

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

447

450

448 let

451 let

449 valueEnum A.Null = bottom

452 valueEnum A.Null = bottom

450− { forNull = singletonFormula EnumField $ Exactly TNull }

453+ { forNull = singletonFormula $ Exactly TNull }

451 valueEnum (A.Bool b) = bottom

454 valueEnum (A.Bool b) = bottom

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

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

453 valueEnum (A.Number n) = bottom

456 valueEnum (A.Number n) = bottom

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

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

455 valueEnum (A.String s) = bottom

458 valueEnum (A.String s) = bottom

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

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

457 valueEnum (A.Array a) = bottom

460 valueEnum (A.Array a) = bottom

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

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

459 valueEnum (A.Object o) = bottom

462 valueEnum (A.Object o) = bottom

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

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

461 enumClause <- case _schemaEnum of

464 enumClause <- case _schemaEnum of

462 Nothing -> pure top

465 Nothing -> pure top

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

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

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

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

465

468

466 let

469 let

467 maximumClause = case _schemaMaximum of

470 maximumClause = case _schemaMaximum of

468 Nothing -> top

471 Nothing -> top

469 Just n -> top

472 Just n -> top

470− { forNumber = singletonFormula MaximumFields $ Maximum $

473+ { forNumber = singletonFormula $ Maximum $

471 case _schemaExclusiveMaximum of

474 case _schemaExclusiveMaximum of

472 Just True -> Exclusive n

475 Just True -> Exclusive n

473 _ -> Inclusive n }

476 _ -> Inclusive n }

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

475 minimumClause = case _schemaMinimum of

478 minimumClause = case _schemaMinimum of

476 Nothing -> top

479 Nothing -> top

477 Just n -> top

480 Just n -> top

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

481+ { forNumber = singletonFormula $ Minimum $ Down $

479 case _schemaExclusiveMinimum of

482 case _schemaExclusiveMinimum of

480 Just True -> Exclusive $ Down n

483 Just True -> Exclusive $ Down n

481 _ -> Inclusive $ Down n }

484 _ -> Inclusive $ Down n }

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

483 multipleOfClause = case _schemaMultipleOf of

486 multipleOfClause = case _schemaMultipleOf of

484 Nothing -> top

487 Nothing -> top

485 Just n -> top

488 Just n -> top

486− { forNumber = singletonFormula MultipleOfField $ MultipleOf n }

489+ { forNumber = singletonFormula $ MultipleOf n }

487

490

488 formatClause <- case _schemaFormat of

491 formatClause <- case _schemaFormat of

489 Nothing -> pure top

492 Nothing -> pure top

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

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

491− { forNumber = singletonFormula FormatField $ NumberFormat f }

494+ { forNumber = singletonFormula $ NumberFormat f }

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

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

493− { forString = singletonFormula FormatField $ StringFormat f }

496+ { forString = singletonFormula $ StringFormat f }

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

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

495

498

496 let

499 let

497 maxLengthClause = case _schemaMaxLength of

500 maxLengthClause = case _schemaMaxLength of

498 Nothing -> top

501 Nothing -> top

499 Just n -> top

502 Just n -> top

500− { forString = singletonFormula MaxLengthField $ MaxLength n }

503+ { forString = singletonFormula $ MaxLength n }

501

504

502 minLengthClause = case _schemaMinLength of

505 minLengthClause = case _schemaMinLength of

503 Nothing -> top

506 Nothing -> top

504 Just n -> top

507 Just n -> top

505− { forString = singletonFormula MinLengthField $ MinLength n }

508+ { forString = singletonFormula $ MinLength n }

506

509

507 patternClause = case _schemaPattern of

510 patternClause = case _schemaPattern of

508 Nothing -> top

511 Nothing -> top

509 Just p -> top

512 Just p -> top

510− { forString = singletonFormula PatternField $ Pattern p }

513+ { forString = singletonFormula $ Pattern p }

511

514

512 itemsClause <- case tracedItems sch of

515 itemsClause <- case tracedItems sch of

513 Nothing -> pure top

516 Nothing -> pure top

514 Just (Left rs) -> do

517 Just (Left rs) -> do

515 f <- processRefSchema rs

518 f <- processRefSchema rs

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

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

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

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

518

521

519 let

522 let

520 maxItemsClause = case _schemaMaxItems of

523 maxItemsClause = case _schemaMaxItems of

521 Nothing -> top

524 Nothing -> top

522 Just n -> top

525 Just n -> top

523− { forArray = singletonFormula MaxItemsField $ MaxItems n }

526+ { forArray = singletonFormula $ MaxItems n }

524

527

525 minItemsClause = case _schemaMinItems of

528 minItemsClause = case _schemaMinItems of

526 Nothing -> top

529 Nothing -> top

527 Just n -> top

530 Just n -> top

528− { forArray = singletonFormula MinItemsField $ MinItems n }

531+ { forArray = singletonFormula $ MinItems n }

529

532

530 uniqueItemsClause = case _schemaUniqueItems of

533 uniqueItemsClause = case _schemaUniqueItems of

531 Just True -> top

534 Just True -> top

532− { forArray = singletonFormula UniqueItemsField UniqueItems }

535+ { forArray = singletonFormula UniqueItems }

533 _ -> top

536 _ -> top

534

537

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

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

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

546 in pure (addProps, fromMaybe fakeSchema addPropSchema)

549 in pure (addProps, fromMaybe fakeSchema addPropSchema)

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

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

548 let

551 let

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

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

550 BottomFormula -> All True

553 BottomFormula -> All True

551 _ -> All False

554 _ -> All False

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

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

553 TopFormula -> All True

556 TopFormula -> All True

554 _ -> All False

557 _ -> All False

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

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

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

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

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

562 | otherwise

565 | otherwise

563 = top

566 = top

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

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

565

568

566 maxPropertiesClause = case _schemaMaxProperties of

569 maxPropertiesClause = case _schemaMaxProperties of

567 Nothing -> top

570 Nothing -> top

568 Just n -> top

571 Just n -> top

569− { forObject = singletonFormula MaxPropertiesField $ MaxProperties n }

572+ { forObject = singletonFormula $ MaxProperties n }

570

573

571 minPropertiesClause = case _schemaMinProperties of

574 minPropertiesClause = case _schemaMinProperties of

572 Nothing -> top

575 Nothing -> top

573 Just n -> top

576 Just n -> top

574− { forObject = singletonFormula MinPropertiesField $ MinProperties n }

577+ { forObject = singletonFormula $ MinProperties n }

575

578

576 nullableClause

579 nullableClause

577 | Just True <- _schemaNullable = bottom

580 | Just True <- _schemaNullable = bottom

578− { forNull = singletonFormula NullableField $ Exactly TNull }

581+ { forNull = singletonFormula $ Exactly TNull }

579 | otherwise = bottom

582 | otherwise = bottom

580

583

581 pure $ nullableClause \/ meets (allClauses <>

584 pure $ nullableClause \/ meets (allClauses <>

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

585 , uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])

588 , uniqueItemsClause, propertiesClause, maxPropertiesClause, minPropertiesClause])

586{- TODO: ReadOnly/WriteOnly -}

589{- TODO: ReadOnly/WriteOnly -}

587

590

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

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

589checkOneOfDisjoint = const $ pure True -- TODO

592checkOneOfDisjoint = const $ pure True -- TODO

590

593

591schemaToFormula

594schemaToFormula

592− :: Definitions Schema

595+ :: Traced (Definitions Schema)

593− -> Traced OpenApi Schema

596+ -> Traced Schema

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

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

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

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

596

599

597checkFormulas

600checkFormulas

598 :: HasAll (CheckEnv Schema) xs

601 :: HasAll (CheckEnv Schema) xs

599 => HList xs

602 => HList xs

600− -> Trace OpenApi Schema

603+ -> Behavior 'SchemaLevel

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

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

602 -> CompatFormula ()

605 -> CompatFormula ()

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

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

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

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

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

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

606 [] -> do

609 [] -> do

607 -- We have the following isomorphisms:

610 -- We have the following isomorphisms:

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

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

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

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

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

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

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

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

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

634− forType_ $ \ty ->

637+ forType_ $ \tyName ty -> do

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

635 case (ty fp, ty fc) of

639 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

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

641 (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

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

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

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

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

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

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

642

646

643checkContradiction

647checkContradiction

644− :: Trace OpenApi Schema

648+ :: Behavior 'TypedSchemaLevel

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

649+ -> [Condition t]

646 -> CompatFormula ()

650 -> CompatFormula ()

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

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

648

652

649checkImplication

653checkImplication

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

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

651 => HList xs

655 => HList xs

656+ -> Behavior 'TypedSchemaLevel

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

657+ -> [Condition t]

653− -> Traced OpenApi (Condition t)

658+ -> Condition t

654 -> CompatFormula ()

659 -> CompatFormula ()

655−checkImplication env prods cons = case findExactly prods of

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

656 Just e

661 Just e

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

662+ | all (satisfiesTyped e) prods ->

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

663+ if satisfiesTyped e cons then pure ()

659− else issueAt cons (EnumDoesntSatisfy e)

664+ else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

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

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

661− Nothing -> case extract cons of

666+ Nothing -> case cons of

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

667 -- 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)

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

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

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

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

666− else issueAt cons (MatchingMaximumWeak m m')

671+ else issueAt beh (MatchingMaximumWeak m m')

667− Nothing -> issueAt cons (NoMatchingMaximum m)

672+ Nothing -> issueAt beh (NoMatchingMaximum m)

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

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

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

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

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

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

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

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

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

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

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

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

674− else issueAt cons (MatchingMultipleOfWeak m m')

679+ else issueAt beh (MatchingMultipleOfWeak m m')

675− Nothing -> issueAt cons (NoMatchingMultipleOf m)

680+ Nothing -> issueAt beh (NoMatchingMultipleOf m)

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

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

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

682+ then pure () else issueAt beh (NoMatchingFormat f)

678 MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of

683 MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of

679 Just m' -> if m' <= m then pure ()

684 Just m' -> if m' <= m then pure ()

680− else issueAt cons (MatchingMaxLengthWeak m m')

685+ else issueAt beh (MatchingMaxLengthWeak m m')

681− Nothing -> issueAt cons (NoMatchingMaxLength m)

686+ Nothing -> issueAt beh (NoMatchingMaxLength m)

682 MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of

687 MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of

683 Just m' -> if m' >= m then pure ()

688 Just m' -> if m' >= m then pure ()

684− else issueAt cons (MatchingMinLengthWeak m m')

689+ else issueAt beh (MatchingMinLengthWeak m m')

685− Nothing -> issueAt cons (NoMatchingMinLength m)

690+ Nothing -> issueAt beh (NoMatchingMinLength m)

686− Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) $ extract <$> prods

691+ Pattern p -> if any (\case Pattern p' -> p == p'; _ -> False) prods

687− then pure () else issueAt cons (NoMatchingPattern p)

692+ then pure () else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison

688− StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) $ extract <$> prods

693+ StringFormat f -> if any (\case StringFormat f' -> f == f'; _ -> False) prods

689− then pure () else issueAt cons (NoMatchingFormat f)

694+ then pure () else issueAt beh (NoMatchingFormat f)

690 Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of

695 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'

692 Just rs -> do

697 Just rs -> do

693 let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ extract <$> rs }

698 let sch = Inline mempty { _schemaAllOf = Just . NE.toList $ extract <$> rs }

694− checkCompatibility env $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace

699+ checkCompatibility env (beh >>> step InItems) $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace

695− Nothing -> issueAt cons NoMatchingItems

700+ Nothing -> issueAt beh NoMatchingItems

696 MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of

701 MaxItems m -> case findRelevant min (\case MaxItems m' -> Just m'; _ -> Nothing) prods of

697 Just m' -> if m' <= m then pure ()

702 Just m' -> if m' <= m then pure ()

698− else issueAt cons (MatchingMaxItemsWeak m m')

703+ else issueAt beh (MatchingMaxItemsWeak m m')

699− Nothing -> issueAt cons (NoMatchingMaxItems m)

704+ Nothing -> issueAt beh (NoMatchingMaxItems m)

700 MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of

705 MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of

701 Just m' -> if m' >= m then pure ()

706 Just m' -> if m' >= m then pure ()

702− else issueAt cons (MatchingMinItemsWeak m m')

707+ else issueAt beh (MatchingMinItemsWeak m m')

703− Nothing -> issueAt cons (NoMatchingMinItems m)

708+ Nothing -> issueAt beh (NoMatchingMinItems m)

704− UniqueItems -> if any (== UniqueItems) $ extract <$> prods then pure ()

709+ UniqueItems -> if any (== UniqueItems) $ prods then pure ()

705− else issueAt cons NoMatchingUniqueItems

710+ else issueAt beh NoMatchingUniqueItems

706 Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of

711 Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of

707 Just ((props', madd') NE.:| []) -> do

712 Just ((props', madd') NE.:| []) -> do

708 F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do

713 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')

710 case (M.lookup k props', madd', M.lookup k props, madd) of

715 case (M.lookup k props', madd', M.lookup k props, madd) of

711 (Nothing, Nothing, _, _) -> pure () -- vacuously

716 (Nothing, Nothing, _, _) -> pure () -- vacuously

712− (_, _, Nothing, Nothing) -> issueAt cons (UnexpectedProperty k)

717+ (_, _, Nothing, Nothing) -> issueAt beh (UnexpectedProperty k)

713 (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)

718 (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)

714 (Nothing, Just add', Just p, _) -> go add' (propRefSchema p)

719 (Nothing, Just add', Just p, _) -> go add' (propRefSchema p)

715 (Just p', _, Nothing, Just add) -> go (propRefSchema p') add

720 (Just p', _, Nothing, Just add) -> go (propRefSchema p') add

716 (Nothing, Just _, Nothing, Just _) -> pure ()

721 (Nothing, Just _, Nothing, Just _) -> pure ()

717 case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of

722 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)

719 _ -> pure ()

724 _ -> pure ()

720 pure ()

725 pure ()

721 case (madd', madd) of

726 case (madd', madd) of

722 (Nothing, _) -> pure () -- vacuously

727 (Nothing, _) -> pure () -- vacuously

723− (_, Nothing) -> issueAt cons NoAdditionalProperties

728+ (_, Nothing) -> issueAt beh NoAdditionalProperties

724− (Just add', Just add) -> checkCompatibility env (ProdCons add' add)

729+ (Just add', Just add) -> checkCompatibility env (beh >>> step InAdditionalProperty) (ProdCons add' add)

725 pure ()

730 pure ()

726− Nothing -> issueAt cons NoMatchingProperties

731+ Nothing -> issueAt beh NoMatchingProperties

727 MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of

732 MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of

728 Just m' -> if m' <= m then pure ()

733 Just m' -> if m' <= m then pure ()

729− else issueAt cons (MatchingMaxPropertiesWeak m m')

734+ else issueAt beh (MatchingMaxPropertiesWeak m m')

730− Nothing -> issueAt cons (NoMatchingMaxProperties m)

735+ Nothing -> issueAt beh (NoMatchingMaxProperties m)

731 MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of

736 MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of

732 Just m' -> if m' >= m then pure ()

737 Just m' -> if m' >= m then pure ()

733− else issueAt cons (MatchingMinPropertiesWeak m m')

738+ else issueAt beh (MatchingMinPropertiesWeak m m')

734− Nothing -> issueAt cons (NoMatchingMinProperties m)

739+ Nothing -> issueAt beh (NoMatchingMinProperties m)

735 where

740 where

736− findExactly ((extract -> Exactly x):_) = Just x

741+ findExactly (Exactly x:_) = Just x

737 findExactly (_:xs) = findExactly xs

742 findExactly (_:xs) = findExactly xs

738 findExactly [] = Nothing

743 findExactly [] = Nothing

739 findRelevant combine extr

744 findRelevant combine extr

740− = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe (extr . extract)

745+ = fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr

741 lcmScientific (toRational -> a) (toRational -> b)

746 lcmScientific (toRational -> a) (toRational -> b)

742 = fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

747 = fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

743

748

744−instance Typeable t => Subtree (Condition t) where

749+instance Issuable 'TypedSchemaLevel where

745− data CheckIssue (Condition t)

750+ data Issue 'TypedSchemaLevel

746− = EnumDoesntSatisfy (TypedValue t)

751+ = EnumDoesntSatisfy A.Value

747− | NoMatchingEnum (TypedValue t)

752+ | NoMatchingEnum A.Value

748 | NoMatchingMaximum (Bound Scientific)

753 | NoMatchingMaximum (Bound Scientific)

749 | MatchingMaximumWeak (Bound Scientific) (Bound Scientific)

754 | MatchingMaximumWeak (Bound Scientific) (Bound Scientific)

750 | NoMatchingMinimum (Bound Scientific)

755 | NoMatchingMinimum (Bound Scientific)

@@ -771,29 +776,42 @@ instance Typeable t => Subtree (Condition t) where

771 | MatchingMaxPropertiesWeak Integer Integer

776 | MatchingMaxPropertiesWeak Integer Integer

772 | NoMatchingMinProperties Integer

777 | NoMatchingMinProperties Integer

773 | MatchingMinPropertiesWeak Integer Integer

778 | MatchingMinPropertiesWeak Integer Integer

779+ | NoMatchingCondition [SomeCondition]

780+ | NoContradiction

774 deriving stock (Eq, Ord, Show)

781 deriving stock (Eq, Ord, Show)

775− type CheckEnv (Condition t) = CheckEnv Schema

782+ issueIsUnsupported _ = False

776− normalizeTrace = undefined

777− checkCompatibility env pc = checkImplication env [producer pc] (consumer pc)

778

783

779−instance Subtree Schema where

784+instance Issuable 'SchemaLevel where

780− data CheckIssue Schema

785+ data Issue 'SchemaLevel

781 = NotSupported Text

786 = NotSupported Text

782 | InvalidSchema Text

787 | InvalidSchema Text

783− | NoMatchingCondition [SomeCondition]

784− | NoContradiction

785 deriving stock (Eq, Ord, Show)

788 deriving stock (Eq, Ord, Show)

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

786− type CheckEnv Schema = '[ProdCons (Definitions Schema)]

805+ type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]

787− checkCompatibility env schs = do

806+ checkCompatibility env beh schs = do

788 let defs = getH env

807 let defs = getH env

789− checkFormulas env (ask $ producer schs) $ schemaToFormula <$> defs <*> schs

808+ checkFormulas env beh $ schemaToFormula <$> defs <*> schs

790

809

791instance Subtree (Referenced Schema) where

810instance Subtree (Referenced Schema) where

792− data CheckIssue (Referenced Schema)

811+ type SubtreeLevel (Referenced Schema) = 'SchemaLevel

793− deriving stock (Eq, Ord, Show)

794 type CheckEnv (Referenced Schema) = CheckEnv Schema

812 type CheckEnv (Referenced Schema) = CheckEnv Schema

795− checkCompatibility env refs = do

813+ checkCompatibility env beh refs = do

796 let

814 let

797 defs = getH env

815 defs = getH env

798 schs = dereference <$> defs <*> refs

816 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 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

3module OpenAPI.Checker.Validate.SecurityRequirement

4− ( CheckIssue (..)

4+ ( Issue (..)

5 ) where

7import Data.OpenApi

8+import OpenAPI.Checker.Behavior

8import OpenAPI.Checker.Subtree

9import OpenAPI.Checker.Subtree

11+instance Issuable 'SecurityRequirementLevel where

12+ data Issue 'SecurityRequirementLevel

13+ = SecurityRequirementNotMet

14+ deriving stock (Eq, Ord, Show)

15+ issueIsUnsupported _ = False

16+

10instance Subtree SecurityRequirement where

17instance Subtree SecurityRequirement where

18+ type SubtreeLevel SecurityRequirement = 'SecurityRequirementLevel

11 type

19 type

12 CheckEnv SecurityRequirement =

20 CheckEnv SecurityRequirement =

13− '[ ProdCons (Definitions SecurityScheme)

21+ '[ ProdCons (Traced (Definitions SecurityScheme))

14 ]

22 ]

15− data CheckIssue SecurityRequirement

16− = SecurityRequirementNotMet

17− deriving (Eq, Ord, Show)

18 checkCompatibility = undefined

23 checkCompatibility = undefined

src/OpenAPI/Checker/Validate/Server.hs+50−36

@@ -1,7 +1,7 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

3module OpenAPI.Checker.Validate.Server

4− ( CheckIssue (..)

4+ ( Issue (..)

5 )

6where

@@ -20,41 +20,51 @@ import Data.OpenApi

20import Data.Text (Text)

21import qualified Data.Text as T

22import Data.Traversable

23+import OpenAPI.Checker.Behavior

24+import OpenAPI.Checker.Paths

23import OpenAPI.Checker.Subtree

25import OpenAPI.Checker.Subtree

24−import OpenAPI.Checker.Trace

26+import OpenAPI.Checker.Validate.MediaTypeObject

25import Prelude as P

27import Prelude as P

27tracedParsedServerUrlParts

29tracedParsedServerUrlParts

28− :: Traced' r [Server] Server

30+ :: Server

29− -> Traced' r ProcessedServer (Either (CheckIssue ProcessedServer) ProcessedServer)

31+ -> Either (Issue 'ServerLevel) ProcessedServer

30tracedParsedServerUrlParts s =

32tracedParsedServerUrlParts s =

31− let rawURL = _serverUrl $ extract s

32− parsedUrl = parseServerUrl rawURL

33+ let parsedUrl = parseServerUrl $ _serverUrl s

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

34+ lookupVar var = case IOHM.lookup var (_serverVariables s) of

38− Nothing -> Left VariableNotDefined

35+ Nothing -> Left $ ServerVariableNotDefined var

39− Just x -> Right x)

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)

41instance Subtree [Server] where

44instance Subtree [Server] where

45+ type SubtreeLevel [Server] = 'OperationLevel

42 type CheckEnv [Server] = '[]

46 type CheckEnv [Server] = '[]

43− data CheckIssue [Server]

44− deriving (Eq, Ord, Show)

45− checkCompatibility env pcServer = do

47+ checkCompatibility env beh pcServer = do

46 let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =

48 let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =

49+ pcServer

50+ <&> partitionEithers

51+ . fmap

52+ (\(Traced t s) ->

53+ let bhv = beh >>> step (InServer $ _serverUrl s)

47− pcServer <&> partitionEithers . fmap (bicosequence . tracedParsedServerUrlParts) . sequence

54+ in case tracedParsedServerUrlParts s of

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

55+ Left e -> Left $ issueAt bhv e

51− Right a -> Right $ x $> a

56+ Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u))

52− throwAllErrors = traverse_ tracedIssue

57+ . sequence

53− throwAllErrors pErrs

58+ sequenceA_ pErrs

54− throwAllErrors cErrs

59+ sequenceA_ cErrs

55− for_ pUrls $ \cUrl -> do

60+ for_ pUrls $ \(bhv, pUrl) -> do

56− let potentiallyCompatible = P.filter ((staticCompatible `on` extract) cUrl) cUrls

61+ let potentiallyCompatible = P.filter ((staticCompatible `on` extract) pUrl) $ fmap snd cUrls

62+ anyOfAt

63+ bhv

64+ ServerNotMatched

57− anyOfSubtreeAt cUrl ServerNotMatched $ potentiallyCompatible <&> (checkCompatibility env . ProdCons cUrl)

65+ [ checkCompatibility env bhv (ProdCons pUrl cUrl)

66+ | cUrl <- potentiallyCompatible

67+ ]

58 pure ()

68 pure ()

60type ProcessedServer = [ServerUrlPart ServerVariable]

70type ProcessedServer = [ServerUrlPart ServerVariable]

@@ -108,22 +118,26 @@ instance Steppable [Server] ProcessedServer where

108 data Step [Server] ProcessedServer = ServerStep Text

118 data Step [Server] ProcessedServer = ServerStep Text

109 deriving (Eq, Ord, Show)

119 deriving (Eq, Ord, Show)

110

120

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+

111instance Subtree ProcessedServer where

130instance Subtree ProcessedServer where

131+ type SubtreeLevel ProcessedServer = 'ServerLevel

112 type CheckEnv ProcessedServer = '[]

132 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 =

120 -- traversing here is fine because we have already filtered for length

134 -- traversing here is fine because we have already filtered for length

121 for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of

135 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)

123 -- Consumer can consume anything

137 -- Consumer can consume anything

124 (_, Nothing) -> pure ()

138 (_, Nothing) -> pure ()

125 -- Producer can produce anythings, but consumer has a finite enum ;(

139 -- Producer can produce anythings, but consumer has a finite enum ;(

126− (Nothing, Just _) -> issueAt p (ConsumerNotOpen i)

140+ (Nothing, Just _) -> issueAt beh (ConsumerNotOpen i)

127 where

141 where

128 zipProdCons :: ProdCons [a] -> [(a, a)]

142 zipProdCons :: ProdCons [a] -> [(a, a)]

129 zipProdCons (ProdCons x y) = zip x y

143 zipProdCons (ProdCons x y) = zip x y

src/OpenAPI/Checker/Validate/Sums.hs+11−13

@@ -5,22 +5,20 @@ module OpenAPI.Checker.Validate.Sums

5import Data.Foldable

6import Data.Map.Strict (Map)

7import qualified Data.Map.Strict as M

8+import OpenAPI.Checker.Behavior

8import OpenAPI.Checker.Subtree

9import OpenAPI.Checker.Subtree

9−import OpenAPI.Checker.Trace

10+import OpenAPI.Checker.Paths

10−

12checkSums

13− :: forall k r t

13+ :: (Ord k, Issuable l)

14− . (Ord k, Subtree t)

14+ => Paths q r l

15− => (k -> CheckIssue t)

15+ -> (k -> Issue l)

16− -> (k -> ProdCons (Traced r t) -> CompatFormula' SubtreeCheckIssue r ())

16+ -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())

17− -> ProdCons (Map k (Traced r t))

17+ -> ProdCons (Map k t)

18− -> CompatFormula' SubtreeCheckIssue r ()

18+ -> CompatFormula' q AnIssue r ()

19−checkSums noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

19+checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

20 case M.lookup key c of

21− Nothing -> issueAt prodElt $ noElt key

21+ Nothing -> issueAt xs $ noElt key

22 Just consElt ->

23− let

24− sumElts :: ProdCons (Traced r t)

25− sumElts = ProdCons prodElt consElt

23+ let sumElts = ProdCons prodElt consElt

26 in check key sumElts

24 in check key sumElts

test/Spec/Golden/TraceTree.hs+2−2

@@ -7,7 +7,7 @@ import Control.Category

7import Data.HList

8import qualified Data.Yaml as Yaml

9import OpenAPI.Checker.Subtree

10−import OpenAPI.Checker.Trace

10+import OpenAPI.Checker.Paths

11import OpenAPI.Checker.Validate.OpenApi ()

12import Spec.Golden.Extra

13import Test.Tasty (TestTree)

@@ -21,4 +21,4 @@ tests =

21 "trace-tree.yaml"

22 ("a.yaml", "b.yaml")

23 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 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

3+ InOperation PostMethod:

5− OperationRequestBodyStep:

4+ InRequest:

6− InlineStep:

5+ InPayload:

7− RequestMediaTypeObject application/json:

6+ PayloadSchema:

8− MediaTypeSchema:

9− ReferencedStep (Reference {getReference = "Test"}):

10− MaximumFields: MatchingMaximumWeak (Inclusive 2.0) (Inclusive 3.0)

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 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

3+ InOperation PostMethod:

4− OperationMethodStep PostMethod:

5− OperationParamsStep 0:

6− InlineStep: ParamEmptinessIncompatible

4+ InParam "test1": ParamEmptinessIncompatible

test/golden/common/pathItem/operation/parameters/change/trace-tree.yaml+5−7

@@ -1,8 +1,6 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

3+ InOperation PostMethod:

4− OperationMethodStep PostMethod:

4+ InParam "test":

5− OperationParamsStep 0:

5+ InParamSchema:

6− InlineStep:

7− ParamSchema:

8− InlineStep: NoContradiction

6+ OfType String: NoContradiction

test/golden/common/pathItem/operation/parameters/required/set/trace-tree.yaml+3−5

@@ -1,6 +1,4 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

3+ InOperation PostMethod:

4− OperationMethodStep PostMethod:

5− OperationParamsStep 0:

6− InlineStep: ParamRequired

4+ InParam "test1": ParamRequired

test/golden/common/pathItem/operation/parameters/required/true/add/trace-tree.yaml+2−5

@@ -1,6 +1,3 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

5− OperationParamsStep 1:

6− InlineStep: ParamNotMatched "test2"

3+ InOperation PostMethod: ParamNotMatched "test2"

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/trace-tree.yaml+6−8

@@ -1,9 +1,7 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

3+ InOperation PostMethod:

4− OperationMethodStep PostMethod:

4+ InRequest:

5− OperationRequestBodyStep:

5+ InPayload:

6− InlineStep:

6+ PayloadSchema:

7− RequestMediaTypeObject application/json:

8− MediaTypeSchema:

9− InlineStep: NoContradiction

7+ OfType String: NoContradiction

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/trace-tree.yaml+3−6

@@ -1,7 +1,4 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

3+ InOperation PostMethod:

5− OperationRequestBodyStep:

6− InlineStep:

7− RequestMediaTypeObject application/x-www-form-urlencoded: RequestMediaTypeNotFound

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 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

3+ InOperation PostMethod:

5− OperationRequestBodyStep:

6− InlineStep: RequestBodyRequired

4+ InRequest: RequestBodyRequired

test/golden/common/pathItem/operation/responses/add/trace-tree.yaml+2−6

@@ -1,7 +1,3 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

3+ InOperation PostMethod: ResponseCodeNotFound 500

4− OperationMethodStep PostMethod:

5− OperationResponsesStep:

6− ResponseCodeStep 500:

7− InlineStep: ResponseCodeNotFound

test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/trace-tree.yaml+3−8

@@ -1,9 +1,4 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

3+ InOperation PostMethod:

4− OperationMethodStep PostMethod:

5− OperationResponsesStep:

6− ResponseCodeStep 200:

7− InlineStep:

8− ResponseHeader "Test2":

9− InlineStep: ResponseHeaderMissing

4+ WithStatusCode 200: ResponseHeaderMissing "Test2"

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/trace-tree.yaml+3−7

@@ -1,8 +1,4 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

3+ InOperation PostMethod:

5− OperationResponsesStep:

6− ResponseCodeStep 200:

7− InlineStep:

8− ResponseMediaObject application/x-www-form-urlencoded: ResponseMediaTypeMissing

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 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

3+ InOperation PostMethod:

4− OperationMethodStep PostMethod:

4+ WithStatusCode 200:

5− OperationResponsesStep:

5+ ResponsePayload:

6− ResponseCodeStep 200:

6+ PayloadSchema:

7− InlineStep:

8− ResponseMediaObject application/json:

9− MediaTypeSchema:

10− InlineStep: NoContradiction

7+ OfType Boolean: NoContradiction

test/golden/common/property-removed/trace-tree.yaml+10−16

@@ -1,17 +1,11 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

4− OperationMethodStep PostMethod:

3+ InOperation PostMethod:

5− OperationResponsesStep:

4+ InRequest:

6− ResponseCodeStep 200:

5+ InPayload:

7− InlineStep:

6+ PayloadSchema:

8− ResponseMediaObject application/json:

7+ OfType Object: UnexpectedProperty "property2"

9− MediaTypeSchema:

8+ WithStatusCode 200:

10− ReferencedStep (Reference {getReference = "Test"}):

9+ ResponsePayload:

10+ PayloadSchema:

11− PropertiesFields: PropertyNowRequired "property2"

11+ OfType Object: PropertyNowRequired "property2"

12− OperationRequestBodyStep:

13− InlineStep:

14− RequestMediaTypeObject application/json:

15− MediaTypeSchema:

16− ReferencedStep (Reference {getReference = "Test"}):

17− PropertiesFields: UnexpectedProperty "property2"

test/golden/common/property-required/trace-tree.yaml+6−9

@@ -1,10 +1,7 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/test", consumer = "/test"}):

3− MatchedPathStep "/test":

3+ InOperation PostMethod:

4− OperationMethodStep PostMethod:

4+ InRequest:

5− OperationRequestBodyStep:

5+ InPayload:

6− InlineStep:

6+ PayloadSchema:

7− RequestMediaTypeObject application/json:

8− MediaTypeSchema:

9− ReferencedStep (Reference {getReference = "Test"}):

10− PropertiesFields: PropertyNowRequired "property2"

7+ OfType Object: PropertyNowRequired "property2"

test/golden/common/servers/trace-tree.yaml+6−8

@@ -1,9 +1,7 @@

1Left:

2− OpenApiPathsStep:

2+ AtPath (ProdCons {producer = "/pets", consumer = "/pets"}):

3− MatchedPathStep "/pets":

3+ InOperation GetMethod:

4− OperationMethodStep GetMethod:

5− OperationServersStep:

6− ServerStep "http://missing.url": ServerNotMatched

7− ServerStep "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":

4+ InServer "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":

8− - EnumValueNotConsumed 1 "a"

5+ - EnumValueNotConsumed 1 "a"

9− - ConsumerNotOpen 7

6+ - ConsumerNotOpen 7

7+ InServer "http://missing.url": ServerNotMatched