649261f · typeable/compaREST

openapi-diff.cabal+1

compare with master

unifiedsplit

@@ -34,6 +34,7 @@ common common-options

34 -Wno-all-missed-specialisations

35 -Wno-missing-local-signatures

36 -Wno-unsafe

37+ -fconstraint-solver-iterations=0

37 default-language: Haskell2010

38 default-language: Haskell2010

38 build-depends: base >= 4.12.0.0 && < 4.16

39 build-depends: base >= 4.12.0.0 && < 4.16

39 , bytestring

40 , bytestring

src/Data/HList.hs+30

@@ -4,6 +4,8 @@ module Data.HList

4 , getH

5 , HList (..)

6 , singletonH

7+ , ReassembleHList

8+ , reassemble

7 )

9 )

8where

10where

9

11

@@ -31,21 +33,49 @@ class t ~ HeadEq x xs => Has' (x :: Type) (xs :: [Type]) (t :: Bool) where

31

33

32instance Has' x (x ': xs) 'True where

34instance Has' x (x ': xs) 'True where

33 getH (HCons x _) = x

35 getH (HCons x _) = x

36+ {-# INLINE getH #-}

34

37

35instance (Has' x xs t, HeadEq x (y : xs) ~ 'False) => Has' x (y ': xs) 'False where

38instance (Has' x xs t, HeadEq x (y : xs) ~ 'False) => Has' x (y ': xs) 'False where

36 getH (HCons _ xs) = getH xs

39 getH (HCons _ xs) = getH xs

40+ {-# INLINE getH #-}

37

41

38instance

42instance

39 TypeError ('ShowType x ':<>: 'Text " is not a part of the list.")

43 TypeError ('ShowType x ':<>: 'Text " is not a part of the list.")

40 => Has' x '[] 'False

44 => Has' x '[] 'False

41 where

45 where

42 getH HNil = undefined

46 getH HNil = undefined

47+ {-# INLINE getH #-}

43

48

44singletonH :: a -> HList '[a]

49singletonH :: a -> HList '[a]

45singletonH a = a `HCons` HNil

50singletonH a = a `HCons` HNil

51+{-# INLINE singletonH #-}

46

52

47instance Eq (HList '[]) where

53instance Eq (HList '[]) where

48 HNil == HNil = True

54 HNil == HNil = True

49

55

50instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) where

56instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) where

51 (HCons x xs) == (HCons y ys) = x == y && xs == ys

57 (HCons x xs) == (HCons y ys) = x == y && xs == ys

58+

59+type family (==) a b :: Bool where

60+ a == a = 'True

61+ _ == _ = 'False

62+

63+type ReassembleHList xs ys = ReassembleHList' xs ys (xs == ys)

64+

65+class f ~ (xs == ys) => ReassembleHList' xs ys f where

66+ reassemble :: HList xs -> HList ys

67+

68+instance ReassembleHList' xs xs 'True where

69+ reassemble = id

70+ {-# INLINE reassemble #-}

71+

72+instance ReassembleHList' (x ': xs) '[] 'False where

73+ reassemble _ = HNil

74+ {-# INLINE reassemble #-}

75+

76+instance

77+ (Has y xs, ReassembleHList' xs ys f, (xs == (y ': ys)) ~ 'False)

78+ => ReassembleHList' xs (y ': ys) 'False

79+ where

80+ reassemble xs = getH @y xs `HCons` reassemble xs

81+ {-# INLINE reassemble #-}

src/OpenAPI/Checker/Behavior.hs+6−3

@@ -53,12 +53,15 @@ class (Typeable l, Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLeve

53 -- based on the context the issue might need to be rendered as "opposite" ('Backward')

54 -- – for example when rendering non-breaking changes everything should be

55 -- reversed (a consequence of the way we generate non-breaking changes).

56+ --

57+ -- If _consumer_ doesn't have something, the element was "removed".

58+ -- If _producer_ doesn't have something, the element was "added".

56 describeIssue :: Orientation -> Issue l -> Blocks

59 describeIssue :: Orientation -> Issue l -> Blocks

57

60

58 issueIsUnsupported :: Issue l -> Bool

61 issueIsUnsupported :: Issue l -> Bool

59

62

60data Orientation = Forward | Backward

63data Orientation = Forward | Backward

61− deriving stock (Eq, Ord)

64+ deriving stock (Eq, Ord, Show)

62

65

63toggleOrientation :: Orientation -> Orientation

66toggleOrientation :: Orientation -> Orientation

64toggleOrientation Forward = Backward

67toggleOrientation Forward = Backward

@@ -71,7 +74,7 @@ instance Issuable l => ToJSON (Issue l) where

71 toJSON = toJSON . show

74 toJSON = toJSON . show

72

75

73data AnIssue (l :: BehaviorLevel) where

76data AnIssue (l :: BehaviorLevel) where

74− AnIssue :: Issuable l => Issue l -> AnIssue l

77+ AnIssue :: Issuable l => Orientation -> Issue l -> AnIssue l

75

78

76deriving stock instance Show (AnIssue l)

79deriving stock instance Show (AnIssue l)

77

80

@@ -80,4 +83,4 @@ deriving stock instance Eq (AnIssue l)

80deriving stock instance Ord (AnIssue l)

83deriving stock instance Ord (AnIssue l)

81

84

82instance ToJSON (AnIssue l) where

85instance ToJSON (AnIssue l) where

83− toJSON (AnIssue issue) = toJSON issue

86+ toJSON (AnIssue _ issue) = toJSON issue

src/OpenAPI/Checker/PathsPrefixTree.hs+13−1

@@ -14,6 +14,7 @@ module OpenAPI.Checker.PathsPrefixTree

14 , embed

15 , size

16 , partition

17+ , map

17 )

18 )

18where

19where

19

20

@@ -32,7 +33,7 @@ import qualified Data.Vector as V

32import qualified GHC.Exts as Exts

33import qualified GHC.Exts as Exts

33import OpenAPI.Checker.Paths

34import OpenAPI.Checker.Paths

34import Type.Reflection

35import Type.Reflection

35−import Prelude hiding (filter, null)

36+import Prelude hiding (filter, map, null)

36

37

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

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

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

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

@@ -41,6 +42,10 @@ data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPref

41 }

42 }

42 deriving stock (Show)

43 deriving stock (Show)

43

44

45+map :: (forall x. f x -> f x) -> PathsPrefixTree q f r -> PathsPrefixTree q f r

46+map f (PathsPrefixTree roots branches) =

47+ PathsPrefixTree (mapASet f roots) (TRM.hoist (mapAStep f) branches)

48+

44-- TODO: optimize

49-- TODO: optimize

45partition :: (forall a. f a -> Bool) -> PathsPrefixTree q f r -> (PathsPrefixTree q f r, PathsPrefixTree q f r)

50partition :: (forall a. f a -> Bool) -> PathsPrefixTree q f r -> (PathsPrefixTree q f r, PathsPrefixTree q f r)

46partition f x = (filter f x, filter (not . f) x)

51partition f x = (filter f x, filter (not . f) x)

@@ -116,6 +121,10 @@ data ASet (a :: Type) where

116 AnEmptySet :: ASet a

121 AnEmptySet :: ASet a

117 ASet :: Ord a => S.Set a -> ASet a

122 ASet :: Ord a => S.Set a -> ASet a

118

123

124+mapASet :: (Ord a => Ord b) => (a -> b) -> ASet a -> ASet b

125+mapASet _ AnEmptySet = AnEmptySet

126+mapASet f (ASet s) = ASet $ S.map f s

127+

119deriving stock instance Show a => Show (ASet a)

128deriving stock instance Show a => Show (ASet a)

120

129

121toSet :: ASet a -> S.Set a

130toSet :: ASet a -> S.Set a

@@ -149,6 +158,9 @@ data AStep (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: k) where

149 !(M.Map (q r a) (PathsPrefixTree q f a))

158 !(M.Map (q r a) (PathsPrefixTree q f a))

150 -> AStep q f r a

159 -> AStep q f r a

151

160

161+mapAStep :: (forall x. f x -> f x) -> AStep q f r a -> AStep q f r a

162+mapAStep f (AStep m) = AStep $ M.map (map f) m

163+

152deriving stock instance Eq (AStep q f r a)

164deriving stock instance Eq (AStep q f r a)

153

165

154deriving stock instance Ord (AStep q f r a)

166deriving stock instance Ord (AStep q f r a)

src/OpenAPI/Checker/References.hs+7−7

@@ -34,16 +34,16 @@ instance Subtree a => Subtree (Referenced a) where

34 type CheckEnv (Referenced a) = ProdCons (Traced (Definitions a)) ': CheckEnv a

35 type SubtreeLevel (Referenced a) = SubtreeLevel a

36

37− checkStructuralCompatibility env pc' = do

37+ checkStructuralCompatibility (defs `HCons` env) pc' = do

38 let pc = do

39 x <- pc'

40− defs <- getH @(ProdCons (Traced (Definitions a))) env

40+ defs' <- defs

41− pure (dereference defs x)

41+ pure (dereference defs' x)

42 checkSubstructure env pc

43

44− checkSemanticCompatibility env bhv pc' = do

44+ checkSemanticCompatibility (defs `HCons` env) bhv pc' = do

45 let pc = do

46 x <- pc'

47− defs <- getH @(ProdCons (Traced (Definitions a))) env

47+ defs' <- defs

48− pure (dereference defs x)

48+ pure (dereference defs' x)

49− checkCompatibility env bhv pc

49+ checkCompatibility bhv env pc

src/OpenAPI/Checker/Report.hs+15−36

@@ -14,7 +14,6 @@ import Data.Either

14import Data.Foldable

15import Data.Function

16import Data.Functor

17−import Data.Functor.Const

18import Data.List.NonEmpty

17import Data.List.NonEmpty

19import qualified Data.List.NonEmpty as NE

18import qualified Data.List.NonEmpty as NE

20import qualified Data.Map as M

19import qualified Data.Map as M

@@ -33,17 +32,13 @@ import OpenAPI.Checker.Paths

33import OpenAPI.Checker.PathsPrefixTree hiding (empty)

32import OpenAPI.Checker.PathsPrefixTree hiding (empty)

34import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty)

33import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty)

35import OpenAPI.Checker.Report.Jet

34import OpenAPI.Checker.Report.Jet

35+import OpenAPI.Checker.Subtree (invertIssueOrientationP)

36import OpenAPI.Checker.Validate.OpenApi

37import OpenAPI.Checker.Validate.Schema

38import Text.Pandoc.Builder

39

40type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel

41

42−type ProcessedChanges a = P.PathsPrefixTree Behave (FunctorTuple (Const Orientation) AnIssue) a

43−

44−data FunctorTuple f g a = FunctorTuple (f a) (g a)

45− deriving stock (Eq, Ord)

46−

47data ReportInput = ReportInput

42data ReportInput = ReportInput

48 { breakingChanges :: Changes

43 { breakingChanges :: Changes

49 , nonBreakingChanges :: Changes

44 , nonBreakingChanges :: Changes

@@ -59,28 +54,12 @@ data ReportStatus

59 -- there actually are any breaking changes.

54 -- there actually are any breaking changes.

60 OnlyUnsupportedChanges

55 OnlyUnsupportedChanges

61

56

62−preprocessChanges :: Orientation -> Changes -> ProcessedChanges 'APILevel

63−preprocessChanges initialO = P.fromList . fmap process . P.toList

64− where

65− process :: AnItem Behave AnIssue 'APILevel -> AnItem Behave (FunctorTuple (Const Orientation) AnIssue) 'APILevel

66− process (AnItem paths issue) = AnItem paths $ FunctorTuple (Const $ toggle initialO) issue

67− where

68− (Endo toggle) = togglePaths paths

69−

70− togglePaths :: Paths Behave a c -> Endo Orientation

71− togglePaths Root = mempty

72− togglePaths (rest `Snoc` (_ :: Behave b c)) = case eqT @c @'ResponseLevel of

73− Just Refl -> Endo toggleOrientation <> togglePaths rest

74− Nothing -> togglePaths rest

75−

76generateReport :: ReportInput -> (Pandoc, ReportStatus)

57generateReport :: ReportInput -> (Pandoc, ReportStatus)

77generateReport inp =

58generateReport inp =

78− let partitionUnsupported = P.partition (\(AnIssue i) -> issueIsUnsupported i)

59+ let partitionUnsupported = P.partition (\(AnIssue _ i) -> issueIsUnsupported i)

79− (bUnsupported, preprocessChanges Forward -> breaking) =

80− partitionUnsupported $ breakingChanges inp

60+ (bUnsupported, breaking) = partitionUnsupported $ breakingChanges inp

81− (nbUnsupported, preprocessChanges Backward -> nonBreaking) =

82− partitionUnsupported $ nonBreakingChanges inp

61+ (nbUnsupported, invertIssueOrientationP -> nonBreaking) = partitionUnsupported $ nonBreakingChanges inp

83− unsupported = preprocessChanges Forward $ bUnsupported <> nbUnsupported

62+ unsupported = bUnsupported <> nbUnsupported

84 breakingChangesPresent = not $ P.null breaking

63 breakingChangesPresent = not $ P.null breaking

85 nonBreakingChangesPresent = not $ P.null nonBreaking

64 nonBreakingChangesPresent = not $ P.null nonBreaking

86 unsupportedChangesPresent = not $ P.null unsupported

65 unsupportedChangesPresent = not $ P.null unsupported

@@ -145,24 +124,24 @@ smartHeader i = do

145 h <- asks headerLevel

124 h <- asks headerLevel

146 tell $ header h i

125 tell $ header h i

147

126

148−showErrs :: forall a. Typeable a => ProcessedChanges a -> ReportMonad ()

127+showErrs :: forall a. Typeable a => P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()

149showErrs x@(P.PathsPrefixNode currentIssues _) = do

128showErrs x@(P.PathsPrefixNode currentIssues _) = do

150 let -- Extract this pattern if more cases like this arise

129 let -- Extract this pattern if more cases like this arise

151 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])

130 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])

152− , otherIssues :: Set (FunctorTuple (Const Orientation) AnIssue a)

131+ , otherIssues :: Set (AnIssue a)

153 ) = case eqT @a @'APILevel of

132 ) = case eqT @a @'APILevel of

154 Just Refl

133 Just Refl

155− | (S.toList -> p@(FunctorTuple (Const ori) _ : _), o) <-

134+ | (S.toList -> p@((AnIssue ori _) : _), o) <-

156 S.partition

135 S.partition

157− (\(FunctorTuple _ (AnIssue u)) -> case u of

136+ (\((AnIssue _ u)) -> case u of

158 NoPathsMatched {} -> True

137 NoPathsMatched {} -> True

159 AllPathsFailed {} -> True)

138 AllPathsFailed {} -> True)

160 currentIssues ->

139 currentIssues ->

161− let p' = p <&> (\(FunctorTuple _ (AnIssue i)) -> i)

140+ let p' = p <&> (\(AnIssue _ i) -> i)

162 in (Just (ori, p'), o)

141 in (Just (ori, p'), o)

163 _ -> (Nothing, currentIssues)

142 _ -> (Nothing, currentIssues)

164 jts <- asks sourceJets

143 jts <- asks sourceJets

165− for_ otherIssues $ \(FunctorTuple (Const ori) (AnIssue i)) -> tell . describeIssue ori $ i

144+ for_ otherIssues $ \(AnIssue ori i) -> tell . describeIssue ori $ i

166 case removedPaths of

145 case removedPaths of

167 Just (ori, paths) -> do

146 Just (ori, paths) -> do

168 smartHeader $ case ori of

147 smartHeader $ case ori of

@@ -240,8 +219,8 @@ jets =

240

219

241observeJetShowErrs

220observeJetShowErrs

242 :: ReportJet' Behave Inlines

221 :: ReportJet' Behave Inlines

243− -> ProcessedChanges a

222+ -> P.PathsPrefixTree Behave AnIssue a

244− -> ReportMonad (ProcessedChanges a)

223+ -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)

245observeJetShowErrs jet p = case observeJetShowErrs' jet p of

224observeJetShowErrs jet p = case observeJetShowErrs' jet p of

246 Just m -> m

225 Just m -> m

247 Nothing -> pure p

226 Nothing -> pure p

@@ -249,8 +228,8 @@ observeJetShowErrs jet p = case observeJetShowErrs' jet p of

249observeJetShowErrs'

228observeJetShowErrs'

250 :: forall a.

229 :: forall a.

251 ReportJet' Behave Inlines

230 ReportJet' Behave Inlines

252− -> ProcessedChanges a

231+ -> P.PathsPrefixTree Behave AnIssue a

253− -> Maybe (ReportMonad (ProcessedChanges a))

232+ -> Maybe (ReportMonad (P.PathsPrefixTree Behave AnIssue a))

254observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =

233observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =

255 let results =

234 let results =

256 subIssues >>= \(WrapTypeable (AStep m)) ->

235 subIssues >>= \(WrapTypeable (AStep m)) ->

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

@@ -24,7 +24,7 @@ runChecker (client, server) =

24 { producer = traced (step ClientSchema) p

25 , consumer = traced (step ServerSchema) c

26 }

27− run p c = either id mempty . runCompatFormula . checkCompatibility HNil Root $ toPC p c

27+ run p c = either id mempty . runCompatFormula . checkCompatibility Root HNil $ toPC p c

28

29runReport :: (OpenApi, OpenApi) -> (Pandoc, ReportStatus)

30runReport = generateReport . runChecker

src/OpenAPI/Checker/Subtree.hs+80−46

@@ -18,10 +18,14 @@ module OpenAPI.Checker.Subtree

18 , CompatFormula'

19 , SemanticCompatFormula

20 , ProdCons (..)

21− , HasUnsupportedFeature (..)

22 , swapProdCons

21 , swapProdCons

23 , runCompatFormula

22 , runCompatFormula

24 , issueAt

23 , issueAt

24+ , anItem

25+ , anIssue

26+ , invertIssueOrientation

27+ , invertIssueOrientationP

28+ , embedFormula

25 , anyOfAt

29 , anyOfAt

26 , structuralIssue

30 , structuralIssue

27

31

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

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

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

54import Data.Hashable

58import Data.Hashable

55import Data.Kind

59import Data.Kind

56−import Data.Monoid

57import Data.OpenApi

60import Data.OpenApi

58import qualified Data.Set as S

61import qualified Data.Set as S

59import Data.Typeable

62import Data.Typeable

@@ -106,8 +109,38 @@ data ProdCons a = ProdCons

106 }

109 }

107 deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)

