649261f · typeable/compaREST

git.iko.soy/typeable/compaREST

Fixed some report issues (#88)

* Removed HasUnsupportedFeature * Embedded direction in error and removed reversed responses * Swap first two checkCompatibility arguments * Monomorphised env closes #47 * Made swapProdCons better * Added inversion when swapping prodcons * Show issues when adding restrictions to open field in json schema * better condition rendering

commit649261f6bc57104b2838c887e0c80fb96572b111 authoriko <ilyakooo0@gmail.com> dateMon 28 Jun 2021, 13:49 (5 years ago) parent38341ca

34 files changed+279−195

compare with master

unifiedsplit

openapi-diff.cabal+1

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

3434 -Wno-all-missed-specialisations

3535 -Wno-missing-local-signatures

3636 -Wno-unsafe

37+ -fconstraint-solver-iterations=0

3738 default-language: Haskell2010

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

3940 , bytestring

src/Data/HList.hs+30

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

44 , getH

55 , HList (..)

66 , singletonH

7+ , ReassembleHList

8+ , reassemble

79 )

810where

911

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

3133

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

3335 getH (HCons x _) = x

36+ {-# INLINE getH #-}

3437

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

3639 getH (HCons _ xs) = getH xs

40+ {-# INLINE getH #-}

3741

3842instance

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

4044 => Has' x '[] 'False

4145 where

4246 getH HNil = undefined

47+ {-# INLINE getH #-}

4348

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

4550singletonH a = a `HCons` HNil

51+{-# INLINE singletonH #-}

4652

4753instance Eq (HList '[]) where

4854 HNil == HNil = True

4955

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

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

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

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

5555 -- 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".

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

5760

5861 issueIsUnsupported :: Issue l -> Bool

5962

6063data Orientation = Forward | Backward

61− deriving stock (Eq, Ord)

64+ deriving stock (Eq, Ord, Show)

6265

6366toggleOrientation :: Orientation -> Orientation

6467toggleOrientation Forward = Backward

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

7174 toJSON = toJSON . show

7275

7376data AnIssue (l :: BehaviorLevel) where

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

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

7578

7679deriving stock instance Show (AnIssue l)

7780

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

8083deriving stock instance Ord (AnIssue l)

8184

8285instance 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

1414 , embed

1515 , size

1616 , partition

17+ , map

1718 )

1819where

1920

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

3233import qualified GHC.Exts as Exts

3334import OpenAPI.Checker.Paths

3435import Type.Reflection

35−import Prelude hiding (filter, null)

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

3637

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

3839data 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

4142 }

4243 deriving stock (Show)

4344

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+

4449-- TODO: optimize

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

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

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

116121 AnEmptySet :: ASet a

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

118123

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+

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

120129

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

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

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

150159 -> AStep q f r a

151160

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+

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

153165

154166deriving 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

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

3535 type SubtreeLevel (Referenced a) = SubtreeLevel a

3636

37− checkStructuralCompatibility env pc' = do

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

3838 let pc = do

3939 x <- pc'

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

41− pure (dereference defs x)

40+ defs' <- defs

41+ pure (dereference defs' x)

4242 checkSubstructure env pc

4343

44− checkSemanticCompatibility env bhv pc' = do

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

4545 let pc = do

4646 x <- pc'

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

48− pure (dereference defs x)

49− checkCompatibility env bhv pc

47+ defs' <- defs

48+ pure (dereference defs' x)

49+ checkCompatibility bhv env pc

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

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

1414import Data.Foldable

1515import Data.Function

1616import Data.Functor

17−import Data.Functor.Const

1817import Data.List.NonEmpty

1918import qualified Data.List.NonEmpty as NE

2019import qualified Data.Map as M

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

3332import OpenAPI.Checker.PathsPrefixTree hiding (empty)

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

3534import OpenAPI.Checker.Report.Jet

35+import OpenAPI.Checker.Subtree (invertIssueOrientationP)

3636import OpenAPI.Checker.Validate.OpenApi

3737import OpenAPI.Checker.Validate.Schema

3838import Text.Pandoc.Builder

3939

4040type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel

4141

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−

4742data ReportInput = ReportInput

4843 { breakingChanges :: Changes

4944 , nonBreakingChanges :: Changes

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

5954 -- there actually are any breaking changes.

6055 OnlyUnsupportedChanges

6156

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−

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

7758generateReport inp =

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

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

80− partitionUnsupported $ breakingChanges inp

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

82− partitionUnsupported $ nonBreakingChanges inp

83− unsupported = preprocessChanges Forward $ bUnsupported <> nbUnsupported

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

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

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

62+ unsupported = bUnsupported <> nbUnsupported

8463 breakingChangesPresent = not $ P.null breaking

8564 nonBreakingChangesPresent = not $ P.null nonBreaking

8665 unsupportedChangesPresent = not $ P.null unsupported

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

145124 h <- asks headerLevel

146125 tell $ header h i

147126

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

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

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

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

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

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

131+ , otherIssues :: Set (AnIssue a)

153132 ) = case eqT @a @'APILevel of

154133 Just Refl

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

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

156135 S.partition

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

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

158137 NoPathsMatched {} -> True

159138 AllPathsFailed {} -> True)

160139 currentIssues ->

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

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

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

163142 _ -> (Nothing, currentIssues)

164143 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

166145 case removedPaths of

167146 Just (ori, paths) -> do

168147 smartHeader $ case ori of

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

240219

241220observeJetShowErrs

242221 :: ReportJet' Behave Inlines

243− -> ProcessedChanges a

244− -> ReportMonad (ProcessedChanges a)

222+ -> P.PathsPrefixTree Behave AnIssue a

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

245224observeJetShowErrs jet p = case observeJetShowErrs' jet p of

246225 Just m -> m

247226 Nothing -> pure p

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

249228observeJetShowErrs'

250229 :: forall a.

251230 ReportJet' Behave Inlines

252− -> ProcessedChanges a

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

231+ -> P.PathsPrefixTree Behave AnIssue a

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

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

255234 let results =

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

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

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

2424 { producer = traced (step ClientSchema) p

2525 , consumer = traced (step ServerSchema) c

2626 }

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

2828

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

3030runReport = generateReport . runChecker

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

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

1818 , CompatFormula'

1919 , SemanticCompatFormula

2020 , ProdCons (..)

21− , HasUnsupportedFeature (..)

2221 , swapProdCons

2322 , runCompatFormula

2423 , issueAt

24+ , anItem

25+ , anIssue

26+ , invertIssueOrientation

27+ , invertIssueOrientationP

28+ , embedFormula

2529 , anyOfAt

2630 , structuralIssue

2731

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

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

5458import Data.Hashable

5559import Data.Kind

56−import Data.Monoid

5760import Data.OpenApi

5861import qualified Data.Set as S

5962import Data.Typeable

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

106109 }

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

108111

109−swapProdCons :: ProdCons a -> ProdCons a

110−swapProdCons (ProdCons a b) = ProdCons b 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)

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)

111144

112145instance Applicative ProdCons where

113146 pure x = ProdCons x x

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

145178 type SubtreeLevel t :: BehaviorLevel

146179

147180 checkStructuralCompatibility

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

149− => HList xs

181+ :: HList (CheckEnv t)

150182 -> ProdCons (Traced t)

151183 -> StructuralCompatFormula ()

152184

153185 checkSemanticCompatibility

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

155− => HList xs

186+ :: HList (CheckEnv t)

156187 -> Behavior (SubtreeLevel t)

157188 -> ProdCons (Traced t)

158189 -> SemanticCompatFormula ()

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

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

163194

164195checkCompatibility

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

166− => HList xs

167− -> Behavior (SubtreeLevel t)

196+ :: forall t xs.

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

198+ => Behavior (SubtreeLevel t)

199+ -> HList xs

168200 -> ProdCons (Traced t)

169201 -> SemanticCompatFormula ()

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

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

171203 case runCompatFormula $ checkSubstructure e pc of

172− Left _ -> checkSemanticCompatibility e bhv pc

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

173205 Right () -> pure ()

206+{-# INLINE checkCompatibility #-}

174207

175208checkSubstructure

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

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

177210 => HList xs

178211 -> ProdCons (Traced t)

179212 -> StructuralCompatFormula ()

180−checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility e

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

214+{-# INLINE checkSubstructure #-}

181215

182216structuralMaybe

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

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

184218 => HList xs

185219 -> ProdCons (Maybe (Traced a))

186220 -> StructuralCompatFormula ()

187221structuralMaybe e = structuralMaybeWith (checkSubstructure e)

222+{-# INLINE structuralMaybe #-}

188223

189224structuralMaybeWith

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

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

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

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

195230structuralMaybeWith _ _ = structuralIssue

231+{-# INLINE structuralMaybeWith #-}

196232

197233structuralList

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

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

199235 => HList xs

200236 -> ProdCons [Traced a]

201237 -> StructuralCompatFormula ()

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

205241 structuralList e $ ProdCons aa bb

206242 pure ()

207243structuralList _ _ = structuralIssue

244+{-# INLINE structuralList #-}

208245

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

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

248+{-# INLINE structuralEq #-}

211249

212250iohmStructural

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)

214252 => HList xs

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

216254 -> StructuralCompatFormula ()

217255iohmStructural e =

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

257+{-# INLINE iohmStructural #-}

219258

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

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

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

235274 (\eKey ->

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

237276 else structuralIssue

238−

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)

277+{-# INLINE iohmStructuralWith #-}

264278

265279runCompatFormula

266280 :: CompatFormula' q f r a

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

268282runCompatFormula (Compose f) =

269283 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

270288

271289issueAt :: 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)

273307

274308structuralIssue :: StructuralCompatFormula a

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

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

282316 -> CompatFormula' q AnIssue r a

283317anyOfAt _ _ [x] = x

284318anyOfAt xs issue fs =

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

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

286320

287321fixpointKnot

288322 :: MonadState (MemoState VarRef) m

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

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

3434 for_ (tracedSchema c) $ \consRef ->

3535 case tracedSchema p of

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

3838 pure ()

3939

4040instance Steppable Header (Referenced Schema) where

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

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

7979 case tracedSchema p of

8080 Nothing -> issueAt beh MediaTypeSchemaRequired

8181 Just prodRef ->

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

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

8383 ProdCons prodRef consRef

8484 pure ()

8585 where

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

9999 in checkProducts

100100 beh

101101 MediaEncodingMissing

102− (const $ checkCompatibility env beh)

102+ (const $ checkCompatibility beh env)

103103 encProdCons

104104

105105instance Subtree Encoding where

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

147147

148148instance Issuable 'OperationLevel where

149149 data Issue 'OperationLevel

150− = ResponseCodeNotFound HttpStatusCode

150+ = ConsumerDoesntHaveResponseCode HttpStatusCode

151151 | ParamNotMatched Text

152152 | PathFragmentNotMatched Int

153153 | NoRequestBody

154154 deriving stock (Eq, Ord, Show)

155155 issueIsUnsupported = \case

156156 _ -> False

157− describeIssue Forward (ResponseCodeNotFound c) =

158− para $ "Reponse 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."

157+ describeIssue Forward (ConsumerDoesntHaveResponseCode c) =

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

159+ describeIssue Backward (ConsumerDoesntHaveResponseCode c) =

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

161161 describeIssue Forward (ParamNotMatched param) =

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

163163 describeIssue Backward (ParamNotMatched param) =

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

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

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

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

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

40− checkCompatibility env bhv $ ProdCons p c

40+ checkCompatibility bhv env $ ProdCons p c

4141 getFlow

4242 :: Typeable x

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

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

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

6363 missingScopes = cScopes S.\\ pScopes

6464 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

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

6767 pure ()

6868

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

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

7878 checkStructuralCompatibility _ _ = structuralIssue

7979 checkSemanticCompatibility _ beh prodCons = do

8080 checkCompatibility @ProcessedPathItems

81+ beh

8182 ((tracedRequestBodies <$> prodCons)

8283 `HCons` (tracedParameters <$> prodCons)

8384 `HCons` (tracedSecuritySchemes <$> prodCons)

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

8889 `HCons` (tracedLinks <$> prodCons)

8990 `HCons` (tracedCallbacks <$> prodCons)

9091 `HCons` HNil)

91− beh

9292 (tracedPaths <$> prodCons)

9393

9494instance Steppable OpenApi ProcessedPathItems where

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

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

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

204204 }

205205 pure (k, v)

206− check (_, name) param = do

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

206+ check (_, name) param =

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

208208 checkProducts beh (ParamNotMatched . snd) check elements

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

210210 checkPathParams pathParams = do

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

213213 getFragments params mop = getPathFragments (extract mop) params

214214 -- Feed path parameters to the fragments getter

215215 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

217217 elements =

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

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

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

225225 }

226226 checkProducts beh PathFragmentNotMatched check elements

227227 checkRequestBodies = do

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

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

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

230230 getReqBody bodyDef mop = M.fromList $ do

231231 bodyRef <- F.toList . tracedRequestBody $ mop

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

239239 }

240240 )

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

242− checkResponses = do

243− let respEnv =

244− HCons (swapProdCons respDefs) $

245− HCons (swapProdCons headerDefs) $

246− HCons (swapProdCons schemaDefs) $

247− HCons (swapProdCons linkDefs) HNil

248− resps = tracedResponses <$> prodCons

249− checkCompatibility respEnv beh $ swapProdCons resps

242+ checkResponses =

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

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

251245 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

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

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

265249 anyOfAt beh' CallbacksUnsupported $

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

267− checkCompatibility env' beh' $ ProdCons pCallback cCallback

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

268252 pure ()

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

270254 checkOperationSecurity = do

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

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

274258 anyOfAt beh' SecurityRequirementNotMet $

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

276− checkCompatibility env beh' $ ProdCons pSec cSec

260+ checkCompatibility beh' env $ ProdCons pSec cSec

277261 checkServers =

278− checkCompatibility env beh $ do

262+ checkCompatibility beh env $ do

279263 x <- prodCons

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

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

282266 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

286267 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

291268

292269data OperationMethod

293270 = GetMethod

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

399376 F.toList $ matchingPathItems $ ProdCons prodItem consItem

400377 case matchedItems of

401378 [] -> issueAt beh $ NoPathsMatched prodPath

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

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

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

404381 match <- matches

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

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

406383 where

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

408385

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

535512 -- Got only Justs here

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

537514 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

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

540517 -- why not

541518 checkSums beh OperationMissing check operations

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

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

119119 issueAt beh ParamStyleMismatch

120120 case tracedSchema <$> pc of

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

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

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

123123 ProdCons Nothing Nothing -> pure ()

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

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

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

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

7676 then pure ()

7777 else issueAt beh (PathFragmentsDontMatch x y)

7878 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

6464 then issueAt beh RequestBodyRequired

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

6666

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

6868 sumElts = getSum <$> prodCons

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

7070 in checkSums beh RequestMediaTypeNotFound check sumElts

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

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

4949 -- one element

5050 checkSemanticCompatibility env beh prodCons = do

5151 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

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

5454 getEls respDef resps = M.fromList $ do

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

5656 pure (code, dereference respDef respRef)

57− checkSums beh ResponseCodeNotFound check elements

57+ checkSums beh ConsumerDoesntHaveResponseCode check elements

5858

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

6060tracedContent resp =

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

6868

6969instance Issuable 'ResponseLevel where

7070 data Issue 'ResponseLevel

71− = ResponseMediaTypeMissing MediaType

72− | ResponseHeaderMissing HeaderName

71+ = ConsumerDoesntHaveMediaType MediaType

72+ | ProducerDoesntHaveResponseHeader HeaderName

7373 deriving stock (Eq, Ord, Show)

7474 issueIsUnsupported _ = False

75− describeIssue Forward (ResponseMediaTypeMissing t) =

75+ describeIssue Forward (ConsumerDoesntHaveMediaType t) =

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

77− describeIssue Backward (ResponseMediaTypeMissing t) =

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

79− describeIssue Forward (ResponseHeaderMissing h) =

77+ describeIssue Backward (ConsumerDoesntHaveMediaType t) =

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

79+ describeIssue Forward (ProducerDoesntHaveResponseHeader h) =

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

81− describeIssue Backward (ResponseHeaderMissing h) =

81+ describeIssue Backward (ProducerDoesntHaveResponseHeader h) =

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

8383

8484instance Behavable 'ResponseLevel 'PayloadLevel where

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

117117 checkMediaTypes = do

118118 -- Media types are sum-like entity

119119 let check mediaType mtObj =

120− let mtEnv = HCons mediaType $ env

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

120+ let mtEnv = HCons mediaType env

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

122122 elements = getEls <$> prodCons

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

124− checkSums beh ResponseMediaTypeMissing check elements

124+ checkSums beh ConsumerDoesntHaveMediaType check elements

125125

126126 checkHeaders = do

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

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

130130 getEls headerDef resp = M.fromList $ do

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

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

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

138138 }

139139 )

140− checkProducts beh ResponseHeaderMissing check elements

140+ checkProducts beh ProducerDoesntHaveResponseHeader check elements

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

142142

143143instance Steppable Responses (Referenced Response) where

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

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

167167 showForEachJsonFormula i =

168168 bulletList $

169169 foldType

170− (\t f ->

171− let (DNF conds') = f i

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

173− in [ para (describeJSONType t)

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

175− ])

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

171+ BottomFormula -> mempty

172+ (DNF conds') ->

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

174+ in [ para (describeJSONType t)

175+ <> bulletList

176+ (conds <&> \case

177+ [] -> para "Empty"

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

179+ ])

176180

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

178182satisfiesTyped e (Exactly e') = e == e'

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

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

461465

462466warn :: 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

464468

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

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

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

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

804808

805809checkFormulas

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

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

807811 => HList xs

808812 -> Behavior 'SchemaLevel

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

810814 -> SemanticCompatFormula ()

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

812816 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

814818 [] -> do

815819 -- We have the following isomorphisms:

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

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

844848 case (ty fp, ty fc) of

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

846850 (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' []

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

849858 anyOfAt

850859 beh'

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

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

866875

867876checkImplication

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

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

869878 => HList xs

870879 -> Behavior 'TypedSchemaLevel

871880 -> [Condition t]

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

924933 then pure ()

925934 else issueAt beh (NoMatchingFormat f)

926935 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'

928937 Just rs -> do

929938 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

931940 Nothing -> issueAt beh NoMatchingItems

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

933942 Just m' ->

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

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

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

956965 _ -> 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')

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

959968 -- (producer, additional producer, consumer, additional consumer)

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

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

967976 case (madd', madd) of

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

969978 (_, 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)

971980 pure ()

972981 Nothing -> issueAt beh NoMatchingProperties

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

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

10531062 MatchingMinPropertiesWeak (ProdCons Integer)

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

10551064 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

10571067 NoContradiction

10581068 deriving stock (Eq, Ord, Show)

10591069 issueIsUnsupported _ = False

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

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

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

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

1070+ describeIssue Forward (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

1072+ describeIssue Forward (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

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

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

10661076 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

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

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

104104 for_ errs $ issueAt bhv

105− checkCompatibility env bhv pc'

105+ checkCompatibility bhv env pc'

106106 pure ()

107107 pure ()

108108

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

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

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

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

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

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

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

3232 _ -> issueAt bhv DifferentSecuritySchemes

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

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

7676 anyOfAt

7777 bhv

7878 ServerNotMatched

79− [ checkCompatibility env bhv (ProdCons pUrl cUrl)

79+ [ checkCompatibility bhv env (ProdCons pUrl cUrl)

8080 | cUrl <- potentiallyCompatible

8181 ]

8282 pure ()

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

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

99## **POST** /test

1010

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

11breakingChanges:

22 AtPath "/test":

3− InOperation PostMethod: ResponseCodeNotFound 500

3+ InOperation PostMethod: ConsumerDoesntHaveResponseCode 500

44nonBreakingChanges: {}

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

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

22nonBreakingChanges:

33 AtPath "/test":

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

11breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

4− WithStatusCode 200: ResponseHeaderMissing "Test2"

4+ WithStatusCode 200: ProducerDoesntHaveResponseHeader "Test2"

55nonBreakingChanges: {}

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

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

1010

1111### Response code 200

1212

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

11breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

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

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

55nonBreakingChanges: {}

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

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

22nonBreakingChanges:

33 AtPath "/test":

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

99## **POST** /test

1010

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

11breakingChanges: {}

22nonBreakingChanges:

33 AtPath "/test":

4− InOperation PostMethod: ResponseCodeNotFound 500

4+ InOperation PostMethod: ConsumerDoesntHaveResponseCode 500

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

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

77paths:

88 /api/foo:

99 get:

10+ requestBody:

11+ content:

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

13+ schema:

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

15+

1016 responses:

1117 200:

1218 description: ""

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

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

77paths:

88 /api/foo:

99 get:

10+ requestBody:

11+ content:

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

13+ schema:

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

15+

1016 responses:

1117 200:

1218 description: ""

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

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

11# Summary

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

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

5−| 0 | 1 | 0 |

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

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

5+| 1 | 1 | 0 |

7+# <span id="breaking-changes"></span>⚠️ Breaking changes

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+```

620

721# <span id="non-breaking-changes"></span>🙆 Non-breaking changes

822

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

1226

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

1428

15−The following enum value has been removed:

29+The following enum value has been added:

1630

1731``` json

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

214nonBreakingChanges:

315 AtPath "/api/foo":

416 InOperation GetMethod: