695c8fb · compaREST · git.iko.soy

app/Main.hs+4−3

compare with master

unifiedsplit

@@ -38,13 +38,14 @@ main = do

38 let result = runCompatFormula $ checkCompatibility HNil Root (ProdCons a b)

39 runPandocIO :: PandocIO a -> ExceptT Errors IO a

40 runPandocIO x = lift (runIO x) >>= either (throwError . DocumentError) pure

41+ options = def {writerExtensions = githubMarkdownExtensions}

41 output :: Either (PathsPrefixTree Behave AnIssue 'APILevel) () -> ExceptT Errors IO ()

42 output :: Either (PathsPrefixTree Behave AnIssue 'APILevel) () -> ExceptT Errors IO ()

42 output = case outputMode opts of

43 output = case outputMode opts of

43− StdoutMode -> lift . T.putStrLn <=< runPandocIO . writeMarkdown def . generateReport

44+ StdoutMode -> lift . T.putStrLn <=< runPandocIO . writeMarkdown options . generateReport

44 FileMode f -> case formatFromFilePath f of

45 FileMode f -> case formatFromFilePath f of

45 Nothing -> \_ -> throwError UnknownOutputFormat

46 Nothing -> \_ -> throwError UnknownOutputFormat

46− Just (TextWriter writer) -> lift . T.writeFile f <=< runPandocIO . writer def . generateReport

47+ Just (TextWriter writer) -> lift . T.writeFile f <=< runPandocIO . writer options . generateReport

47− Just (ByteStringWriter writer) -> lift . BSL.writeFile f <=< runPandocIO . writer def . generateReport

48+ Just (ByteStringWriter writer) -> lift . BSL.writeFile f <=< runPandocIO . writer options . generateReport

48 either handler pure <=< runExceptT $ output result

49 either handler pure <=< runExceptT $ output result

49 case result of

50 case result of

50 Right () -> exitSuccess

51 Right () -> exitSuccess

openapi-diff.cabal+1

@@ -133,6 +133,7 @@ library

133 , OpenAPI.Checker.Validate.OAuth2Flows

134 , OpenAPI.Checker.Report

135 , Data.OpenUnion.Extra

136+ , OpenAPI.Checker.Report.Jet

136

137

137executable openapi-diff

138executable openapi-diff

138 import: common-options

139 import: common-options

src/OpenAPI/Checker/Behavior.hs+2

@@ -55,6 +55,8 @@ instance Issuable l => ToJSON (Issue l) where

55data AnIssue (l :: BehaviorLevel) where

56 AnIssue :: Issuable l => Issue l -> AnIssue l

57

58+deriving stock instance Show (AnIssue l)

59+

58deriving stock instance Eq (AnIssue l)

60deriving stock instance Eq (AnIssue l)

59

61

60deriving stock instance Ord (AnIssue l)

62deriving stock instance Ord (AnIssue l)

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

@@ -10,10 +10,14 @@ module OpenAPI.Checker.PathsPrefixTree

10 , foldWith

11 , toList

12 , filter

13+ , takeSubtree

13 , embed

14 , embed

15+ , size

16+ , partition

14 )

17 )

15where

18where

16

19

20+import Control.Monad

17import Data.Aeson

21import Data.Aeson

18import Data.Foldable hiding (null, toList)

22import Data.Foldable hiding (null, toList)

19import qualified Data.HashMap.Strict as HM

23import qualified Data.HashMap.Strict as HM

@@ -26,7 +30,6 @@ import Data.Type.Equality

26import qualified Data.TypeRepMap as TRM

30import qualified Data.TypeRepMap as TRM

27import qualified Data.Vector as V

31import qualified Data.Vector as V

28import qualified GHC.Exts as Exts

32import qualified GHC.Exts as Exts

29−import qualified GHC.Exts as TRM

30import OpenAPI.Checker.Paths

33import OpenAPI.Checker.Paths

31import Type.Reflection

34import Type.Reflection

32import Prelude hiding (filter, null)

35import Prelude hiding (filter, null)

@@ -36,13 +39,33 @@ data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPref

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

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

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

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

38 }

41 }

42+ deriving stock (Show)

43+

44+-- TODO: optimize

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

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

47+

48+filter :: (forall a. f a -> Bool) -> PathsPrefixTree q f r -> PathsPrefixTree q f r

49+filter f (PathsPrefixTree roots branches) = PathsPrefixTree roots' branches'

50+ where

51+ roots' = filterASet f roots

52+ branches' =

53+ Exts.fromList

54+ . fmap (\(TRM.WrapTypeable (AStep x)) -> TRM.WrapTypeable . AStep . M.filter (not . null) . fmap (filter f) $ x)

55+ . Exts.toList

56+ $ branches

57+

58+-- | The number of leaves.

59+size :: PathsPrefixTree q f r -> Int

60+size (PathsPrefixTree root branches) =

61+ (S.size . toSet $ root)

62+ + (sum . fmap (\(TRM.WrapTypeable (AStep x)) -> sum . fmap size . M.elems $ x) . Exts.toList $ branches)

39

63

40pattern PathsPrefixNode :: Ord (f r) => S.Set (f r) -> [TRM.WrapTypeable (AStep q f r)] -> PathsPrefixTree q f r

64pattern PathsPrefixNode :: Ord (f r) => S.Set (f r) -> [TRM.WrapTypeable (AStep q f r)] -> PathsPrefixTree q f r

41pattern PathsPrefixNode s steps <-

65pattern PathsPrefixNode s steps <-

42 (\(PathsPrefixTree aset m) -> (toSet aset, Exts.toList m) -> (s, steps))

66 (\(PathsPrefixTree aset m) -> (toSet aset, Exts.toList m) -> (s, steps))

43 where

67 where

44− PathsPrefixNode s steps | S.null s = PathsPrefixTree AnEmptySet (Exts.fromList steps)

68+ PathsPrefixNode s steps = PathsPrefixTree (fromSet s) (Exts.fromList steps)

45− PathsPrefixNode s steps = PathsPrefixTree (ASet s) (Exts.fromList steps)

46

69

47{-# COMPLETE PathsPrefixNode #-}

70{-# COMPLETE PathsPrefixNode #-}

48

71

@@ -79,25 +102,32 @@ compareTRM s1 s2 =

79 | otherwise = EQ -- unreachable

102 | otherwise = EQ -- unreachable

80 toMap s =

103 toMap s =

81 M.fromList

104 M.fromList

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

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

83

106

84instance Ord (PathsPrefixTree q f a) where

107instance Ord (PathsPrefixTree q f a) where

85 compare (PathsPrefixTree r1 s1) (PathsPrefixTree r2 s2) =

108 compare (PathsPrefixTree r1 s1) (PathsPrefixTree r2 s2) =

86 compare r1 r2 <> compareTRM s1 s2

109 compare r1 r2 <> compareTRM s1 s2

87

110

111+filterASet :: (a -> Bool) -> ASet a -> ASet a

112+filterASet _ AnEmptySet = AnEmptySet

113+filterASet f (ASet s) = fromSet $ S.filter f s

114+

88data ASet (a :: Type) where

115data ASet (a :: Type) where

89 AnEmptySet :: ASet a

116 AnEmptySet :: ASet a

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

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

91

118

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

120+

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

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

93toSet AnEmptySet = S.empty

122toSet AnEmptySet = S.empty

94toSet (ASet s) = s

123toSet (ASet s) = s

95

124

125+fromSet :: Ord a => S.Set a -> ASet a

126+fromSet s | S.null s = AnEmptySet

127+fromSet s = ASet s

128+

96instance ToJSON a => ToJSON (ASet a) where

129instance ToJSON a => ToJSON (ASet a) where

97− toJSON =

130+ toJSON = toJSON . toSet

98− toJSON . \case

99− AnEmptySet -> S.empty

100− ASet s -> s

101

131

102instance Semigroup (ASet a) where

132instance Semigroup (ASet a) where

103 AnEmptySet <> s = s

133 AnEmptySet <> s = s

@@ -168,7 +198,7 @@ foldWith k = goTPT Root

168 goASet _ AnEmptySet = mempty

198 goASet _ AnEmptySet = mempty

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

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

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

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

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

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

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

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

173 goAStep xs (AStep m) =

203 goAStep xs (AStep m) =

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

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

@@ -177,11 +207,11 @@ toList :: PathsPrefixTree q f r -> [AnItem q f r]

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

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

178

208

179-- | Select a subtree by prefix

209-- | Select a subtree by prefix

180−filter :: forall q f r a. Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a

210+takeSubtree :: forall q f r a. Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a

181−filter Root t = t

211+takeSubtree Root t = t

182−filter (Snoc xs x) t =

212+takeSubtree (Snoc xs x) t =

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

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

184− TRM.lookup @a $ snocItems $ filter xs t

214+ TRM.lookup @a $ snocItems $ takeSubtree xs t

185

215

186-- | Embed a subtree in a larger tree with given prefix

216-- | Embed a subtree in a larger tree with given prefix

187embed :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r

217embed :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r

src/OpenAPI/Checker/Report.hs+100−91

@@ -3,7 +3,6 @@ module OpenAPI.Checker.Report

3 )

4where

5

6−import Control.Applicative

7import Control.Monad.Free hiding (unfoldM)

6import Control.Monad.Free hiding (unfoldM)

8import Control.Monad.Reader

7import Control.Monad.Reader

9import Control.Monad.Writer

8import Control.Monad.Writer

@@ -17,6 +16,8 @@ import qualified Data.Map as M

17import Data.Maybe

16import Data.Maybe

18import Data.OpenUnion

17import Data.OpenUnion

19import Data.OpenUnion.Extra

18import Data.OpenUnion.Extra

19+import Data.Set

20+import qualified Data.Set as S

20import Data.Text (Text)

21import Data.Text (Text)

21import qualified Data.Text as T

22import qualified Data.Text as T

22import Data.TypeRepMap hiding (empty)

23import Data.TypeRepMap hiding (empty)

@@ -25,13 +26,45 @@ import OpenAPI.Checker.Behavior

25import OpenAPI.Checker.Paths

26import OpenAPI.Checker.Paths

26import OpenAPI.Checker.PathsPrefixTree hiding (empty)

27import OpenAPI.Checker.PathsPrefixTree hiding (empty)

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

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

29+import OpenAPI.Checker.Report.Jet

28import OpenAPI.Checker.Validate.OpenApi

30import OpenAPI.Checker.Validate.OpenApi

29import OpenAPI.Checker.Validate.Schema

31import OpenAPI.Checker.Validate.Schema

30import Text.Pandoc.Builder

32import Text.Pandoc.Builder

31

33

32generateReport :: Either (P.PathsPrefixTree Behave AnIssue 'APILevel) () -> Pandoc

34generateReport :: Either (P.PathsPrefixTree Behave AnIssue 'APILevel) () -> Pandoc

33generateReport (Right ()) = doc $ header 1 "No breaking changes found ✨"

35generateReport (Right ()) = doc $ header 1 "No breaking changes found ✨"

34−generateReport (Left errs) = doc $ runReportMonad jets $ showErrs errs

36+generateReport (Left errs) = doc $

37+ runReportMonad jets $ do

38+ let (unsupported, breaking) = P.partition (\(AnIssue i) -> issueIsUnsupported i) errs

39+ breakingChangesPresent = not $ P.null breaking

40+ unsupportedChangesPresent = not $ P.null unsupported

41+ smartHeader "Summary"

42+ tell $

43+ simpleTable

44+ (para

45+ <$> [ refOpt breakingChangesPresent breakingChangesId "⚠️ Breaking changes"

46+ , refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"

47+ ])

48+ [para . show' <$> [P.size breaking, P.size unsupported]]

49+ when breakingChangesPresent $ do

50+ smartHeader $ anchor breakingChangesId <> "⚠️ Breaking changes"

51+ incrementHeaders $ showErrs breaking

52+ when unsupportedChangesPresent $ do

53+ smartHeader $ anchor unsupportedChangesId <> "🤷 Unsupported feature changes"

54+ incrementHeaders $ showErrs unsupported

55+ where

56+ anchor :: Text -> Inlines

57+ anchor a = spanWith (a, [], []) mempty

58+

59+ refOpt :: Bool -> Text -> Inlines -> Inlines

60+ refOpt False _ i = i

61+ refOpt True a i = link ("#" <> a) "" i

62+

63+ breakingChangesId :: Text

64+ breakingChangesId = "breaking-changes"

65+

66+ unsupportedChangesId :: Text

67+ unsupportedChangesId = "unsupported-changes"

35

68

36data ReportState = ReportState

69data ReportState = ReportState

37 { sourceJets :: [ReportJet' Behave Inlines]

70 { sourceJets :: [ReportJet' Behave Inlines]

@@ -55,10 +88,29 @@ smartHeader i = do

55 h <- asks headerLevel

88 h <- asks headerLevel

56 tell $ header h i

89 tell $ header h i

57

90

58−showErrs :: P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()

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

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

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

93+ let -- Extract this pattern if more cases like this arise

94+ (removedPaths :: [Issue 'APILevel], otherIssues :: Set (AnIssue a)) = case eqT @a @'APILevel of

95+ Just Refl ->

96+ let (p, o) =

97+ S.partition

98+ (\(AnIssue u) -> case u of

99+ NoPathsMatched {} -> True

100+ AllPathsFailed {} -> True)

101+ currentIssues

102+ p' = S.toList p <&> (\(AnIssue i) -> i)

103+ in (p', o)

104+ Nothing -> (mempty, currentIssues)

60 jts <- asks sourceJets

105 jts <- asks sourceJets

61− for_ currentIssues $ \(AnIssue i) -> tell . describeIssue $ i

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

107+ unless ([] == removedPaths) $ do

108+ smartHeader "Removed paths"

109+ tell $

110+ bulletList $

111+ removedPaths <&> \case

112+ (NoPathsMatched p) -> para . code $ T.pack p

113+ (AllPathsFailed p) -> para . code $ T.pack p

62 unfoldM x (observeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do

114 unfoldM x (observeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do

63 for_ subIssues $ \(WrapTypeable (AStep m)) ->

115 for_ subIssues $ \(WrapTypeable (AStep m)) ->

64 for_ (M.toList m) $ \(bhv, subErrors) -> do

116 for_ (M.toList m) $ \(bhv, subErrors) -> do

@@ -72,93 +124,6 @@ unfoldM a (f : ff) g = do

72 a' <- f a

124 a' <- f a

73 unfoldM a' ff g

125 unfoldM a' ff g

74

126

75−observeJetShowErrs

76− :: ReportJet' Behave Inlines

77− -> P.PathsPrefixTree Behave AnIssue a

78− -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)

79−observeJetShowErrs jet p = case observeJetShowErrs' jet p of

80− Just m -> m

81− Nothing -> pure p

82−

83−observeJetShowErrs'

84− :: forall a.

85− ReportJet' Behave Inlines

86− -> P.PathsPrefixTree Behave AnIssue a

87− -> Maybe (ReportMonad (P.PathsPrefixTree Behave AnIssue a))

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

89− let results =

90− subIssues >>= \(WrapTypeable (AStep m)) ->

91− M.toList m <&> \(bhv, subErrs) ->

92− maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $

93− jet @_ @_ @[] bhv

94− & mapMaybe

95− (\case

96− Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs

97− Pure h -> Just $ do

98− smartHeader h

99− incrementHeaders $ showErrs subErrs

100− return mempty)

101− in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $

102− if any isRight results

103− then

104− Just $

105− catMapM

106− (\case

107− Left e -> pure e

108− Right m -> m)

109− results

110− else Nothing

111−

112−catMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b

113−catMapM f xs = mconcat <$> mapM f xs

114−

115−-- | A "jet" is a way of simplifying expressions from "outside". The "jetted"

116−-- expressions should still be completely valid and correct without the jets.

117−-- Jets just make the expression more "optimized" by identifying patterns and

118−-- replacing the expressions with "better" ones that have the same sematics.

119−--

120−-- The term "jet" in this context was introduced in the Urbit project:

121−-- https://urbit.org/docs/vere/jetting/

122−--

123−-- The pattern fits well for simplifying 'Behaviour' tree paths.

124−class ConstructReportJet x f where

125− constructReportJet :: x -> ReportJetResult f Inlines

126−

127−instance (ConstructReportJet b f, JetArg a) => ConstructReportJet (a -> b) f where

128− constructReportJet f = Free (fmap f <$> consumeJetArg @a) >>= constructReportJet

129−

130−instance ConstructReportJet Inlines f where

131− constructReportJet x = Pure x

132−

133−class JetArg a where

134− consumeJetArg :: ReportJet' f a

135−

136−instance Typeable (f a b) => JetArg (f a b) where

137− consumeJetArg =

138− ReportJet $ \(x :: x) ->

139− case eqT @(f a b) @x of

140− Nothing -> empty

141− Just Refl -> pure $ Pure x

142−

143−instance TryLiftUnion xs => JetArg (Union xs) where

144− consumeJetArg = ReportJet $ fmap Pure . tryLiftUnion

145−

146−instance JetArg x => JetArg (NonEmpty x) where

147− consumeJetArg =

148− let (ReportJet f) = (consumeJetArg @x)

149− in ReportJet $ \a -> do

150− u <- f a

151− pure (u >>= \y -> Free $ fmap (NE.cons y) <$> consumeJetArg)

152− <|> pure (pure <$> u)

153−

154−type ReportJetResult f = Free (ReportJet f)

155−

156−-- Not a true 'Applicative'

157−newtype ReportJet f x = ReportJet (forall a b m. (Typeable (f a b), Alternative m, Monad m) => f a b -> m x)

158− deriving stock (Functor)

159−

160−type ReportJet' f a = ReportJet f (Free (ReportJet f) a)

161−

162incrementHeaders :: ReportMonad x -> ReportMonad x

127incrementHeaders :: ReportMonad x -> ReportMonad x

163incrementHeaders m = do

128incrementHeaders m = do

164 l <- asks headerLevel

129 l <- asks headerLevel

@@ -209,3 +174,47 @@ jets =

209 @@> typesExhausted)

174 @@> typesExhausted)

210 y

175 y

211 <> showParts ys

176 <> showParts ys

177+

178+observeJetShowErrs

179+ :: ReportJet' Behave Inlines

180+ -> P.PathsPrefixTree Behave AnIssue a

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

182+observeJetShowErrs jet p = case observeJetShowErrs' jet p of

183+ Just m -> m

184+ Nothing -> pure p

185+

186+observeJetShowErrs'

187+ :: forall a.

188+ ReportJet' Behave Inlines

189+ -> P.PathsPrefixTree Behave AnIssue a

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

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

192+ let results =

193+ subIssues >>= \(WrapTypeable (AStep m)) ->

194+ M.toList m <&> \(bhv, subErrs) ->

195+ maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $

196+ jet @_ @_ @[] bhv

197+ & mapMaybe

198+ (\case

199+ Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs

200+ Pure h -> Just $ do

201+ unless (P.null subErrs) $ do

202+ smartHeader h

203+ incrementHeaders $ showErrs subErrs

204+ return mempty)

205+ in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $

206+ if any isRight results

207+ then

208+ Just $

209+ catMapM

210+ (\case

211+ Left e -> pure e

212+ Right m -> m)

213+ results

214+ else Nothing

215+

216+catMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b

217+catMapM f xs = mconcat <$> mapM f xs

218+

219+show' :: Show x => x -> Inlines

220+show' = str . T.pack . show

src/OpenAPI/Checker/Report/Jet.hsnew file+64

@@ -0,0 +1,64 @@

1+module OpenAPI.Checker.Report.Jet

2+ ( ReportJet (..)

3+ , ReportJet'

4+ , ConstructReportJet (..)

5+ , ReportJetResult

6+ )

7+where

8+

9+import Control.Applicative

10+import Control.Monad.Free

11+import Data.List.NonEmpty

12+import qualified Data.List.NonEmpty as NE

13+import Data.OpenUnion

14+import Data.OpenUnion.Extra

15+import Data.Typeable

16+import Text.Pandoc.Builder

17+

18+-- | A "jet" is a way of simplifying expressions from "outside". The "jetted"

19+-- expressions should still be completely valid and correct without the jets.

20+-- Jets just make the expression more "optimized" by identifying patterns and

21+-- replacing the expressions with "better" ones that have the same sematics.

22+--

23+-- The term "jet" in this context was introduced in the Urbit project:

24+-- https://urbit.org/docs/vere/jetting/

25+--

26+-- The pattern fits well for simplifying 'Behaviour' tree paths.

27+class ConstructReportJet x f where

28+ constructReportJet :: x -> ReportJetResult f Inlines

29+

30+instance (ConstructReportJet b f, JetArg a) => ConstructReportJet (a -> b) f where

31+ constructReportJet f = Free (fmap f <$> consumeJetArg @a) >>= constructReportJet

32+

33+instance ConstructReportJet Inlines f where

34+ constructReportJet x = Pure x

35+

36+class JetArg a where

37+ consumeJetArg :: ReportJet' f a

38+

39+instance Typeable (f a b) => JetArg (f a b) where

40+ consumeJetArg =

41+ ReportJet $ \(x :: x) ->

42+ case eqT @(f a b) @x of

43+ Nothing -> empty

44+ Just Refl -> pure $ Pure x

45+

46+instance TryLiftUnion xs => JetArg (Union xs) where

47+ consumeJetArg = ReportJet $ fmap Pure . tryLiftUnion

48+

49+instance JetArg x => JetArg (NonEmpty x) where

50+ consumeJetArg =

51+ let (ReportJet f) = (consumeJetArg @x)

52+ in ReportJet $ \a -> do

53+ u <- f a

54+ pure (u >>= \y -> Free $ fmap (NE.cons y) <$> consumeJetArg)

55+ <|> pure (pure <$> u)

56+

57+type ReportJetResult f = Free (ReportJet f)

58+

59+-- Not a true 'Applicative'

60+newtype ReportJet f x

61+ = ReportJet (forall a b m. (Typeable (f a b), Alternative m, Monad m) => f a b -> m x)

62+ deriving stock (Functor)

63+

64+type ReportJet' f a = ReportJet f (Free (ReportJet f) a)

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

@@ -306,7 +306,7 @@ memo bhv k f pc = Compose $ do

306 fixpointKnot

307 (do

308 formula <- getCompose $ f pc

309− pure $ mapErrors (P.filter bhv) formula)

309+ pure $ mapErrors (P.takeSubtree bhv) formula)

310 (k, ask <$> pc)

311 pure $ mapErrors (P.embed bhv) formula'

312

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

@@ -51,8 +51,8 @@ instance Issuable 'HeaderLevel where

51 | HeaderSchemaRequired

52 deriving stock (Eq, Ord, Show)

53 issueIsUnsupported _ = False

54− describeIssue RequiredHeaderMissing = para "Header expected, but missing."

54+ describeIssue RequiredHeaderMissing = para "Header has become required."

55− describeIssue NonEmptyHeaderRequired = para "Empty header not allowed."

55+ describeIssue NonEmptyHeaderRequired = para "The header does not allow empty values anymore."

56 describeIssue HeaderSchemaRequired = para "Expected header schema, but it is not present."

57

58instance Behavable 'HeaderLevel 'SchemaLevel where

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

@@ -43,7 +43,7 @@ instance Issuable 'PayloadLevel where

43 _ -> False

44

45 describeIssue MediaTypeSchemaRequired = para "Media type expected, but was not specified."

46− describeIssue (MediaEncodingMissing enc) = para $ "Media encoding " <> str enc <> " expected, but was not specified."

46+ describeIssue (MediaEncodingMissing enc) = para $ "Media encoding " <> str enc <> " added."

47 describeIssue EncodingNotSupported = para "OpenApi Diff does not currently support media encodings other than JSON."

48

49instance Behavable 'PayloadLevel 'SchemaLevel where

@@ -154,10 +154,10 @@ instance Issuable 'OperationLevel where

154 issueIsUnsupported = \case

155 _ -> False

156 describeIssue (ResponseCodeNotFound c) =

157− para $ "Reponse code " <> (str . T.pack . show $ c) <> " is not supported."

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

158 describeIssue (ParamNotMatched param) =

159− para $ "Parameter " <> str param <> " is not supported."

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

160 describeIssue (PathFragmentNotMatched i) =

161 -- TODO: Indices are meaningless in this context. Replace with a better error.

162 para $ "Path fragment " <> (str . T.pack . show $ i) <> " not matched."

163− describeIssue NoRequestBody = para "Request body not specified."

163+ describeIssue NoRequestBody = para "Request body has been added."

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

@@ -104,7 +104,7 @@ instance Issuable 'SecurityRequirementLevel where

104 | UndefinedSecurityScheme Text

105 deriving stock (Eq, Ord, Show)

106 issueIsUnsupported _ = False

107− describeIssue SecurityRequirementNotMet = para "Security scheme was not met."

107+ describeIssue SecurityRequirementNotMet = para "Security scheme has been removed."

108 describeIssue (UndefinedSecurityScheme k) = para $ "Security scheme " <> code k <> " is not defined."

109

110instance Issuable 'SecuritySchemeLevel where

@@ -129,23 +129,23 @@ instance Issuable 'SecuritySchemeLevel where

129 | ScopeNotDefined Text

130 deriving stock (Eq, Ord, Show)

131 issueIsUnsupported _ = False

132− describeIssue RefreshUrlsDontMatch = para "Refresh URLs differ."

132+ describeIssue RefreshUrlsDontMatch = para "Refresh URL changed."

133− describeIssue (HttpSchemeTypesDontMatch _ _) = para "HTTP scheme types don't match."

133+ describeIssue (HttpSchemeTypesDontMatch _ _) = para "HTTP scheme type changed."

134− describeIssue (ApiKeyParamsDontMatch _ _) = para "API Key parameters don't match."

134+ describeIssue (ApiKeyParamsDontMatch _ _) = para "API Key parameters changed."

135− describeIssue (OpenIdConnectUrlsDontMatch _ _) = para "OpenaId Connect URLs don't match."

135+ describeIssue (OpenIdConnectUrlsDontMatch _ _) = para "OpenaId Connect URL changed."

136 describeIssue (CustomHttpSchemesDontMatch e a) =

137− para $ "Expected HTTP scheme " <> code e <> " but got " <> code a <> "."

137+ para $ "Changed HTTP scheme from " <> code e <> " to " <> code a <> "."

138− describeIssue ConsumerDoesNotSupportImplicitFlow = para "Implicit flow not supported."

138+ describeIssue ConsumerDoesNotSupportImplicitFlow = para "Implicit flow support has been removed."

139− describeIssue ConsumerDoesNotSupportPasswordFlow = para "Password flow not supported."

139+ describeIssue ConsumerDoesNotSupportPasswordFlow = para "Password flow support has been removed."

140− describeIssue ConsumerDoesNotSupportClientCridentialsFlow = para "Client Cridentials flow not supported."

140+ describeIssue ConsumerDoesNotSupportClientCridentialsFlow = para "Client Cridentials flow support has been removed."

141− describeIssue ConsumerDoesNotSupportAuthorizationCodeFlow = para "Authorization Code flow not supported."

141+ describeIssue ConsumerDoesNotSupportAuthorizationCodeFlow = para "Authorization Code flow support has been removed."

142− describeIssue SecuritySchemeNotMatched = para "Security scheme not met."

142+ describeIssue SecuritySchemeNotMatched = para "Security scheme has been removed."

143− describeIssue OAuth2ImplicitFlowNotEqual = para "Implicit Flows don't match."

143+ describeIssue OAuth2ImplicitFlowNotEqual = para "Implicit Flow changed."

144− describeIssue OAuth2PasswordFlowNotEqual = para "Password Flows don't match."

144+ describeIssue OAuth2PasswordFlowNotEqual = para "Password Flow changed."

145− describeIssue OAuth2ClientCredentialsFlowNotEqual = para "Client Cridentials Flows don't match."

145+ describeIssue OAuth2ClientCredentialsFlowNotEqual = para "Client Cridentials Flow changed."

146− describeIssue OAuth2AuthorizationCodeFlowNotEqual = para "Authorization Code Flows don't match."

146+ describeIssue OAuth2AuthorizationCodeFlowNotEqual = para "Authorization Code Flow changed."

147 describeIssue (ScopesMissing ss) =

148− para "Scopes missing:" <> bulletList (S.toList ss <&> codeBlock)

148+ para "New scopes required:" <> bulletList (S.toList ss <&> codeBlock)

149 describeIssue DifferentSecuritySchemes = para "Completely different security scheme types."

150 describeIssue CanNotHaveScopes = para "The specified security scheme can not have scopes."

151 describeIssue (ScopeNotDefined k) = para $ "Scope with key " <> code k <> " is not defined."

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

@@ -4,6 +4,7 @@

4

5module OpenAPI.Checker.Validate.OpenApi

6 ( Behave (..)

7+ , Issue (..)

7 )

8 )

8where

9where

9

10

src/OpenAPI/Checker/Validate/Operation.hs+4−3

@@ -14,6 +14,7 @@ module OpenAPI.Checker.Validate.Operation

14 , processPathItems

15 , Step (..)

16 , Behave (..)

17+ , Issue (..)

17 )

18 )

18where

19where

19

20

@@ -358,8 +359,8 @@ instance Issuable 'APILevel where

358 -- When several paths match given but all checks failed

359 -- When several paths match given but all checks failed

359 deriving stock (Eq, Ord, Show)

360 deriving stock (Eq, Ord, Show)

360 issueIsUnsupported _ = False

361 issueIsUnsupported _ = False

361− describeIssue (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " did not match anything."

362+ describeIssue (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been removed."

362− describeIssue (AllPathsFailed p) = para $ "The path " <> (code . T.pack) p <> " did not match anything."

363+ describeIssue (AllPathsFailed p) = para $ "The path " <> (code . T.pack) p <> " has been removed."

363

364

364instance Behavable 'APILevel 'PathLevel where

365instance Behavable 'APILevel 'PathLevel where

365 data Behave 'APILevel 'PathLevel

366 data Behave 'APILevel 'PathLevel

@@ -461,7 +462,7 @@ instance Issuable 'PathLevel where

461 = OperationMissing OperationMethod

462 = OperationMissing OperationMethod

462 deriving stock (Eq, Ord, Show)

463 deriving stock (Eq, Ord, Show)

463 issueIsUnsupported _ = False

464 issueIsUnsupported _ = False

464− describeIssue (OperationMissing op) = para $ "Method " <> strong (showMethod op) <> " is not defined."

465+ describeIssue (OperationMissing op) = para $ "Method " <> strong (showMethod op) <> " has been removed."

465

466

466instance Behavable 'PathLevel 'OperationLevel where

467instance Behavable 'PathLevel 'OperationLevel where

467 data Behave 'PathLevel 'OperationLevel

468 data Behave 'PathLevel 'OperationLevel

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

@@ -71,11 +71,11 @@ instance Issuable 'PathFragmentLevel where

71 issueIsUnsupported _ = False

72 describeIssue ParamNameMismatch = para "The path fragments don't match."

73 describeIssue ParamEmptinessIncompatible = para "Expected that an empty parameter is allowed, but it isn't."

74− describeIssue ParamRequired = para "Expected the parameter to be optional, but it is required."

74+ describeIssue ParamRequired = para "Parameter has become required."

75 describeIssue ParamPlaceIncompatible = para "Parameters in incompatible locations."

76 describeIssue ParamStyleMismatch = para "Different parameter styles (encodings)."

77 describeIssue ParamSchemaMismatch = para "Expected a schema, but didn't find one."

78− describeIssue (PathFragmentsDontMatch e a) = para $ "Expected " <> code e <> " but got " <> code a <> "."

78+ describeIssue (PathFragmentsDontMatch e a) = para $ "Parameter changed from " <> code e <> " to " <> code a <> "."

79

80instance Behavable 'PathFragmentLevel 'SchemaLevel where

81 data Behave 'PathFragmentLevel 'SchemaLevel

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

@@ -32,9 +32,9 @@ instance Issuable 'RequestLevel where

32 deriving stock (Eq, Ord, Show)

33 issueIsUnsupported _ = False

34 describeIssue RequestBodyRequired =

35− para "Expected the request body to be optional, but found it to be required."

35+ para "Request body has become required."

36 describeIssue (RequestMediaTypeNotFound t) =

37− para $ "Couldn't find a request body for media type " <> (code . T.pack . show $ t) <> "."

37+ para $ "Media type " <> (code . T.pack . show $ t) <> " has been removed."

38

39instance Behavable 'RequestLevel 'PayloadLevel where

40 data Behave 'RequestLevel 'PayloadLevel

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

@@ -73,9 +73,9 @@ instance Issuable 'ResponseLevel where

73 deriving stock (Eq, Ord, Show)

74 issueIsUnsupported _ = False

75 describeIssue (ResponseMediaTypeMissing t) =

76− para $ "Couldn't find reponse for media type " <> (code . T.pack . show $ t) <> "."

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

77 describeIssue (ResponseHeaderMissing h) =

78− para $ "Couldn't find header " <> code h <> "."

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

79

80instance Behavable 'ResponseLevel 'PayloadLevel where

81 data Behave 'ResponseLevel 'PayloadLevel

src/OpenAPI/Checker/Validate/Schema.hs+57−46

@@ -848,8 +848,15 @@ checkFormulas env beh (ProdCons (fp, ep) (fc, ec)) =

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

849 anyOfAt

850 beh'

851− (NoMatchingCondition $ SomeCondition <$> ps)

851+ (issueFromConjunct ps)

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

853+ where

854+ issueFromConjunct :: Typeable t => [Condition t] -> Issue 'TypedSchemaLevel

855+ issueFromConjunct ps

856+ | Just e <- findExactly ps

857+ , all (satisfiesTyped e) ps =

858+ EnumDoesntSatisfy $ untypeValue e

859+ issueFromConjunct ps = NoMatchingCondition $ SomeCondition <$> ps

853

860

854checkContradiction

861checkContradiction

855 :: Behavior 'TypedSchemaLevel

862 :: Behavior 'TypedSchemaLevel

@@ -943,18 +950,20 @@ checkImplication env beh prods cons = case findExactly prods of

943 anyOfAt beh NoMatchingProperties $

950 anyOfAt beh NoMatchingProperties $

944 NE.toList pm <&> \(props', madd') -> do

951 NE.toList pm <&> \(props', madd') -> do

945 F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do

952 F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do

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

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

948− (Nothing, Nothing, _, _) -> pure () -- vacuously

949− (_, _, Nothing, Nothing) -> issueAt beh (UnexpectedProperty k)

950− (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)

951− (Nothing, Just add', Just p, _) -> go add' (propRefSchema p)

952− (Just p', _, Nothing, Just add) -> go (propRefSchema p') add

953− (Nothing, Just _, Nothing, Just _) -> pure ()

954 case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of

953 case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of

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

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

956− _ -> pure ()

956+ _ -> do

957− pure ()

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

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

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

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

961+ -- this ^ seems fishy. Producer does not produce anything, but consumer might expect a field.

962+ (_, _, Nothing, Nothing) -> issueAt beh (UnexpectedProperty k)

963+ (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)

964+ (Nothing, Just add', Just p, _) -> go add' (propRefSchema p)

965+ (Just p', _, Nothing, Just add) -> go (propRefSchema p') add

966+ (Nothing, Just _, Nothing, Just _) -> pure ()

958 case (madd', madd) of

967 case (madd', madd) of

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

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

960 (_, Nothing) -> issueAt beh NoAdditionalProperties

969 (_, Nothing) -> issueAt beh NoAdditionalProperties

@@ -974,14 +983,16 @@ checkImplication env beh prods cons = case findExactly prods of

974 else issueAt beh (MatchingMinPropertiesWeak ProdCons {producer = m', consumer = m})

983 else issueAt beh (MatchingMinPropertiesWeak ProdCons {producer = m', consumer = m})

975 Nothing -> issueAt beh (NoMatchingMinProperties m)

984 Nothing -> issueAt beh (NoMatchingMinProperties m)

976 where

985 where

977− findExactly (Exactly x : _) = Just x

978− findExactly (_ : xs) = findExactly xs

979− findExactly [] = Nothing

980 findRelevant combine extr =

986 findRelevant combine extr =

981 fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr

987 fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr

982 lcmScientific (toRational -> a) (toRational -> b) =

988 lcmScientific (toRational -> a) (toRational -> b) =

983 fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

989 fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

984

990

991+findExactly :: [Condition t] -> Maybe (TypedValue t)

992+findExactly (Exactly x : _) = Just x

993+findExactly (_ : xs) = findExactly xs

994+findExactly [] = Nothing

995+

985instance Issuable 'TypedSchemaLevel where

996instance Issuable 'TypedSchemaLevel where

986 data Issue 'TypedSchemaLevel

997 data Issue 'TypedSchemaLevel

987 = -- | producer produces a specific value ($1), consumer has a condition that is not satisfied by said value

998 = -- | producer produces a specific value ($1), consumer has a condition that is not satisfied by said value

@@ -1010,7 +1021,7 @@ instance Issuable 'TypedSchemaLevel where

1010 NoMatchingMinLength Integer

1021 NoMatchingMinLength Integer

1011 | -- | consumer declares a minimum length of the string ($1), producer declares a weaker (lower) limit ($2)

1022 | -- | consumer declares a minimum length of the string ($1), producer declares a weaker (lower) limit ($2)

1012 MatchingMinLengthWeak (ProdCons Integer)

1023 MatchingMinLengthWeak (ProdCons Integer)

1013− | -- | consumer declares the string value must matrix a regex ($1), producer doesn't declare or declares different regex (TODO: #32)

1024+ | -- | consumer declares the string value must match a regex ($1), producer doesn't declare or declares different regex (TODO: #32)

1014 NoMatchingPattern Pattern

1025 NoMatchingPattern Pattern

1015 | -- | consumer declares the items of an array must satisfy some condition, producer doesn't

1026 | -- | consumer declares the items of an array must satisfy some condition, producer doesn't

1016 NoMatchingItems

1027 NoMatchingItems

@@ -1040,44 +1051,44 @@ instance Issuable 'TypedSchemaLevel where

1040 NoMatchingMinProperties Integer

1051 NoMatchingMinProperties Integer

1041 | -- | consumer declares a minimum number of properties in the object ($1), producer declares a weaker (lower) limit ($2)

1052 | -- | consumer declares a minimum number of properties in the object ($1), producer declares a weaker (lower) limit ($2)

1042 MatchingMinPropertiesWeak (ProdCons Integer)

1053 MatchingMinPropertiesWeak (ProdCons Integer)

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

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)

1044 NoMatchingCondition [SomeCondition]

1055 NoMatchingCondition [SomeCondition]

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

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)

1046 NoContradiction

1057 NoContradiction

1047 deriving stock (Eq, Ord, Show)

1058 deriving stock (Eq, Ord, Show)

1048 issueIsUnsupported _ = False

1059 issueIsUnsupported _ = False

1049− describeIssue (EnumDoesntSatisfy v) = para "The following enum value will yield an error:" <> showJSONValue v

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

1050− describeIssue (NoMatchingEnum v) = para "The following enum value is not supported:" <> showJSONValue v

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

1051− describeIssue (NoMatchingMaximum b) = para $ "Unexpected upper bound " <> showBound b <> "."

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

1052− describeIssue (MatchingMaximumWeak (ProdCons p c)) = para $ "Expected upper bound " <> showBound p <> " but but found " <> showBound c <> "."

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

1053− describeIssue (NoMatchingMinimum b) = para $ "Unexpected lower bound " <> showBound b <> "."

1064+ describeIssue (NoMatchingMinimum b) = para $ "Lower bound has been added: " <> showBound b <> "."

1054− describeIssue (MatchingMinimumWeak (ProdCons p c)) = para $ "Expected lower bound " <> showBound p <> " but but found " <> showBound c <> "."

1065+ describeIssue (MatchingMinimumWeak (ProdCons p c)) = para $ "Lower bound changed from " <> showBound p <> " to " <> showBound c <> "."

1055− describeIssue (NoMatchingMultipleOf n) = para $ "Didn't expect the value to be a multiple of " <> show' n <> " but it was."

1066+ describeIssue (NoMatchingMultipleOf n) = para $ "Value is now a multiple of " <> show' n <> "."

1056− describeIssue (MatchingMultipleOfWeak (ProdCons p c)) = para $ "Expected the value to be a multiple of " <> show' p <> " but found a multiple of " <> show' c <> "."

1067+ describeIssue (MatchingMultipleOfWeak (ProdCons p c)) = para $ "Value changed from being a multiple of " <> show' p <> " to being a multiple of " <> show' c <> "."

1057− describeIssue (NoMatchingFormat f) = para $ "Unexpected format: " <> code f <> "."

1068+ describeIssue (NoMatchingFormat f) = para $ "Format added: " <> code f <> "."

1058− describeIssue (NoMatchingMaxLength n) = para $ "Unexpected maximum length of the string " <> show' n <> "."

1069+ describeIssue (NoMatchingMaxLength n) = para $ "Maximum length added: " <> show' n <> "."

1059− describeIssue (MatchingMaxLengthWeak (ProdCons p c)) = para $ "Expected the maximum length of the string to be " <> show' p <> "but it was " <> show' c <> "."

1070+ describeIssue (MatchingMaxLengthWeak (ProdCons p c)) = para $ "Maximum length of the string changed from " <> show' p <> " to " <> show' c <> "."

1060− describeIssue (NoMatchingMinLength n) = para $ "Unexpected minimum length of the string " <> show' n <> "."

1071+ describeIssue (NoMatchingMinLength n) = para $ "Minimum length of the string added: " <> show' n <> "."

1061− describeIssue (MatchingMinLengthWeak (ProdCons p c)) = para $ "Expected the minimum length of the string to be " <> show' p <> "but it was " <> show' c <> "."

1072+ describeIssue (MatchingMinLengthWeak (ProdCons p c)) = para $ "Minimum length of the string changed from " <> show' p <> " to " <> show' c <> "."

1062− describeIssue (NoMatchingPattern p) = para "Unexpected pattern (regular expression): " <> codeBlock p

1073+ describeIssue (NoMatchingPattern p) = para "Pattern (regular expression) added: " <> codeBlock p

1063− describeIssue NoMatchingItems = para "Couldn't find any matching items."

1074+ describeIssue NoMatchingItems = para "Array item schema has been added."

1064− describeIssue (NoMatchingMaxItems n) = para $ "Unexpected maximum length of the array " <> show' n <> "."

1075+ describeIssue (NoMatchingMaxItems n) = para $ "Maximum length of the array has been added " <> show' n <> "."

1065− describeIssue (MatchingMaxItemsWeak (ProdCons p c)) = para $ "Expected the maximum length of the array to be " <> show' p <> "but it was " <> show' c <> "."

1076+ describeIssue (MatchingMaxItemsWeak (ProdCons p c)) = para $ "Maximum length of the array changed from " <> show' p <> " to " <> show' c <> "."

1066− describeIssue (NoMatchingMinItems n) = para $ "Unexpected minimum length of the array " <> show' n <> "."

1077+ describeIssue (NoMatchingMinItems n) = para $ "Minimum length of the array added: " <> show' n <> "."

1067− describeIssue (MatchingMinItemsWeak (ProdCons p c)) = para $ "Expected the minimum length of the array to be " <> show' p <> "but it was " <> show' c <> "."

1078+ describeIssue (MatchingMinItemsWeak (ProdCons p c)) = para $ "Minimum length of the array changed from " <> show' p <> " to " <> show' c <> "."

1068− describeIssue NoMatchingUniqueItems = para "Didn't expect the items to be unique, but they were."

1079+ describeIssue NoMatchingUniqueItems = para "Items are now required to be unique."

1069− describeIssue NoMatchingProperties = para "Couldn't find matching properties."

1080+ describeIssue NoMatchingProperties = para "Property added."

1070− describeIssue (UnexpectedProperty p) = para $ "Expected the property " <> code p <> " to be allowed, but it wasn't."

1081+ describeIssue (UnexpectedProperty p) = para $ "Property " <> code p <> " has been removed."

1071− describeIssue (PropertyNowRequired p) = para $ "Don't have a required property " <> code p <> "."

1082+ describeIssue (PropertyNowRequired p) = para $ "Property " <> code p <> " has become required."

1072− describeIssue NoAdditionalProperties = para "Expected additional properties to be allowed, but they weren't."

1083+ describeIssue NoAdditionalProperties = para "Additional properties have been removed."

1073− describeIssue (NoMatchingMaxProperties n) = para $ "Unexpected maximum number of properties " <> show' n <> "."

1084+ describeIssue (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been added: " <> show' n <> "."

1074− describeIssue (MatchingMaxPropertiesWeak (ProdCons p c)) = para $ "Expected the maximum number of properties to be " <> show' p <> "but it was " <> show' c <> "."

1085+ describeIssue (MatchingMaxPropertiesWeak (ProdCons p c)) = para $ "Maximum number of properties has changed from " <> show' p <> " to " <> show' c <> "."

1075− describeIssue (NoMatchingMinProperties n) = para $ "Unexpected minimum number of properties " <> show' n <> "."

1086+ describeIssue (NoMatchingMinProperties n) = para $ "Minimum number of properties added: " <> show' n <> "."

1076− describeIssue (MatchingMinPropertiesWeak (ProdCons p c)) = para $ "Expected the minimum number of properties to be " <> show' p <> "but it was " <> show' c <> "."

1087+ describeIssue (MatchingMinPropertiesWeak (ProdCons p c)) = para $ "Minimum number of properties has changed from " <> show' p <> " to " <> show' c <> "."

1077 describeIssue (NoMatchingCondition conds) =

1088 describeIssue (NoMatchingCondition conds) =

1078− para "Expected the following conditions to hold, but they didn't:"

1089+ para "Expected the following conditions to hold, but they didn't (please file a bug if you see this):"

1079 <> bulletList ((\(SomeCondition c) -> showCondition c) <$> conds)

1090 <> bulletList ((\(SomeCondition c) -> showCondition c) <$> conds)

1080− describeIssue NoContradiction = para "Expected the type to be allowed, but it wasn't."

1091+ describeIssue NoContradiction = para "The type has been removed."

1081

1092

1082showJSONValue :: A.Value -> Blocks

1093showJSONValue :: A.Value -> Blocks

1083showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)

1094showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)

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

@@ -135,12 +135,12 @@ instance Issuable 'ServerLevel where

135 deriving stock (Eq, Ord, Show)

136 issueIsUnsupported _ = False

137 describeIssue (EnumValueNotConsumed _ v) =

138− para $ "Enum value " <> code v <> " is not supported."

138+ para $ "Enum value " <> code v <> " has been removed."

139 describeIssue (ConsumerNotOpen _) =

140− para $ "Expected a variable to be open (any value), but it wasn't."

140+ para $ "A variable has been changed from being open to being closed."

141 describeIssue (ServerVariableNotDefined k) =

142 para $ "Variable " <> code k <> " is not defined."

143− describeIssue ServerNotMatched = para $ "Couldn't find a matching server."

143+ describeIssue ServerNotMatched = para $ "The server was removed."

144

145instance Subtree ProcessedServer where

146 type SubtreeLevel ProcessedServer = 'ServerLevel

stack.yaml+1−1

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

1−resolver: nightly-2021-06-01

1+resolver: nightly-2021-06-10

2

3extra-deps:

4 - open-union-0.4.0.0

stack.yaml.lock+4−4

@@ -20,7 +20,7 @@ packages:

20 hackage: type-fun-0.1.3

21snapshots:

22- completed:

23− size: 587963

23+ size: 585361

24− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/6/1.yaml

24+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/6/10.yaml

25− sha256: 6f13285c82266d1d06f7f68366a5190dcbc6758ae8806813005cf56daa6bb9be

25+ sha256: ef53458d54ca6084c6d8eb5219d03b38878e999af607cf006d5be86669d9a696

26− original: nightly-2021-06-01

26+ original: nightly-2021-06-10

test/Spec/Golden/TraceTree.hs+2−1

@@ -21,6 +21,7 @@ import OpenAPI.Checker.Validate.OpenApi ()

21import Spec.Golden.Extra

22import Test.Tasty (TestTree, testGroup)

23import Text.Pandoc.Class

24+import Text.Pandoc.Options

24import Text.Pandoc.Writers

25import Text.Pandoc.Writers

25import Prelude hiding (id, (.))

26import Prelude hiding (id, (.))

26

27

@@ -42,7 +43,7 @@ tests = do

42 "report.md"

43 "report.md"

43 ("a.yaml", "b.yaml")

44 ("a.yaml", "b.yaml")

44 Yaml.decodeFileThrow

45 Yaml.decodeFileThrow

45− (runPandoc . writeMarkdown def . generateReport . runChecker)

46+ (runPandoc . writeMarkdown def {writerExtensions = githubMarkdownExtensions} . generateReport . runChecker)

46

47

47 return $ testGroup "Golden tests" [traceTreeTests, reportTests]

48 return $ testGroup "Golden tests" [traceTreeTests, reportTests]

48

49

test/golden/common/maximum-lowered/report.md+12−4

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

1−# **POST** /test

1+# Summary

2

3−## JSON Request

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

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

5+| 1 | 0 |

4

6

5−### `$(Number)`

7+# ⚠️ Breaking changes

6

8

9+## **POST** /test

10+

11+### JSON Request

12+

13+#### `$(Number)`

14+

7−Expected upper bound 3.0 inclusive but but found 2.0 inclusive.

15+Upper bound changed from 3.0 inclusive to 2.0 inclusive.

test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/report.md+10−2

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

1−# **POST** /test

1+# Summary

2

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

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

5+| 1 | 0 |

6+

7+# ⚠️ Breaking changes

8+

9+## **POST** /test

10+

3−## Parameter test1

11+### Parameter test1

4

12

5Expected that an empty parameter is allowed, but it isn't.

13Expected that an empty parameter is allowed, but it isn't.

test/golden/common/pathItem/operation/parameters/change/report.md+13−5

@@ -1,9 +1,17 @@

1−# **POST** /test

1+# Summary

2

3−## Parameter test

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

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

5+| 1 | 0 |

4

6

5−### JSON Schema

7+# ⚠️ Breaking changes

6

8

7−#### `$(String)`

9+## **POST** /test

8

10

9−Expected the type to be allowed, but it wasn't.

11+### Parameter test

12+

13+#### JSON Schema

14+

15+##### `$(String)`

16+

17+The type has been removed.

test/golden/common/pathItem/operation/parameters/required/set/report.md+11−3

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

1−# **POST** /test

1+# Summary

2

3−## Parameter test1

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

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

5+| 1 | 0 |

4

6

5−Expected the parameter to be optional, but it is required.

7+# ⚠️ Breaking changes

8+

9+## **POST** /test

10+

11+### Parameter test1

12+

13+Parameter has become required.

test/golden/common/pathItem/operation/parameters/required/true/add/report.md+10−2

@@ -1,3 +1,11 @@

1−# **POST** /test

1+# Summary

2

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

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

5+| 1 | 0 |

6+

7+# ⚠️ Breaking changes

8+

9+## **POST** /test

10+

3−Parameter test2 is not supported.

11+Parameter `test2` has become required.

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md+12−4

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

1−# **POST** /test

1+# Summary

2

3−## JSON Request

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

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

5+| 1 | 0 |

4

6

5−### `$(String)`

7+# ⚠️ Breaking changes

6

8

7−Expected the type to be allowed, but it wasn't.

9+## **POST** /test

10+

11+### JSON Request

12+

13+#### `$(String)`

14+

15+The type has been removed.

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/report.md+11−4

@@ -1,6 +1,13 @@

1−# **POST** /test

1+# Summary

2

3−## Request

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

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

5+| 1 | 0 |

4

6

5−Couldn't find a request body for media type

7+# ⚠️ Breaking changes

8+

9+## **POST** /test

10+

11+### Request

12+

6−`application/x-www-form-urlencoded`.

13+Media type `application/x-www-form-urlencoded` has been removed.

test/golden/common/pathItem/operation/requestBody/required/set/report.md+11−3

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

1−# **POST** /test

1+# Summary

2

3−## Request

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

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

5+| 1 | 0 |

4

6

5−Expected the request body to be optional, but found it to be required.

7+# ⚠️ Breaking changes

8+

9+## **POST** /test

10+

11+### Request

12+

13+Request body has become required.

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

@@ -1,3 +1,11 @@

1−# **POST** /test

1+# Summary

2

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

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

5+| 1 | 0 |

6+

7+# ⚠️ Breaking changes

8+

9+## **POST** /test

10+

3−Reponse code 500 is not supported.

11+Reponse code 500 has been added.

test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/report.md+11−3

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

1−# **POST** /test

1+# Summary

2

3−## Response code 200

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

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

5+| 1 | 0 |

4

6

7+# ⚠️ Breaking changes

8+

9+## **POST** /test

10+

11+### Response code 200

12+

5−Couldn't find header `Test2`.

13+New header was added `Test2`.

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

@@ -1,6 +1,13 @@

1−# **POST** /test

1+# Summary

2

3−## Response code 200

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

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

5+| 1 | 0 |

4

6

5−Couldn't find reponse for media type

7+# ⚠️ Breaking changes

8+

9+## **POST** /test

10+

11+### Response code 200

12+

6−`application/x-www-form-urlencoded`.

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

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md+12−4

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

1−# **POST** /test

1+# Summary

2

3−## JSON Response – 200

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

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

5+| 1 | 0 |

4

6

5−### `$(Number)`

7+# ⚠️ Breaking changes

6

8

7−Expected the type to be allowed, but it wasn't.

9+## **POST** /test

10+

11+### JSON Response – 200

12+

13+#### `$(Number)`

14+

15+The type has been removed.

test/golden/common/property-removed/report.md+15−7

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

1−# **POST** /test

1+# Summary

2

3−## JSON Request

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

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

5+| 2 | 0 |

4

6

5−### `$(Object)`

7+# ⚠️ Breaking changes

6

8

7−Expected the property `property2` to be allowed, but it wasn't.

9+## **POST** /test

8

10

9−## JSON Response – 200

11+### JSON Request

10

12

11−### `$(Object)`

13+#### `$(Object)`

12

14

13−Don't have a required property `property2`.

15+Property `property2` has been removed.

16+

17+### JSON Response – 200

18+

19+#### `$(Object)`

20+

21+Property `property2` has become required.

test/golden/common/property-required/report.md+12−4

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

1−# **POST** /test

1+# Summary

2

3−## JSON Request

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

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

5+| 1 | 0 |

4

6

5−### `$(Object)`

7+# ⚠️ Breaking changes

6

8

7−Don't have a required property `property2`.

9+## **POST** /test

10+

11+### JSON Request

12+

13+#### `$(Object)`

14+

15+Property `property2` has become required.

test/golden/common/security-scheme/report.md+16−8

@@ -1,15 +1,23 @@

1−# **POST** /oauth/check

1+# Summary

2

3−## Security requirement 0

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

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

5+| 2 | 0 |

4

6

5−### oauth

7+# ⚠️ Breaking changes

6

8

7−Security scheme not met.

9+## **POST** /oauth/check

8

10

9−# **GET** /oauth/sign\_out

11+### Security requirement 0

10

12

11−## Security requirement 1

13+#### oauth

12

14

13−### oauth

15+Security scheme has been removed.

14

16

17+## **GET** /oauth/sign\_out

18+

19+### Security requirement 1

20+

21+#### oauth

22+

15−Security scheme not met.

23+Security scheme has been removed.

test/golden/common/servers/report.md+14−6

@@ -1,11 +1,19 @@

1−# **GET** /pets

1+# Summary

2

3−## Server `http://missing.url`

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

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

5+| 3 | 0 |

4

6

5−Couldn't find a matching server.

7+# ⚠️ Breaking changes

6

8

7−## Server `http://{x}variable.path/{y}/{openVariable1}/{openVariable2}`

9+## **GET** /pets

8

10

9−Enum value `a` is not supported.

11+### Server `http://missing.url`

10

12

11−Expected a variable to be open (any value), but it wasn't.

13+The server was removed.

14+

15+### Server `http://{x}variable.path/{y}/{openVariable1}/{openVariable2}`

16+

17+Enum value `a` has been removed.

18+

19+A variable has been changed from being open to being closed.

test/golden/common/unguarded-recursive/report.md+10−2

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

1−# **GET** /api/foo

1+# Summary

2

3+| ⚠️ Breaking changes | [🤷 Unsupported feature changes](#unsupported-changes) |

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

5+| 0 | 1 |

6+

7+# 🤷 Unsupported feature changes

8+

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

10+

3−## JSON Response – 200

11+### JSON Response – 200

4

12

5Encountered recursion that is too complex for OpenApi Diff to untangle.

13Encountered recursion that is too complex for OpenApi Diff to untangle.