110 deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)

108

111

109−swapProdCons :: ProdCons a -> ProdCons a

112+swapProdCons

113+ :: SwapEnvRoles xs

114+ => (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

115+ -> (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

110−swapProdCons (ProdCons a b) = ProdCons b a

116+swapProdCons f e (ProdCons p c) =

117+ invertIssueOrientation $

118+ f (swapEnvRoles e) (ProdCons c p)

119+{-# INLINE swapProdCons #-}

120+

121+type family IsProdCons (x :: Type) :: Bool where

122+ IsProdCons (ProdCons _) = 'True

123+ IsProdCons _ = 'False

124+

125+type SwapEnvElementRoles x = SwapEnvElementRoles' x (IsProdCons x)

126+

127+class IsProdCons x ~ f => SwapEnvElementRoles' (x :: Type) f where

128+ swapEnvElementRoles :: x -> x

129+

130+instance SwapEnvElementRoles' (ProdCons x) 'True where

131+ swapEnvElementRoles (ProdCons p c) = ProdCons c p

132+

133+instance IsProdCons x ~ 'False => SwapEnvElementRoles' x 'False where

134+ swapEnvElementRoles = id

135+

136+class SwapEnvRoles xs where

137+ swapEnvRoles :: HList xs -> HList xs

138+

139+instance SwapEnvRoles '[] where

140+ swapEnvRoles = id

141+

142+instance (SwapEnvElementRoles x, SwapEnvRoles xs) => SwapEnvRoles (x ': xs) where

143+ swapEnvRoles (HCons x xs) = HCons (swapEnvElementRoles x) (swapEnvRoles xs)

111

144

112instance Applicative ProdCons where

145instance Applicative ProdCons where

113 pure x = ProdCons x x

146 pure x = ProdCons x x

@@ -145,14 +178,12 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where

145 type SubtreeLevel t :: BehaviorLevel

178 type SubtreeLevel t :: BehaviorLevel

146

179

147 checkStructuralCompatibility

180 checkStructuralCompatibility

148− :: (HasAll (CheckEnv t) xs)

181+ :: HList (CheckEnv t)

149− => HList xs

150 -> ProdCons (Traced t)

182 -> ProdCons (Traced t)

151 -> StructuralCompatFormula ()

183 -> StructuralCompatFormula ()

152

184

153 checkSemanticCompatibility

185 checkSemanticCompatibility

154− :: (HasAll (CheckEnv t) xs)

186+ :: HList (CheckEnv t)

155− => HList xs

156 -> Behavior (SubtreeLevel t)

187 -> Behavior (SubtreeLevel t)

157 -> ProdCons (Traced t)

188 -> ProdCons (Traced t)

158 -> SemanticCompatFormula ()

189 -> SemanticCompatFormula ()

@@ -162,29 +193,33 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where

162{-# WARNING checkSemanticCompatibility "You should not be calling this directly. Use 'checkCompatibility'" #-}

193{-# WARNING checkSemanticCompatibility "You should not be calling this directly. Use 'checkCompatibility'" #-}

163

194

164checkCompatibility

195checkCompatibility

196+ :: forall t xs.

165− :: (HasAll (CheckEnv t) xs, Subtree t)

197+ (ReassembleHList xs (CheckEnv t), Subtree t)

166− => HList xs

167− -> Behavior (SubtreeLevel t)

198+ => Behavior (SubtreeLevel t)

199+ -> HList xs

168 -> ProdCons (Traced t)

200 -> ProdCons (Traced t)

169 -> SemanticCompatFormula ()

201 -> SemanticCompatFormula ()

170−checkCompatibility e bhv = memo bhv SemanticMemoKey $ \pc ->

202+checkCompatibility bhv e = memo bhv SemanticMemoKey $ \pc ->

171 case runCompatFormula $ checkSubstructure e pc of

203 case runCompatFormula $ checkSubstructure e pc of

172− Left _ -> checkSemanticCompatibility e bhv pc

204+ Left _ -> checkSemanticCompatibility (reassemble e) bhv pc

173 Right () -> pure ()

205 Right () -> pure ()

206+{-# INLINE checkCompatibility #-}

174

207

175checkSubstructure

208checkSubstructure

176− :: (HasAll (CheckEnv t) xs, Subtree t)

209+ :: (ReassembleHList xs (CheckEnv t), Subtree t)

177 => HList xs

210 => HList xs

178 -> ProdCons (Traced t)

211 -> ProdCons (Traced t)

179 -> StructuralCompatFormula ()

212 -> StructuralCompatFormula ()

180−checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility e

213+checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility (reassemble e)

214+{-# INLINE checkSubstructure #-}

181

215

182structuralMaybe

216structuralMaybe

183− :: (Subtree a, HasAll (CheckEnv a) xs)

217+ :: (Subtree a, ReassembleHList xs (CheckEnv a))

184 => HList xs

218 => HList xs

185 -> ProdCons (Maybe (Traced a))

219 -> ProdCons (Maybe (Traced a))

186 -> StructuralCompatFormula ()

220 -> StructuralCompatFormula ()

187structuralMaybe e = structuralMaybeWith (checkSubstructure e)

221structuralMaybe e = structuralMaybeWith (checkSubstructure e)

222+{-# INLINE structuralMaybe #-}

188

223

189structuralMaybeWith

224structuralMaybeWith

190 :: (ProdCons a -> StructuralCompatFormula ())

225 :: (ProdCons a -> StructuralCompatFormula ())

@@ -193,9 +228,10 @@ structuralMaybeWith

193structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b

228structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b

194structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()

229structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()

195structuralMaybeWith _ _ = structuralIssue

230structuralMaybeWith _ _ = structuralIssue

231+{-# INLINE structuralMaybeWith #-}

196

232

197structuralList

233structuralList

198− :: (Subtree a, HasAll (CheckEnv a) xs)

234+ :: (Subtree a, ReassembleHList xs (CheckEnv a))

199 => HList xs

235 => HList xs

200 -> ProdCons [Traced a]

236 -> ProdCons [Traced a]

201 -> StructuralCompatFormula ()

237 -> StructuralCompatFormula ()

@@ -205,17 +241,20 @@ structuralList e (ProdCons (a : aa) (b : bb)) = do

205 structuralList e $ ProdCons aa bb

241 structuralList e $ ProdCons aa bb

206 pure ()

242 pure ()

207structuralList _ _ = structuralIssue

243structuralList _ _ = structuralIssue

244+{-# INLINE structuralList #-}

208

245

209structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula ()

246structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula ()

210structuralEq (ProdCons a b) = if extract a == extract b then pure () else structuralIssue

247structuralEq (ProdCons a b) = if extract a == extract b then pure () else structuralIssue

248+{-# INLINE structuralEq #-}

211

249

212iohmStructural

250iohmStructural

213− :: (HasAll (CheckEnv v) (k ': xs), Ord k, Subtree v, Hashable k, Typeable k, Show k)

251+ :: (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k)

214 => HList xs

252 => HList xs

215 -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

253 -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

216 -> StructuralCompatFormula ()

254 -> StructuralCompatFormula ()

217iohmStructural e =

255iohmStructural e =

218 iohmStructuralWith (\k -> checkSubstructure (k `HCons` e))

256 iohmStructuralWith (\k -> checkSubstructure (k `HCons` e))

257+{-# INLINE iohmStructural #-}

219

258

220instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMap k v) v where

259instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMap k v) v where

221 data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k

260 data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k

@@ -235,41 +274,36 @@ iohmStructuralWith f pc = do

235 (\eKey ->

274 (\eKey ->

236 f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc)

275 f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc)

237 else structuralIssue

276 else structuralIssue

238−

277+{-# INLINE iohmStructuralWith #-}

239−class HasUnsupportedFeature x where

240− hasUnsupportedFeature :: x -> Bool

241−

242−instance HasUnsupportedFeature () where

243− hasUnsupportedFeature () = False

244−

245−instance

246− (HasUnsupportedFeature a, HasUnsupportedFeature b)

247− => HasUnsupportedFeature (Either a b)

248− where

249− hasUnsupportedFeature (Left x) = hasUnsupportedFeature x

250− hasUnsupportedFeature (Right x) = hasUnsupportedFeature x

251−

252−instance Issuable l => HasUnsupportedFeature (Issue l) where

253− hasUnsupportedFeature = issueIsUnsupported

254−

255−instance HasUnsupportedFeature (AnIssue l) where

256− hasUnsupportedFeature (AnIssue issue) = hasUnsupportedFeature issue

257−

258−instance

259− (forall x. HasUnsupportedFeature (f x))

260− => HasUnsupportedFeature (P.PathsPrefixTree q f r)

261− where

262− hasUnsupportedFeature =

263− getAny . P.foldWith (\_ fa -> Any $ hasUnsupportedFeature fa)

264

278

265runCompatFormula

279runCompatFormula

266 :: CompatFormula' q f r a

280 :: CompatFormula' q f r a

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

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

268runCompatFormula (Compose f) =

282runCompatFormula (Compose f) =

269 calculate . runIdentity . runMemo 0 . unCompatM $ f

283 calculate . runIdentity . runMemo 0 . unCompatM $ f

284+{-# INLINE runCompatFormula #-}

285+

286+embedFormula :: Paths q r l -> CompatFormula' q f l a -> CompatFormula' q f r a

287+embedFormula bhv (Compose x) = Compose $ mapErrors (P.embed bhv) <$> x

270

288

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

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

272−issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ AnIssue issue

290+issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ anIssue issue

291+{-# INLINE issueAt #-}

292+

293+anIssue :: Issuable l => Issue l -> AnIssue l

294+anIssue = AnIssue Forward

295+{-# INLINE anIssue #-}

296+

297+anItem :: AnItem q AnIssue r -> CompatFormula' q AnIssue r a

298+anItem = Compose . pure . anError

299+{-# INLINE anItem #-}

300+

301+invertIssueOrientation :: CompatFormula' q AnIssue r a -> CompatFormula' q AnIssue r a

302+invertIssueOrientation (Compose x) =

303+ Compose $ mapErrors invertIssueOrientationP <$> x

304+

305+invertIssueOrientationP :: P.PathsPrefixTree q AnIssue r -> P.PathsPrefixTree q AnIssue r

306+invertIssueOrientationP = P.map (\(AnIssue ori i) -> AnIssue (toggleOrientation ori) i)

273

307

274structuralIssue :: StructuralCompatFormula a

308structuralIssue :: StructuralCompatFormula a

275structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy

309structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy

@@ -282,7 +316,7 @@ anyOfAt

282 -> CompatFormula' q AnIssue r a

316 -> CompatFormula' q AnIssue r a

283anyOfAt _ _ [x] = x

317anyOfAt _ _ [x] = x

284anyOfAt xs issue fs =

318anyOfAt xs issue fs =

285− Compose $ (`eitherOf` AnItem xs (AnIssue issue)) <$> sequenceA (getCompose <$> fs)

319+ Compose $ (`eitherOf` AnItem xs (anIssue issue)) <$> sequenceA (getCompose <$> fs)

286

320

287fixpointKnot

321fixpointKnot

288 :: MonadState (MemoState VarRef) m

322 :: MonadState (MemoState VarRef) m

src/OpenAPI/Checker/Validate/Header.hs+1−1

@@ -34,7 +34,7 @@ instance Subtree Header where

34 for_ (tracedSchema c) $ \consRef ->

35 case tracedSchema p of

36 Nothing -> issueAt beh HeaderSchemaRequired

37− Just prodRef -> checkCompatibility env (beh >>> step InSchema) (ProdCons prodRef consRef)

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

38 pure ()

39

40instance Steppable Header (Referenced Schema) where

src/OpenAPI/Checker/Validate/MediaTypeObject.hs+7−7

@@ -79,7 +79,7 @@ instance Subtree MediaTypeObject where

79 case tracedSchema p of

80 Nothing -> issueAt beh MediaTypeSchemaRequired

81 Just prodRef ->

82− checkCompatibility env (beh >>> step PayloadSchema) $

82+ checkCompatibility (beh >>> step PayloadSchema) env $

83 ProdCons prodRef consRef

84 pure ()

85 where

@@ -99,7 +99,7 @@ instance Subtree MediaTypeObject where

99 in checkProducts

100 beh

101 MediaEncodingMissing

102− (const $ checkCompatibility env beh)

102+ (const $ checkCompatibility beh env)

103 encProdCons

104

105instance Subtree Encoding where

@@ -147,17 +147,17 @@ instance Behavable 'OperationLevel 'ResponseLevel where

147

148instance Issuable 'OperationLevel where

149 data Issue 'OperationLevel

150− = ResponseCodeNotFound HttpStatusCode

150+ = ConsumerDoesntHaveResponseCode HttpStatusCode

151 | ParamNotMatched Text

152 | PathFragmentNotMatched Int

153 | NoRequestBody

154 deriving stock (Eq, Ord, Show)

155 issueIsUnsupported = \case

156 _ -> False

157− describeIssue Forward (ResponseCodeNotFound c) =

157+ describeIssue Forward (ConsumerDoesntHaveResponseCode c) =

158+ para $ "Response code " <> (str . T.pack . show $ c) <> " has been removed."

159+ describeIssue Backward (ConsumerDoesntHaveResponseCode c) =

158− para $ "Reponse code " <> (str . T.pack . show $ c) <> " has been added."

160+ para $ "Response code " <> (str . T.pack . show $ c) <> " has been added."

159− describeIssue Backward (ResponseCodeNotFound c) =

160− para $ "Reponse code " <> (str . T.pack . show $ c) <> " has been removed."

161 describeIssue Forward (ParamNotMatched param) =

162 para $ "Parameter " <> code param <> " has become required."

163 describeIssue Backward (ParamNotMatched param) =

src/OpenAPI/Checker/Validate/OAuth2Flows.hs+2−2

@@ -37,7 +37,7 @@ instance Subtree OAuth2Flows where

37 -- producer can attempt a flow the consumer does not know about

38 (ProdCons (Just _) Nothing) -> issueAt bhv i

39 (ProdCons (Just p) (Just c)) ->

40− checkCompatibility env bhv $ ProdCons p c

40+ checkCompatibility bhv env $ ProdCons p c

41 getFlow

42 :: Typeable x

43 => (OAuth2Flows -> Maybe (OAuth2Flow x))

@@ -62,7 +62,7 @@ instance (Typeable t, Subtree t, SubtreeLevel (OAuth2Flow t) ~ SubtreeLevel t) =

62 let ProdCons pScopes cScopes = S.fromList . IOHM.keys . _oAuth2Scopes . extract <$> prodCons

63 missingScopes = cScopes S.\\ pScopes

64 unless (S.null missingScopes) (issueAt bhv $ ScopesMissing missingScopes)

65− checkCompatibility env bhv $ retraced (>>> step (OAuth2FlowParamsStep Proxy)) . fmap _oAuth2Params <$> prodCons

65+ checkCompatibility bhv env $ retraced (>>> step (OAuth2FlowParamsStep Proxy)) . fmap _oAuth2Params <$> prodCons

66 unless (((==) `on` _oAath2RefreshUrl . extract) p c) $ issueAt bhv RefreshUrlsDontMatch

67 pure ()

68

src/OpenAPI/Checker/Validate/OpenApi.hs+1−1

@@ -78,6 +78,7 @@ instance Subtree OpenApi where

78 checkStructuralCompatibility _ _ = structuralIssue

79 checkSemanticCompatibility _ beh prodCons = do

80 checkCompatibility @ProcessedPathItems

81+ beh

81 ((tracedRequestBodies <$> prodCons)

82 ((tracedRequestBodies <$> prodCons)

82 `HCons` (tracedParameters <$> prodCons)

83 `HCons` (tracedParameters <$> prodCons)

83 `HCons` (tracedSecuritySchemes <$> prodCons)

84 `HCons` (tracedSecuritySchemes <$> prodCons)

@@ -88,7 +89,6 @@ instance Subtree OpenApi where

88 `HCons` (tracedLinks <$> prodCons)

89 `HCons` (tracedLinks <$> prodCons)

89 `HCons` (tracedCallbacks <$> prodCons)

90 `HCons` (tracedCallbacks <$> prodCons)

90 `HCons` HNil)

91 `HCons` HNil)

91− beh

92 (tracedPaths <$> prodCons)

93

94instance Steppable OpenApi ProcessedPathItems where

src/OpenAPI/Checker/Validate/Operation.hs+13−36

@@ -203,8 +203,8 @@ instance Subtree MatchedOperation where

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

204 }

205 pure (k, v)

206− check (_, name) param = do

206+ check (_, name) param =

207− checkCompatibility @Param (singletonH schemaDefs) (beh >>> step (InParam name)) param

207+ checkCompatibility @Param (beh >>> step (InParam name)) env param

208 checkProducts beh (ParamNotMatched . snd) check elements

209 checkPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()

210 checkPathParams pathParams = do

@@ -213,7 +213,7 @@ instance Subtree MatchedOperation where

213 getFragments params mop = getPathFragments (extract mop) params

214 -- Feed path parameters to the fragments getter

215 check _ frags@(ProdCons (Traced _ p) _) =

216− checkCompatibility @PathFragmentParam env (beh >>> step (InFragment $ _paramName . extract <$> p)) frags

216+ checkCompatibility @PathFragmentParam (beh >>> step (InFragment $ _paramName . extract <$> p)) env frags

217 elements =

218 fragments <&> \frags -> M.fromList $

219 zip [0 :: Int ..] $ do

@@ -225,7 +225,7 @@ instance Subtree MatchedOperation where

225 }

226 checkProducts beh PathFragmentNotMatched check elements

227 checkRequestBodies = do

228− let check reqBody = checkCompatibility @RequestBody env (beh >>> step InRequest) reqBody

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

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

230 getReqBody bodyDef mop = M.fromList $ do

231 bodyRef <- F.toList . tracedRequestBody $ mop

@@ -239,32 +239,16 @@ instance Subtree MatchedOperation where

239 }

240 )

241 checkProducts beh (const NoRequestBody) (const check) elements

242− checkResponses = do

242+ checkResponses =

243− let respEnv =

244− HCons (swapProdCons respDefs) $

245− HCons (swapProdCons headerDefs) $

246− HCons (swapProdCons schemaDefs) $

247− HCons (swapProdCons linkDefs) HNil

248− resps = tracedResponses <$> prodCons

243+ swapProdCons (checkCompatibility beh) env $ tracedResponses <$> prodCons

249− checkCompatibility respEnv beh $ swapProdCons resps

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

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

251 checkCallbacks = do

245 checkCallbacks = do

252− let env' =

253− HCons (swapProdCons respDefs) $

254− HCons (swapProdCons headerDefs) $

255− HCons (swapProdCons schemaDefs) $

256− HCons (swapProdCons securitySchemeDefs) $

257− HCons (swapProdCons paramDefs) $

258− HCons (swapProdCons serversDefs) $

259− HCons (swapProdCons callbackDefs) $

260− HCons (swapProdCons bodyDefs) $

261− HCons (swapProdCons linkDefs) HNil

262− let ProdCons pCallbacks cCallbacks = swapProdCons $ tracedCallbacks <$> prodCons

246+ let ProdCons pCallbacks cCallbacks = tracedCallbacks <$> prodCons

263 for_ pCallbacks $ \(k, pCallback) -> do

247 for_ pCallbacks $ \(k, pCallback) -> do

264 let beh' = beh >>> step (OperationCallback k)

248 let beh' = beh >>> step (OperationCallback k)

265 anyOfAt beh' CallbacksUnsupported $

249 anyOfAt beh' CallbacksUnsupported $

266 cCallbacks <&> \(_, cCallback) -> do

250 cCallbacks <&> \(_, cCallback) -> do

267− checkCompatibility env' beh' $ ProdCons pCallback cCallback

251+ swapProdCons (checkCompatibility beh') env $ ProdCons pCallback cCallback

268 pure ()

252 pure ()

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

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

270 checkOperationSecurity = do

254 checkOperationSecurity = do

@@ -273,21 +257,14 @@ instance Subtree MatchedOperation where

273 let beh' = beh >>> step (SecurityRequirementStep i)

257 let beh' = beh >>> step (SecurityRequirementStep i)

274 anyOfAt beh' SecurityRequirementNotMet $

258 anyOfAt beh' SecurityRequirementNotMet $

275 cSecs <&> \(_, cSec) ->

259 cSecs <&> \(_, cSec) ->

276− checkCompatibility env beh' $ ProdCons pSec cSec

260+ checkCompatibility beh' env $ ProdCons pSec cSec

277 checkServers =

261 checkServers =

278− checkCompatibility env beh $ do

262+ checkCompatibility beh env $ do

279 x <- prodCons

263 x <- prodCons

280 se <- getH @(ProdCons [Server]) env

264 se <- getH @(ProdCons [Server]) env

281 pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))

265 pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))

282 bodyDefs = getH @(ProdCons (Traced (Definitions RequestBody))) env

266 bodyDefs = getH @(ProdCons (Traced (Definitions RequestBody))) env

283− respDefs = getH @(ProdCons (Traced (Definitions Response))) env

284− headerDefs = getH @(ProdCons (Traced (Definitions Header))) env

285− schemaDefs = getH @(ProdCons (Traced (Definitions Schema))) env

286 paramDefs = getH @(ProdCons (Traced (Definitions Param))) env

267 paramDefs = getH @(ProdCons (Traced (Definitions Param))) env

287− linkDefs = getH @(ProdCons (Traced (Definitions Link))) env

288− callbackDefs = getH @(ProdCons (Traced (Definitions Callback))) env

289− securitySchemeDefs = getH @(ProdCons (Traced (Definitions SecurityScheme))) env

290− serversDefs = getH @(ProdCons [Server]) env

291

268

292data OperationMethod

269data OperationMethod

293 = GetMethod

270 = GetMethod

@@ -399,10 +376,10 @@ instance Subtree ProcessedPathItems where

399 F.toList $ matchingPathItems $ ProdCons prodItem consItem

376 F.toList $ matchingPathItems $ ProdCons prodItem consItem

400 case matchedItems of

377 case matchedItems of

401 [] -> issueAt beh $ NoPathsMatched prodPath

378 [] -> issueAt beh $ NoPathsMatched prodPath

402− [match] -> checkCompatibility env beh' (retraced <$> pc <*> match)

379+ [match] -> checkCompatibility beh' env (retraced <$> pc <*> match)

403 matches -> anyOfAt beh (AllPathsFailed prodPath) $ do

380 matches -> anyOfAt beh (AllPathsFailed prodPath) $ do

404 match <- matches

381 match <- matches

405− pure $ checkCompatibility env beh' (retraced <$> pc <*> match)

382+ pure $ checkCompatibility beh' env (retraced <$> pc <*> match)

406 where

383 where

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

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

408

385

@@ -535,7 +512,7 @@ instance Subtree MatchedPathItem where

535 -- Got only Justs here

512 -- Got only Justs here

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

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

537 pure (name, retraced <$> operation)

514 pure (name, retraced <$> operation)

538− check name pc = checkCompatibility @MatchedOperation env (beh >>> step (InOperation name)) pc

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

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

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

540 -- why not

517 -- why not

541 checkSums beh OperationMissing check operations

518 checkSums beh OperationMissing check operations

src/OpenAPI/Checker/Validate/Param.hs+1−1

@@ -119,7 +119,7 @@ instance Subtree Param where

119 issueAt beh ParamStyleMismatch

120 case tracedSchema <$> pc of

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

122− checkCompatibility env (beh >>> step InParamSchema) $ ProdCons prodSchema consSchema

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

123 ProdCons Nothing Nothing -> pure ()

124 ProdCons Nothing (Just _consSchema) -> issueAt beh ParamSchemaMismatch

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

src/OpenAPI/Checker/Validate/PathFragment.hs+1−1

@@ -76,4 +76,4 @@ instance Subtree PathFragmentParam where

76 then pure ()

77 else issueAt beh (PathFragmentsDontMatch x y)

78 checkSemanticCompatibility env beh prodCons = do

79− checkCompatibility env beh (tracedPathFragmentParam <$> prodCons)

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

src/OpenAPI/Checker/Validate/RequestBody.hs+1−1

@@ -64,7 +64,7 @@ instance Subtree RequestBody where

64 then issueAt beh RequestBodyRequired

65 else -- Media type object are sums-like entities.

66

67− let check mediaType pc = checkCompatibility @MediaTypeObject (HCons mediaType env) (beh >>> step InPayload) pc

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

68 sumElts = getSum <$> prodCons

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

70 in checkSums beh RequestMediaTypeNotFound check sumElts

src/OpenAPI/Checker/Validate/Responses.hs+14−14

@@ -49,12 +49,12 @@ instance Subtree Responses where

49 -- one element

50 checkSemanticCompatibility env beh prodCons = do

51 let defs = getH @(ProdCons (Traced (Definitions Response))) env

52− check code resps = checkCompatibility @Response env (beh >>> step (WithStatusCode code)) resps

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

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

54 getEls respDef resps = M.fromList $ do

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

56 pure (code, dereference respDef respRef)

57− checkSums beh ResponseCodeNotFound check elements

57+ checkSums beh ConsumerDoesntHaveResponseCode check elements

58

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

60tracedContent resp =

@@ -68,17 +68,17 @@ tracedHeaders resp =

68

69instance Issuable 'ResponseLevel where

70 data Issue 'ResponseLevel

71− = ResponseMediaTypeMissing MediaType

71+ = ConsumerDoesntHaveMediaType MediaType

72− | ResponseHeaderMissing HeaderName

72+ | ProducerDoesntHaveResponseHeader HeaderName

73 deriving stock (Eq, Ord, Show)

74 issueIsUnsupported _ = False

75− describeIssue Forward (ResponseMediaTypeMissing t) =

75+ describeIssue Forward (ConsumerDoesntHaveMediaType t) =

76 para $ "Media type was removed: " <> (code . T.pack . show $ t) <> "."

77− describeIssue Backward (ResponseMediaTypeMissing t) =

77+ describeIssue Backward (ConsumerDoesntHaveMediaType t) =

78− para $ "New media type was added: " <> (code . T.pack . show $ t) <> "."

78+ para $ "Media type was added: " <> (code . T.pack . show $ t) <> "."

79− describeIssue Forward (ResponseHeaderMissing h) =

79+ describeIssue Forward (ProducerDoesntHaveResponseHeader h) =

80 para $ "New header was added " <> code h <> "."

81− describeIssue Backward (ResponseHeaderMissing h) =

81+ describeIssue Backward (ProducerDoesntHaveResponseHeader h) =

82 para $ "Header was removed " <> code h <> "."

83

84instance Behavable 'ResponseLevel 'PayloadLevel where

@@ -117,15 +117,15 @@ instance Subtree Response where

117 checkMediaTypes = do

118 -- Media types are sum-like entity

119 let check mediaType mtObj =

120− let mtEnv = HCons mediaType $ env

120+ let mtEnv = HCons mediaType env

121− in checkCompatibility @MediaTypeObject mtEnv (beh >>> step ResponsePayload) mtObj

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

122 elements = getEls <$> prodCons

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

124− checkSums beh ResponseMediaTypeMissing check elements

124+ checkSums beh ConsumerDoesntHaveMediaType check elements

125

126 checkHeaders = do

127 -- Headers are product-like entities

128− let check name hdrs = checkCompatibility @Header env (beh >>> step (InHeader name)) hdrs

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

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

130 getEls headerDef resp = M.fromList $ do

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

@@ -137,7 +137,7 @@ instance Subtree Response where

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

138 }

139 )

140− checkProducts beh ResponseHeaderMissing check elements

140+ checkProducts beh ProducerDoesntHaveResponseHeader check elements

141 headerDefs = getH @(ProdCons (Traced (Definitions Header))) env

142

143instance Steppable Responses (Referenced Response) where

src/OpenAPI/Checker/Validate/Schema.hs+30−20

@@ -167,12 +167,16 @@ showCondition = \case

167 showForEachJsonFormula i =

168 bulletList $

169 foldType

170− (\t f ->

170+ (\t f -> case f i of

171− let (DNF conds') = f i

171+ BottomFormula -> mempty

172+ (DNF conds') ->

172− conds = S.toList <$> S.toList conds'

173+ let conds = S.toList <$> S.toList conds'

173− in [ para (describeJSONType t)

174+ in [ para (describeJSONType t)

175+ <> bulletList

176+ (conds <&> \case

177+ [] -> para "Empty"

174− <> bulletList (conds <&> \cond -> bulletList (showCondition <$> cond))

178+ cond -> bulletList (showCondition <$> cond))

175− ])

179+ ])

176

180

177satisfiesTyped :: TypedValue t -> Condition t -> Bool

181satisfiesTyped :: TypedValue t -> Condition t -> Bool

178satisfiesTyped e (Exactly e') = e == e'

182satisfiesTyped e (Exactly e') = e == e'

@@ -460,7 +464,7 @@ type MonadProcess m =

460type SilentM = ReaderT (Traced (Definitions Schema)) (Silent Behave AnIssue 'SchemaLevel)

464type SilentM = ReaderT (Traced (Definitions Schema)) (Silent Behave AnIssue 'SchemaLevel)

461

465

462warn :: MonadProcess m => Issue 'SchemaLevel -> m ()

466warn :: MonadProcess m => Issue 'SchemaLevel -> m ()

463−warn issue = tell $ P.singleton $ AnItem Root $ AnIssue issue

467+warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue

464

468

465-- | Ignore warnings but allow a recursive loop that lazily computes a recursive 'Condition'.

469-- | Ignore warnings but allow a recursive loop that lazily computes a recursive 'Condition'.

466silently :: MonadProcess m => SilentM a -> m a

470silently :: MonadProcess m => SilentM a -> m a

@@ -803,14 +807,14 @@ schemaToFormula

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

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

804

808

805checkFormulas

809checkFormulas

806− :: (HasAll (CheckEnv Schema) xs)

810+ :: (ReassembleHList xs (CheckEnv (Referenced Schema)))

807 => HList xs

811 => HList xs

808 -> Behavior 'SchemaLevel

812 -> Behavior 'SchemaLevel

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

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

810 -> SemanticCompatFormula ()

814 -> SemanticCompatFormula ()

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

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

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

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

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

817+ issues@(_ : _) -> F.for_ issues $ embedFormula beh . anItem

814 [] -> do

818 [] -> do

815 -- We have the following isomorphisms:

819 -- We have the following isomorphisms:

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

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

@@ -844,7 +848,12 @@ checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =

844 case (ty fp, ty fc) of

848 case (ty fp, ty fc) of

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

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

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

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

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

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

852+ (TopFormula, DNF css) ->

853+ -- producer is "open" (allows any value), but consumer has restrictions.

854+ -- In this case we want to show which restrictions were added. (instead

855+ -- of showing an empty list restrictions that couldn't be satisfied.)

856+ F.for_ css $ \(Conjunct cs) -> F.for_ cs $ checkImplication env beh' []

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

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

849 anyOfAt

858 anyOfAt

850 beh'

859 beh'

@@ -865,7 +874,7 @@ checkContradiction

865checkContradiction beh _ = issueAt beh NoContradiction -- TODO #70

874checkContradiction beh _ = issueAt beh NoContradiction -- TODO #70

866

875

867checkImplication

876checkImplication

868− :: (HasAll (CheckEnv Schema) xs)

877+ :: (ReassembleHList xs (CheckEnv (Referenced Schema)))

869 => HList xs

878 => HList xs

870 -> Behavior 'TypedSchemaLevel

879 -> Behavior 'TypedSchemaLevel

871 -> [Condition t]

880 -> [Condition t]

@@ -924,10 +933,10 @@ checkImplication env beh prods cons = case findExactly prods of

924 then pure ()

933 then pure ()

925 else issueAt beh (NoMatchingFormat f)

934 else issueAt beh (NoMatchingFormat f)

926 Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of

935 Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of

927− Just (rs NE.:| []) -> checkCompatibility env (beh >>> step InItems) $ ProdCons rs cons'

936+ Just (rs NE.:| []) -> checkCompatibility (beh >>> step InItems) env $ ProdCons rs cons'

928 Just rs -> do

937 Just rs -> do

929 let sch = Inline mempty {_schemaAllOf = Just . NE.toList $ extract <$> rs}

938 let sch = Inline mempty {_schemaAllOf = Just . NE.toList $ extract <$> rs}

930− checkCompatibility env (beh >>> step InItems) $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace

939+ checkCompatibility (beh >>> step InItems) env $ ProdCons (traced (ask $ NE.head rs) sch) cons' -- TODO: bad trace

931 Nothing -> issueAt beh NoMatchingItems

940 Nothing -> issueAt beh NoMatchingItems

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

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

933 Just m' ->

942 Just m' ->

@@ -954,7 +963,7 @@ checkImplication env beh prods cons = case findExactly prods of

954 -- producer does not require field, but consumer does (can fail)

963 -- producer does not require field, but consumer does (can fail)

955 (False, True) -> issueAt beh (PropertyNowRequired k)

964 (False, True) -> issueAt beh (PropertyNowRequired k)

956 _ -> do

965 _ -> do

957− let go sch sch' = checkCompatibility env (beh >>> step (InProperty k)) (ProdCons sch sch')

966+ let go sch sch' = checkCompatibility (beh >>> step (InProperty k)) env (ProdCons sch sch')

958 case (M.lookup k props', madd', M.lookup k props, madd) of

967 case (M.lookup k props', madd', M.lookup k props, madd) of

959 -- (producer, additional producer, consumer, additional consumer)

968 -- (producer, additional producer, consumer, additional consumer)

960 (Nothing, Nothing, _, _) -> pure () -- vacuously

969 (Nothing, Nothing, _, _) -> pure () -- vacuously

@@ -967,7 +976,7 @@ checkImplication env beh prods cons = case findExactly prods of

967 case (madd', madd) of

976 case (madd', madd) of

968 (Nothing, _) -> pure () -- vacuously

977 (Nothing, _) -> pure () -- vacuously

969 (_, Nothing) -> issueAt beh NoAdditionalProperties

978 (_, Nothing) -> issueAt beh NoAdditionalProperties

970− (Just add', Just add) -> checkCompatibility env (beh >>> step InAdditionalProperty) (ProdCons add' add)

979+ (Just add', Just add) -> checkCompatibility (beh >>> step InAdditionalProperty) env (ProdCons add' add)

971 pure ()

980 pure ()

972 Nothing -> issueAt beh NoMatchingProperties

981 Nothing -> issueAt beh NoMatchingProperties

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

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

@@ -1053,14 +1062,15 @@ instance Issuable 'TypedSchemaLevel where

1053 MatchingMinPropertiesWeak (ProdCons Integer)

1062 MatchingMinPropertiesWeak (ProdCons Integer)

1054 | -- | producer declares that the value must satisfy a disjunction of some conditions, but consumer's requirements couldn't be matched against any single one of them (TODO: split heuristic #71)

1063 | -- | producer declares that the value must satisfy a disjunction of some conditions, but consumer's requirements couldn't be matched against any single one of them (TODO: split heuristic #71)

1055 NoMatchingCondition [SomeCondition]

1064 NoMatchingCondition [SomeCondition]

1056− | -- | consumer indicates that values of this type are now allowed, but the producer does not do so (currently we only check immediate contradictions, c.f. #70)

1065+ | -- | producer indicates that values of this type are now allowed, but the consumer does not do so (currently we only check immediate contradictions, c.f. #70)

1066+ -- AKA consumer does not have the type

1057 NoContradiction

1067 NoContradiction

1058 deriving stock (Eq, Ord, Show)

1068 deriving stock (Eq, Ord, Show)

1059 issueIsUnsupported _ = False

1069 issueIsUnsupported _ = False

1060− describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v

1070+ describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v

1061− describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v

1071+ describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v

1062− describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been removed:" <> showJSONValue v

1072+ describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v

1063− describeIssue Backward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v

1073+ describeIssue Backward (NoMatchingEnum v) = para "The following enum value has been removed:" <> showJSONValue v

1064 describeIssue Forward (NoMatchingMaximum b) = para $ "Upper bound has been added:" <> showBound b <> "."

1074 describeIssue Forward (NoMatchingMaximum b) = para $ "Upper bound has been added:" <> showBound b <> "."

1065 describeIssue Backward (NoMatchingMaximum b) = para $ "Upper bound has been removed:" <> showBound b <> "."

1075 describeIssue Backward (NoMatchingMaximum b) = para $ "Upper bound has been removed:" <> showBound b <> "."

1066 describeIssue _ (MatchingMaximumWeak (ProdCons p c)) = para $ "Upper bound changed from " <> showBound p <> " to " <> showBound c <> "."

1076 describeIssue _ (MatchingMaximumWeak (ProdCons p c)) = para $ "Upper bound changed from " <> showBound p <> " to " <> showBound c <> "."

src/OpenAPI/Checker/Validate/SecurityRequirement.hs+1−1

@@ -102,7 +102,7 @@ instance Subtree SecurityRequirement where

102 (SecuritySchemeOAuth2 {}, SecuritySchemeOAuth2 {}) -> pure ()

103 _ -> unless (null pScopes && null cScopes) $ issueAt bhv CanNotHaveScopes

104 for_ errs $ issueAt bhv

105− checkCompatibility env bhv pc'

105+ checkCompatibility bhv env pc'

106 pure ()

107 pure ()

108

src/OpenAPI/Checker/Validate/SecurityScheme.hs+1−1

@@ -26,7 +26,7 @@ instance Subtree SecurityScheme where

26 (ProdCons (Traced _ (SecuritySchemeApiKey pParams)) (Traced _ (SecuritySchemeApiKey cParams))) -> do

27 unless (pParams == cParams) (issueAt bhv $ ApiKeyParamsDontMatch pParams cParams)

28 (ProdCons (Traced pT (SecuritySchemeOAuth2 pFlows)) (Traced cT (SecuritySchemeOAuth2 cFlows))) -> do

29− checkCompatibility env bhv . fmap (stepTraced SecurityOAuthFlowsStep) $ ProdCons (Traced pT pFlows) (Traced cT cFlows)

29+ checkCompatibility bhv env . fmap (stepTraced SecurityOAuthFlowsStep) $ ProdCons (Traced pT pFlows) (Traced cT cFlows)

30 (ProdCons (Traced _ (SecuritySchemeOpenIdConnect pUrl)) (Traced _ (SecuritySchemeOpenIdConnect cUrl))) -> do

31 unless (pUrl == cUrl) (issueAt bhv $ OpenIdConnectUrlsDontMatch pUrl cUrl)

32 _ -> issueAt bhv DifferentSecuritySchemes

src/OpenAPI/Checker/Validate/Server.hs+1−1

@@ -76,7 +76,7 @@ instance Subtree [Server] where

76 anyOfAt

77 bhv

78 ServerNotMatched

79− [ checkCompatibility env bhv (ProdCons pUrl cUrl)

79+ [ checkCompatibility bhv env (ProdCons pUrl cUrl)

80 | cUrl <- potentiallyCompatible

81 ]

82 pure ()

test/golden/common/pathItem/operation/responses/add/report.md+1−1

@@ -8,4 +8,4 @@

8

9## **POST** /test

10

11−Reponse code 500 has been added.

11+Response code 500 has been added.

test/golden/common/pathItem/operation/responses/add/trace-tree.yaml+1−1

@@ -1,4 +1,4 @@

1breakingChanges:

2 AtPath "/test":

3− InOperation PostMethod: ResponseCodeNotFound 500

3+ InOperation PostMethod: ConsumerDoesntHaveResponseCode 500

4nonBreakingChanges: {}

test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/trace-tree.yaml+1−1

@@ -2,4 +2,4 @@ breakingChanges: {}

2nonBreakingChanges:

3 AtPath "/test":

4 InOperation PostMethod:

5− WithStatusCode 200: ResponseHeaderMissing "Test2"

5+ WithStatusCode 200: ProducerDoesntHaveResponseHeader "Test2"

test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/trace-tree.yaml+1−1

@@ -1,5 +1,5 @@

1breakingChanges:

2 AtPath "/test":

3 InOperation PostMethod:

4− WithStatusCode 200: ResponseHeaderMissing "Test2"

4+ WithStatusCode 200: ProducerDoesntHaveResponseHeader "Test2"

5nonBreakingChanges: {}

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/report.md+1−1

@@ -10,4 +10,4 @@

10

11### Response code 200

12

13−New media type was added: `application/x-www-form-urlencoded`.

13+Media type was added: `application/x-www-form-urlencoded`.

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/trace-tree.yaml+1−1

@@ -1,5 +1,5 @@

1breakingChanges:

2 AtPath "/test":

3 InOperation PostMethod:

4− WithStatusCode 200: ResponseMediaTypeMissing application/x-www-form-urlencoded

4+ WithStatusCode 200: ConsumerDoesntHaveMediaType application/x-www-form-urlencoded

5nonBreakingChanges: {}

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/trace-tree.yaml+1−1

@@ -2,4 +2,4 @@ breakingChanges: {}

2nonBreakingChanges:

3 AtPath "/test":

4 InOperation PostMethod:

5− WithStatusCode 200: ResponseMediaTypeMissing application/x-www-form-urlencoded

5+ WithStatusCode 200: ConsumerDoesntHaveMediaType application/x-www-form-urlencoded

test/golden/common/pathItem/operation/responses/del/report.md+1−1

@@ -8,4 +8,4 @@

8

9## **POST** /test

10

11−Reponse code 500 has been removed.

11+Response code 500 has been removed.

test/golden/common/pathItem/operation/responses/del/trace-tree.yaml+1−1

@@ -1,4 +1,4 @@

1breakingChanges: {}

2nonBreakingChanges:

3 AtPath "/test":

4− InOperation PostMethod: ResponseCodeNotFound 500

4+ InOperation PostMethod: ConsumerDoesntHaveResponseCode 500

test/golden/common/recursive/a.yaml+6

@@ -7,6 +7,12 @@ servers:

7paths:

8 /api/foo:

9 get:

10+ requestBody:

11+ content:

12+ application/json;charset=utf-8:

13+ schema:

14+ $ref: "#/components/schemas/Tree"

15+

10 responses:

16 responses:

11 200:

17 200:

12 description: ""

18 description: ""

test/golden/common/recursive/b.yaml+6

@@ -7,6 +7,12 @@ servers:

7paths:

8 /api/foo:

9 get:

10+ requestBody:

11+ content:

12+ application/json;charset=utf-8:

13+ schema:

14+ $ref: "#/components/schemas/Tree"

15+

10 responses:

16 responses:

11 200:

17 200:

12 description: ""

18 description: ""

test/golden/common/recursive/report.md+18−4

@@ -1,8 +1,22 @@

1# Summary

2

3−| ⚠️ Breaking changes | [🙆 Non-breaking changes](#non-breaking-changes) | 🤷 Unsupported feature changes |

3+| [⚠️ Breaking changes](#breaking-changes) | [🙆 Non-breaking changes](#non-breaking-changes) | 🤷 Unsupported feature changes |

4−|---------------------|-------------------------------------------------|-------------------------------|

4+|------------------------------------------|-------------------------------------------------|-------------------------------|

5−| 0 | 1 | 0 |

5+| 1 | 1 | 0 |

6+

7+# ⚠️ Breaking changes

8+

9+## **GET** /api/foo

10+

11+### 📱➡️ JSON Request

12+

13+#### `$.leaf.value.foo(String)`

14+

15+The following enum value has been added:

16+

17+``` json

18+"a"

19+```

6

20

7# 🙆 Non-breaking changes

21# 🙆 Non-breaking changes

8

22

@@ -12,7 +26,7 @@

12

26

13#### `$.leaf.value.foo(String)`

27#### `$.leaf.value.foo(String)`

14

28

15−The following enum value has been removed:

29+The following enum value has been added:

16

30

17``` json

31``` json

18"a"

32"a"

test/golden/common/recursive/trace-tree.yaml+13−1

@@ -1,4 +1,16 @@

1−breakingChanges: {}

1+breakingChanges:

2+ AtPath "/api/foo":

3+ InOperation GetMethod:

4+ InRequest:

5+ InPayload:

6+ PayloadSchema:

7+ OfType Object:

8+ InProperty "leaf":

9+ OfType Object:

10+ InProperty "value":

11+ OfType Object:

12+ InProperty "foo":

13+ OfType String: NoMatchingEnum (String "a")

2nonBreakingChanges:

14nonBreakingChanges:

3 AtPath "/api/foo":

15 AtPath "/api/foo":

4 InOperation GetMethod:

16 InOperation GetMethod: