218336b · compaREST · git.iko.soy

app/FormatHeuristic.hsnew file+69

compare with master

unifiedsplit

@@ -0,0 +1,69 @@

1+-- |

2+-- Originally based on:

3+-- https://github.com/jgm/pandoc/blob/master/src/Text/Pandoc/App/FormatHeuristics.hs

4+module FormatHeuristic

5+ ( formatFromFilePath

6+ )

7+where

8+

9+import Data.Char (toLower)

10+import System.FilePath (takeExtension)

11+import Text.Pandoc

12+

13+formatFromFilePath :: PandocMonad m => FilePath -> Maybe (Writer m)

14+formatFromFilePath x =

15+ case takeExtension (map toLower x) of

16+ ".adoc" -> f "asciidoc"

17+ ".asciidoc" -> f "asciidoc"

18+ ".context" -> f "context"

19+ ".ctx" -> f "context"

20+ ".db" -> f "docbook"

21+ ".doc" -> f "doc" -- so we get an "unknown reader" error

22+ ".docx" -> f "docx"

23+ ".dokuwiki" -> f "dokuwiki"

24+ ".epub" -> f "epub"

25+ ".fb2" -> f "fb2"

26+ ".htm" -> f "html"

27+ ".html" -> f "html"

28+ ".icml" -> f "icml"

29+ ".json" -> f "json"

30+ ".latex" -> f "latex"

31+ ".lhs" -> f "markdown+lhs"

32+ ".ltx" -> f "latex"

33+ ".markdown" -> f "markdown"

34+ ".mkdn" -> f "markdown"

35+ ".mkd" -> f "markdown"

36+ ".mdwn" -> f "markdown"

37+ ".mdown" -> f "markdown"

38+ ".Rmd" -> f "markdown"

39+ ".md" -> f "markdown"

40+ ".ms" -> f "ms"

41+ ".muse" -> f "muse"

42+ ".native" -> f "native"

43+ ".odt" -> f "odt"

44+ ".opml" -> f "opml"

45+ ".org" -> f "org"

46+ ".pdf" -> f "pdf" -- so we get an "unknown reader" error

47+ ".pptx" -> f "pptx"

48+ ".roff" -> f "ms"

49+ ".rst" -> f "rst"

50+ ".rtf" -> f "rtf"

51+ ".s5" -> f "s5"

52+ ".t2t" -> f "t2t"

53+ ".tei" -> f "tei"

54+ ".tei.xml" -> f "tei"

55+ ".tex" -> f "latex"

56+ ".texi" -> f "texinfo"

57+ ".texinfo" -> f "texinfo"

58+ ".text" -> f "markdown"

59+ ".textile" -> f "textile"

60+ ".txt" -> f "markdown"

61+ ".wiki" -> f "mediawiki"

62+ ".xhtml" -> f "html"

63+ ".ipynb" -> f "ipynb"

64+ ".csv" -> f "csv"

65+ ".bib" -> f "biblatex"

66+ ['.', y] | y `elem` ['1' .. '9'] -> f "man"

67+ _ -> Nothing

68+ where

69+ f k = lookup k writers

app/Main.hs+59−3

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

1module Main (main) where

2

3+import Control.Monad

4+import Control.Monad.Except

5+import Data.Aeson

6+import qualified Data.ByteString.Lazy as BSL

7+import Data.Default

8+import Data.HList

9+import qualified Data.Text.IO as T

10+import qualified Data.Yaml as Yaml

11+import FormatHeuristic

3−import OpenAPI.Checker.Run (runChecker)

12+import OpenAPI.Checker.Behavior

4−

13+import OpenAPI.Checker.Options

14+import OpenAPI.Checker.Paths

15+import OpenAPI.Checker.PathsPrefixTree

16+import OpenAPI.Checker.Report

17+import OpenAPI.Checker.Subtree

18+import System.Exit

19+import System.IO

20+import Text.Pandoc

5

21

6main :: IO ()

22main :: IO ()

7−main = runChecker

23+main = do

24+ opts <- execParser optionsParserInfo

25+ let parseSchema path =

26+ eitherDecodeFileStrict path >>= \case

27+ Left jsonErr -> do

28+ Yaml.decodeFileEither path >>= \case

29+ Left yamlErr -> do

30+ putStrLn "Could not parse as json or yaml"

31+ print jsonErr

32+ print yamlErr

33+ fail "Exiting"

34+ Right s -> pure s

35+ Right s -> pure s

36+ a <- traced (step ClientSchema) <$> parseSchema (clientFile opts)

37+ b <- traced (step ServerSchema) <$> parseSchema (serverFile opts)

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+ output :: Either (PathsPrefixTree Behave AnIssue 'APILevel) () -> ExceptT Errors IO ()

42+ output = case outputMode opts of

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

44+ FileMode f -> case formatFromFilePath f of

45+ Nothing -> \_ -> throwError UnknownOutputFormat

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

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

48+ either handler pure <=< runExceptT $ output result

49+ case result of

50+ Right () -> exitSuccess

51+ Left _ -> exitWith $ ExitFailure 1

52+

53+data Errors

54+ = DocumentError PandocError

55+ | UnknownOutputFormat

56+

57+handler :: Errors -> IO a

58+handler (DocumentError err) = do

59+ T.hPutStrLn stderr (renderError err)

60+ exitWith $ ExitFailure 100

61+handler UnknownOutputFormat = do

62+ T.hPutStrLn stderr "Could not determine output format from file extension."

63+ exitWith $ ExitFailure 101

openapi-diff.cabal+13−2

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

63 , vector

64 , yaml

65 , hashable

66+ , pandoc-types

66

67

67 default-extensions: ApplicativeDo

68 default-extensions: ApplicativeDo

68 , BangPatterns

69 , BangPatterns

@@ -117,7 +118,6 @@ library

117 , OpenAPI.Checker.Paths

118 , OpenAPI.Checker.Paths

118 , OpenAPI.Checker.PathsPrefixTree

119 , OpenAPI.Checker.PathsPrefixTree

119 , OpenAPI.Checker.References

120 , OpenAPI.Checker.References

120− , OpenAPI.Checker.Run

121 , OpenAPI.Checker.Subtree

122 , OpenAPI.Checker.Validate.MediaTypeObject

123 , OpenAPI.Checker.Validate.OpenApi

@@ -136,15 +136,24 @@ library

136 , OpenAPI.Checker.Common

137 , OpenAPI.Checker.Validate.SecurityScheme

138 , OpenAPI.Checker.Validate.OAuth2Flows

139+ , OpenAPI.Checker.Report

139

140

140executable openapi-diff

141executable openapi-diff

141 import: common-options

142 import: common-options

142 hs-source-dirs: app

143 hs-source-dirs: app

143 main-is: Main.hs

144 main-is: Main.hs

144− build-depends: openapi-diff

145+ build-depends:

146+ openapi-diff

147+ , pandoc

148+ , data-default

149+ , bytestring

150+ , yaml

151+ , filepath

145 ghc-options: -threaded

152 ghc-options: -threaded

146 -rtsopts

153 -rtsopts

147 -with-rtsopts=-N

154 -with-rtsopts=-N

155+ other-modules:

156+ FormatHeuristic

148

157

149test-suite openapi-diff-test

158test-suite openapi-diff-test

150 import: common-options

159 import: common-options

@@ -163,6 +172,8 @@ test-suite openapi-diff-test

163 , yaml

172 , yaml

164 , directory

173 , directory

165 , filepath

174 , filepath

175+ , pandoc

176+ , data-default

166 ghc-options: -threaded

177 ghc-options: -threaded

167 -rtsopts

178 -rtsopts

168 -with-rtsopts=-N

179 -with-rtsopts=-N

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

@@ -9,9 +9,9 @@ where

9

10import Data.Aeson

11import Data.Kind

12−import Data.Text as T

13import Data.Typeable

12import Data.Typeable

14import OpenAPI.Checker.Paths

13import OpenAPI.Checker.Paths

14+import Text.Pandoc.Builder

15

16-- | Kind

17data BehaviorLevel

@@ -37,18 +37,20 @@ class

37 Behavable (a :: BehaviorLevel) (b :: BehaviorLevel)

38 where

39 data Behave a b

40+ describeBehaviour :: Behave a b -> Inlines

41+

42+type instance AdditionalQuiverConstraints Behave a b = Behavable a b

40

43

41class (Typeable l, Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where

44class (Typeable l, Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where

42 data Issue l :: Type

45 data Issue l :: Type

43− describeIssue :: Issue l -> Text

46+ describeIssue :: Issue l -> Blocks

44− describeIssue = T.pack . show -- TODO: remove this default

45 issueIsUnsupported :: Issue l -> Bool

47 issueIsUnsupported :: Issue l -> Bool

46

48

47-- | A set of interactions having common unifying features

49-- | A set of interactions having common unifying features

48type Behavior = Paths Behave 'APILevel

50type Behavior = Paths Behave 'APILevel

49

51

50instance Issuable l => ToJSON (Issue l) where

52instance Issuable l => ToJSON (Issue l) where

51− toJSON = toJSON . describeIssue

53+ toJSON = toJSON . show

52

54

53data AnIssue (l :: BehaviorLevel) where

55data AnIssue (l :: BehaviorLevel) where

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

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

src/OpenAPI/Checker/Paths.hs+5−1

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

3-- structure.

4module OpenAPI.Checker.Paths

5 ( NiceQuiver

6+ , AdditionalQuiverConstraints

6 , Paths (..)

7 , Paths (..)

7 , DiffPaths (..)

8 , DiffPaths (..)

8 , catDiffPaths

9 , catDiffPaths

@@ -24,7 +25,10 @@ import Data.Type.Equality

24import Type.Reflection

25import Type.Reflection

25import Prelude hiding ((.))

26import Prelude hiding ((.))

26

27

28+type NiceQuiver (q :: k -> j -> Type) (a :: k) (b :: j) =

27−type NiceQuiver (q :: k -> j -> Type) (a :: k) (b :: j) = (Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q a b))

29+ (Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q a b), AdditionalQuiverConstraints q a b)

30+

31+type family AdditionalQuiverConstraints (q :: k -> j -> Type) (a :: k) (b :: j) :: Constraint

28

32

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

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

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

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

src/OpenAPI/Checker/PathsPrefixTree.hs+20−4

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

1{-# LANGUAGE QuantifiedConstraints #-}

2

3module OpenAPI.Checker.PathsPrefixTree

4− ( PathsPrefixTree

4+ ( PathsPrefixTree (PathsPrefixNode)

5+ , AStep (..)

5 , empty

6 , empty

6 , singleton

7 , singleton

7 , fromList

8 , fromList

@@ -24,6 +25,7 @@ import qualified Data.Text as T

24import Data.Type.Equality

25import Data.Type.Equality

25import qualified Data.TypeRepMap as TRM

26import qualified Data.TypeRepMap as TRM

26import qualified Data.Vector as V

27import qualified Data.Vector as V

28+import qualified GHC.Exts as Exts

27import qualified GHC.Exts as TRM

29import qualified GHC.Exts as TRM

28import OpenAPI.Checker.Paths

30import OpenAPI.Checker.Paths

29import Type.Reflection

31import Type.Reflection

@@ -35,6 +37,15 @@ data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPref

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

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

36 }

38 }

37

39

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

41+pattern PathsPrefixNode s steps <-

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

43+ where

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

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

46+

47+{-# COMPLETE PathsPrefixNode #-}

48+

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

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

39 toJSON =

50 toJSON =

40 Object . getMergableObject

51 Object . getMergableObject

@@ -78,6 +89,10 @@ data ASet (a :: Type) where

78 AnEmptySet :: ASet a

89 AnEmptySet :: ASet a

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

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

80

91

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

93+toSet AnEmptySet = S.empty

94+toSet (ASet s) = s

95+

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

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

82 toJSON =

97 toJSON =

83 toJSON . \case

98 toJSON . \case

@@ -123,6 +138,7 @@ instance Semigroup (PathsPrefixTree q f r) where

123 PathsPrefixTree r1 s1 <> PathsPrefixTree r2 s2 =

138 PathsPrefixTree r1 s1 <> PathsPrefixTree r2 s2 =

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

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

125 where

140 where

141+ joinSteps :: AStep q f r a -> AStep q f r a -> AStep q f r a

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

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

127

143

128instance Monoid (PathsPrefixTree q f r) where

144instance Monoid (PathsPrefixTree q f r) where

@@ -135,7 +151,7 @@ fromList :: [AnItem q f r] -> PathsPrefixTree q f r

135fromList = foldMap singleton

151fromList = foldMap singleton

136

152

137null :: PathsPrefixTree q f r -> Bool

153null :: PathsPrefixTree q f r -> Bool

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

154+null (PathsPrefixTree AnEmptySet s) = all (\(TRM.WrapTypeable (AStep x)) -> all null x) (Exts.toList s)

139null _ = False

155null _ = False

140

156

141foldWith

157foldWith

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

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

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

162

178

163-- | Select a subtree by prefix

179-- | Select a subtree by prefix

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

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

165filter Root t = t

181filter Root t = t

166filter (Snoc xs x) t =

182filter (Snoc xs x) t =

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

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

168− TRM.lookup $ snocItems $ filter xs t

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

169

185

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

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

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

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

src/OpenAPI/Checker/Report.hsnew file+136

@@ -0,0 +1,136 @@

1+module OpenAPI.Checker.Report

2+ ( generateReport

3+ )

4+where

5+

6+import Control.Monad.Reader

7+import Control.Monad.Writer

8+import Data.Foldable

9+import Data.Functor

10+import qualified Data.Map as M

11+import Data.Maybe

12+import qualified Data.Text as T

13+import Data.Traversable

14+import Data.TypeRepMap hiding (empty)

15+import Data.Typeable

16+import OpenAPI.Checker.Behavior

17+import OpenAPI.Checker.Paths

18+import OpenAPI.Checker.PathsPrefixTree hiding (empty)

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

20+import OpenAPI.Checker.Validate.OpenApi

21+import Text.Pandoc.Builder

22+

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

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

25+generateReport (Left errs) = doc $ runReportMonad jets $ showErrs errs

26+

27+data ReportState = ReportState

28+ { sourceJets :: [SomeReportJet Behave]

29+ , headerLevel :: Int

30+ }

31+

32+type ReportMonad = ReaderT ReportState (Writer Blocks)

33+

34+runReportMonad :: [SomeReportJet Behave] -> ReportMonad () -> Blocks

35+runReportMonad jts =

36+ execWriter

37+ . flip

38+ runReaderT

39+ ReportState

40+ { sourceJets = jts

41+ , headerLevel = 1

42+ }

43+

44+smartHeader :: Inlines -> ReportMonad ()

45+smartHeader i = do

46+ h <- asks headerLevel

47+ tell $ header h i

48+

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

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

51+ jts <- asks sourceJets

52+ for_ currentIssues $ \(AnIssue i) -> tell . describeIssue $ i

53+ unfoldM x (observeSomeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do

54+ for_ subIssues $ \(WrapTypeable (AStep m)) ->

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

56+ unless (P.null subErrors) $ do

57+ smartHeader $ describeBehaviour bhv

58+ incrementHeaders $ showErrs subErrors

59+

60+unfoldM :: Monad m => a -> [a -> m a] -> (a -> m ()) -> m ()

61+unfoldM a [] g = g a

62+unfoldM a (f : ff) g = do

63+ a' <- f a

64+ unfoldM a' ff g

65+

66+observeSomeJetShowErrs

67+ :: forall a.

68+ Typeable a

69+ => SomeReportJet Behave

70+ -> P.PathsPrefixTree Behave AnIssue a

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

72+observeSomeJetShowErrs (SomeReportJet (Proxy :: Proxy a') f) x

73+ | Just Refl <- eqT @a @a' = observeJetShowErrs f x

74+observeSomeJetShowErrs _ x = pure x

75+

76+observeJetShowErrs :: ReportJet Behave a -> P.PathsPrefixTree Behave AnIssue a -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)

77+observeJetShowErrs jet (P.PathsPrefixNode currentIssues subIssues) = do

78+ rest <- fmap (fold . join) $

79+ for subIssues $ \(WrapTypeable (AStep m)) -> fmap catMaybes $

80+ for (M.toList m) $ \(bhv, subErrs) ->

81+ case applyReportJet jet bhv of

82+ Just (Left h) -> do

83+ smartHeader h

84+ incrementHeaders $ showErrs subErrs

85+ return Nothing

86+ Just (Right jet') -> do

87+ rest <- observeJetShowErrs jet' subErrs

88+ return $ Just $ embed (step bhv) rest

89+ Nothing -> return $ Just $ embed (step bhv) subErrs

90+ return $ PathsPrefixNode currentIssues mempty <> rest

91+

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

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

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

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

96+--

97+-- The tem "jet" in this context was introduced in the Urbit project:

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

99+--

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

101+class ConstructReportJet f a b c where

102+ constructReportJet :: (f a b -> c) -> ReportJet f a

103+

104+instance (ConstructReportJet f b c d, Typeable b) => ConstructReportJet f a b (f b c -> d) where

105+ constructReportJet f = ReportJet Proxy $ \x -> constructReportJet $ f x

106+

107+instance Typeable b => ConstructReportJet f a b Inlines where

108+ constructReportJet f = TerminalJet Proxy f

109+

110+constructSomeReportJet :: (ConstructReportJet f a b c, Typeable a) => (f a b -> c) -> SomeReportJet f

111+constructSomeReportJet = SomeReportJet Proxy . constructReportJet

112+

113+data ReportJet f a where

114+ ReportJet :: Typeable b => Proxy b -> (f a b -> ReportJet f b) -> ReportJet f a

115+ TerminalJet :: Typeable b => Proxy b -> (f a b -> Inlines) -> ReportJet f a

116+

117+data SomeReportJet f where

118+ SomeReportJet :: Typeable a => Proxy a -> ReportJet f a -> SomeReportJet f

119+

120+applyReportJet :: forall f a b. Typeable b => ReportJet f a -> f a b -> Maybe (Either Inlines (ReportJet f b))

121+applyReportJet (TerminalJet (Proxy :: Proxy b') f) x = eqT @b @b' <&> \Refl -> Left $ f x

122+applyReportJet (ReportJet (Proxy :: Proxy b') f) x = eqT @b @b' <&> \Refl -> Right $ f x

123+

124+incrementHeaders :: ReportMonad x -> ReportMonad x

125+incrementHeaders m = do

126+ l <- asks headerLevel

127+ local (\x -> x {headerLevel = l + 1}) m

128+

129+jets :: [SomeReportJet Behave]

130+jets =

131+ [ constructSomeReportJet $ \p@(AtPath _) op@(InOperation _) ->

132+ strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines

133+ , constructSomeReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines

134+ , constructSomeReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->

135+ "JSON Response – " <> str (T.pack . show $ c) :: Inlines

136+ ]

src/OpenAPI/Checker/Run.hsdeleted−40

@@ -1,40 +0,0 @@

1−module OpenAPI.Checker.Run (runChecker) where

2−

3−import Data.Aeson

4−import qualified Data.ByteString.Char8 as BSC

5−import Data.HList

6−import qualified Data.Yaml as Yaml

7−import OpenAPI.Checker.Options

8−import OpenAPI.Checker.Paths

9−import OpenAPI.Checker.Subtree

10−import OpenAPI.Checker.Validate.OpenApi ()

11−import System.Exit

12−import Prelude hiding (id, (.))

13−

14−runChecker :: IO ()

15−runChecker = do

16− opts <- execParser optionsParserInfo

17− let parseSchema path =

18− eitherDecodeFileStrict path >>= \case

19− Left jsonErr -> do

20− Yaml.decodeFileEither path >>= \case

21− Left yamlErr -> do

22− putStrLn "Could not parse as json or yaml"

23− print jsonErr

24− print yamlErr

25− fail "Exiting"

26− Right s -> pure s

27− Right s -> pure s

28− a <- traced (step ClientSchema) <$> parseSchema (clientFile opts)

29− b <- traced (step ServerSchema) <$> parseSchema (serverFile opts)

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

31− output = case outputMode opts of

32− StdoutMode -> BSC.putStrLn

33− FileMode f -> BSC.writeFile f

34− case report of

35− Right () -> do

36− output "No breaking changes found"

37− exitSuccess

38− Left e -> do

39− output $ Yaml.encode e

40− exitFailure

src/OpenAPI/Checker/Subtree.hs+13−6

@@ -64,7 +64,7 @@ import OpenAPI.Checker.Paths

64import qualified OpenAPI.Checker.PathsPrefixTree as P

65

66class

67− NiceQuiver Step a b =>

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

68 Steppable (a :: Type) (b :: Type)

69 where

70 -- | How to get from an @a@ node to a @b@ node

@@ -80,6 +80,8 @@ instance Steppable TraceRoot OpenApi where

80

81type Trace = Paths Step TraceRoot

82

83+type instance AdditionalQuiverConstraints Step a b = ()

84+

83type Traced' a b = Env (Trace a) b

85type Traced' a b = Env (Trace a) b

84

86

85type Traced a = Traced' a a

87type Traced a = Traced' a a

@@ -128,10 +130,12 @@ type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel

128

130

129type StructuralCompatFormula = CompatFormula' VoidQuiver Proxy ()

131type StructuralCompatFormula = CompatFormula' VoidQuiver Proxy ()

130

132

131−data VoidQuiver a b where

133+data VoidQuiver a b

132

134

133deriving stock instance Eq (VoidQuiver a b)

135deriving stock instance Eq (VoidQuiver a b)

134

136

137+type instance AdditionalQuiverConstraints VoidQuiver a b = ()

138+

135deriving stock instance Ord (VoidQuiver a b)

139deriving stock instance Ord (VoidQuiver a b)

136

140

137deriving stock instance Show (VoidQuiver a b)

141deriving stock instance Show (VoidQuiver a b)

@@ -297,10 +301,13 @@ memo

297 -> (ProdCons (Traced a) -> CompatFormula' q f r ())

301 -> (ProdCons (Traced a) -> CompatFormula' q f r ())

298 -> (ProdCons (Traced a) -> CompatFormula' q f r ())

302 -> (ProdCons (Traced a) -> CompatFormula' q f r ())

299memo bhv k f pc = Compose $ do

303memo bhv k f pc = Compose $ do

304+ formula' <-

300− formula' <- memoWithKnot fixpointKnot (do

305+ memoWithKnot

306+ fixpointKnot

307+ (do

301− formula <- getCompose $ f pc

308+ formula <- getCompose $ f pc

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

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

303− ) (k, ask <$> pc)

310+ (k, ask <$> pc)

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

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

305

312

306data MemoKey = SemanticMemoKey | StructuralMemoKey

313data MemoKey = SemanticMemoKey | StructuralMemoKey

src/OpenAPI/Checker/Validate/Header.hs+5

@@ -13,6 +13,7 @@ import OpenAPI.Checker.Behavior

13import OpenAPI.Checker.References ()

14import OpenAPI.Checker.Subtree

15import OpenAPI.Checker.Validate.Schema ()

16+import Text.Pandoc.Builder

16

17

17instance Subtree Header where

18instance Subtree Header where

18 type SubtreeLevel Header = 'HeaderLevel

19 type SubtreeLevel Header = 'HeaderLevel

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

50 | HeaderSchemaRequired

51 | HeaderSchemaRequired

51 deriving stock (Eq, Ord, Show)

52 deriving stock (Eq, Ord, Show)

52 issueIsUnsupported _ = False

53 issueIsUnsupported _ = False

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

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

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

53

57

54instance Behavable 'HeaderLevel 'SchemaLevel where

58instance Behavable 'HeaderLevel 'SchemaLevel where

55 data Behave 'HeaderLevel 'SchemaLevel

59 data Behave 'HeaderLevel 'SchemaLevel

56 = InSchema

60 = InSchema

57 deriving stock (Eq, Ord, Show)

61 deriving stock (Eq, Ord, Show)

62+ describeBehaviour InSchema = "JSON Schema"

src/OpenAPI/Checker/Validate/Link.hs+2

@@ -5,6 +5,7 @@ module OpenAPI.Checker.Validate.Link () where

5import Data.OpenApi

6import OpenAPI.Checker.Behavior

7import OpenAPI.Checker.Subtree

8+import Text.Pandoc.Builder

8

9

9instance Subtree Link where

10instance Subtree Link where

10 type SubtreeLevel Link = 'LinkLevel

11 type SubtreeLevel Link = 'LinkLevel

@@ -18,3 +19,4 @@ instance Issuable 'LinkLevel where

18 deriving (Eq, Ord, Show)

19 deriving (Eq, Ord, Show)

19 issueIsUnsupported = \case

20 issueIsUnsupported = \case

20 LinksUnsupported -> True

21 LinksUnsupported -> True

22+ describeIssue LinksUnsupported = para "OpenApi Diff does not currently support Link Objects."

src/OpenAPI/Checker/Validate/MediaTypeObject.hs+19−6

@@ -6,19 +6,22 @@ module OpenAPI.Checker.Validate.MediaTypeObject

6 )

7where

8

9−import Control.Lens

9+import Control.Lens hiding (para)

10import Data.Foldable as F

11import Data.HList

12import Data.HashMap.Strict.InsOrd as IOHM

13import Data.Map.Strict as M

14import Data.OpenApi

15+import Data.String

15import Data.Text (Text)

16import Data.Text (Text)

17+import qualified Data.Text as T

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

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

17import OpenAPI.Checker.Behavior

19import OpenAPI.Checker.Behavior

18import OpenAPI.Checker.Subtree

20import OpenAPI.Checker.Subtree

19import OpenAPI.Checker.Validate.Header ()

21import OpenAPI.Checker.Validate.Header ()

20import OpenAPI.Checker.Validate.Products

22import OpenAPI.Checker.Validate.Products

21import OpenAPI.Checker.Validate.Schema ()

23import OpenAPI.Checker.Validate.Schema ()

24+import Text.Pandoc.Builder

22

25

23tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))

26tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))

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

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

@@ -31,9 +34,7 @@ tracedEncoding mto =

31

34

32instance Issuable 'PayloadLevel where

35instance Issuable 'PayloadLevel where

33 data Issue 'PayloadLevel

36 data Issue 'PayloadLevel

34− = PayloadMediaTypeNotFound

35− | MediaEncodingIncompat

36− | MediaTypeSchemaRequired

37+ = MediaTypeSchemaRequired

37 | MediaEncodingMissing Text

38 | MediaEncodingMissing Text

38 | EncodingNotSupported

39 | EncodingNotSupported

39 deriving (Eq, Ord, Show)

40 deriving (Eq, Ord, Show)

@@ -41,10 +42,15 @@ instance Issuable 'PayloadLevel where

41 EncodingNotSupported -> True

42 EncodingNotSupported -> True

42 _ -> False

43 _ -> False

43

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

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

48+

44instance Behavable 'PayloadLevel 'SchemaLevel where

49instance Behavable 'PayloadLevel 'SchemaLevel where

45 data Behave 'PayloadLevel 'SchemaLevel

50 data Behave 'PayloadLevel 'SchemaLevel

46 = PayloadSchema

51 = PayloadSchema

47 deriving (Eq, Ord, Show)

52 deriving (Eq, Ord, Show)

53+ describeBehaviour PayloadSchema = "JSON Schema"

48

54

49instance Subtree MediaTypeObject where

55instance Subtree MediaTypeObject where

50 type SubtreeLevel MediaTypeObject = 'PayloadLevel

56 type SubtreeLevel MediaTypeObject = 'PayloadLevel

@@ -136,15 +142,22 @@ instance Behavable 'OperationLevel 'ResponseLevel where

136 data Behave 'OperationLevel 'ResponseLevel

142 data Behave 'OperationLevel 'ResponseLevel

137 = WithStatusCode HttpStatusCode

143 = WithStatusCode HttpStatusCode

138 deriving stock (Eq, Ord, Show)

144 deriving stock (Eq, Ord, Show)

145+ describeBehaviour (WithStatusCode c) = "Response code " <> (fromString . show $ c)

139

146

140instance Issuable 'OperationLevel where

147instance Issuable 'OperationLevel where

141 data Issue 'OperationLevel

148 data Issue 'OperationLevel

142 = ResponseCodeNotFound HttpStatusCode

149 = ResponseCodeNotFound HttpStatusCode

143− | CallbacksNotSupported

144 | ParamNotMatched Text

150 | ParamNotMatched Text

145 | PathFragmentNotMatched Int

151 | PathFragmentNotMatched Int

146 | NoRequestBody

152 | NoRequestBody

147 deriving stock (Eq, Ord, Show)

153 deriving stock (Eq, Ord, Show)

148 issueIsUnsupported = \case

154 issueIsUnsupported = \case

149− CallbacksNotSupported -> True

150 _ -> False

155 _ -> False

156+ describeIssue (ResponseCodeNotFound c) =

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

158+ describeIssue (ParamNotMatched param) =

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

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

src/OpenAPI/Checker/Validate/OAuth2Flows.hs+25

@@ -9,6 +9,7 @@ where

9

10import Control.Monad

11import Data.Function

12+import Data.Functor

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

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

13import Data.OpenApi

14import Data.OpenApi

14import Data.Proxy

15import Data.Proxy

@@ -18,6 +19,7 @@ import Data.Text (Text)

18import OpenAPI.Checker.Behavior

19import OpenAPI.Checker.Behavior

19import OpenAPI.Checker.Orphans ()

20import OpenAPI.Checker.Orphans ()

20import OpenAPI.Checker.Subtree

21import OpenAPI.Checker.Subtree

22+import Text.Pandoc.Builder

21

23

22instance Subtree OAuth2Flows where

24instance Subtree OAuth2Flows where

23 type CheckEnv OAuth2Flows = '[]

25 type CheckEnv OAuth2Flows = '[]

@@ -102,6 +104,8 @@ instance Issuable 'SecurityRequirementLevel where

102 | UndefinedSecurityScheme Text

104 | UndefinedSecurityScheme Text

103 deriving stock (Eq, Ord, Show)

105 deriving stock (Eq, Ord, Show)

104 issueIsUnsupported _ = False

106 issueIsUnsupported _ = False

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

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

105

109

106instance Issuable 'SecuritySchemeLevel where

110instance Issuable 'SecuritySchemeLevel where

107 data Issue 'SecuritySchemeLevel

111 data Issue 'SecuritySchemeLevel

@@ -125,8 +129,29 @@ instance Issuable 'SecuritySchemeLevel where

125 | ScopeNotDefined Text

129 | ScopeNotDefined Text

126 deriving stock (Eq, Ord, Show)

130 deriving stock (Eq, Ord, Show)

127 issueIsUnsupported _ = False

131 issueIsUnsupported _ = False

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

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

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

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

136+ describeIssue (CustomHttpSchemesDontMatch e a) =

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

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

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

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

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

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

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

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

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

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

147+ describeIssue (ScopesMissing ss) =

148+ para "Scopes missing:" <> 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."

128

152

129instance Behavable 'SecurityRequirementLevel 'SecuritySchemeLevel where

153instance Behavable 'SecurityRequirementLevel 'SecuritySchemeLevel where

130 data Behave 'SecurityRequirementLevel 'SecuritySchemeLevel

154 data Behave 'SecurityRequirementLevel 'SecuritySchemeLevel

131 = SecuritySchemeStep Text

155 = SecuritySchemeStep Text

132 deriving stock (Eq, Ord, Show)

156 deriving stock (Eq, Ord, Show)

157+ describeBehaviour (SecuritySchemeStep s) = text s

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

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

3{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}

4

5module OpenAPI.Checker.Validate.OpenApi

6− (

6+ ( Behave (..)

7 )

8where

9

src/OpenAPI/Checker/Validate/Operation.hs+39−8

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

13 , ProcessedPathItems (..)

14 , processPathItems

15 , Step (..)

16+ , Behave (..)

16 )

17 )

17where

18where

18

19

@@ -27,6 +28,7 @@ import qualified Data.List as L

27import Data.Map.Strict as M

28import Data.Map.Strict as M

28import Data.Maybe

29import Data.Maybe

29import Data.OpenApi

30import Data.OpenApi

31+import Data.String

30import Data.Text (Text)

32import Data.Text (Text)

31import qualified Data.Text as T

33import qualified Data.Text as T

32import OpenAPI.Checker.Behavior

34import OpenAPI.Checker.Behavior

@@ -36,11 +38,12 @@ import OpenAPI.Checker.Validate.MediaTypeObject

36import OpenAPI.Checker.Validate.OAuth2Flows

38import OpenAPI.Checker.Validate.OAuth2Flows

37import OpenAPI.Checker.Validate.PathFragment

39import OpenAPI.Checker.Validate.PathFragment

38import OpenAPI.Checker.Validate.Products

40import OpenAPI.Checker.Validate.Products

39−import OpenAPI.Checker.Validate.RequestBody ()

41+import OpenAPI.Checker.Validate.RequestBody

40−import OpenAPI.Checker.Validate.Responses ()

42+import OpenAPI.Checker.Validate.Responses

41import OpenAPI.Checker.Validate.SecurityRequirement ()

43import OpenAPI.Checker.Validate.SecurityRequirement ()

42import OpenAPI.Checker.Validate.Server ()

44import OpenAPI.Checker.Validate.Server ()

43import OpenAPI.Checker.Validate.Sums

45import OpenAPI.Checker.Validate.Sums

46+import Text.Pandoc.Builder

44

47

45data MatchedOperation = MatchedOperation

48data MatchedOperation = MatchedOperation

46 { operation :: !Operation

49 { operation :: !Operation

@@ -95,18 +98,24 @@ getServers env oper =

95instance Behavable 'OperationLevel 'PathFragmentLevel where

98instance Behavable 'OperationLevel 'PathFragmentLevel where

96 data Behave 'OperationLevel 'PathFragmentLevel

99 data Behave 'OperationLevel 'PathFragmentLevel

97 = InParam Text

100 = InParam Text

98− | InFragment Int

101+ | InFragment (PathFragment Text)

99 deriving stock (Eq, Ord, Show)

102 deriving stock (Eq, Ord, Show)

103+ describeBehaviour (InParam p) = "Parameter " <> text p

104+ describeBehaviour (InFragment (StaticPath p)) = "Static fragment " <> code p

105+ describeBehaviour (InFragment (DynamicPath p)) = "Dynamic fragment " <> code p

100

106

101instance Behavable 'OperationLevel 'RequestLevel where

107instance Behavable 'OperationLevel 'RequestLevel where

102 data Behave 'OperationLevel 'RequestLevel

108 data Behave 'OperationLevel 'RequestLevel

103 = InRequest

109 = InRequest

104 deriving stock (Eq, Ord, Show)

110 deriving stock (Eq, Ord, Show)

111+ describeBehaviour InRequest = "Request"

105

112

106instance Behavable 'OperationLevel 'SecurityRequirementLevel where

113instance Behavable 'OperationLevel 'SecurityRequirementLevel where

107 data Behave 'OperationLevel 'SecurityRequirementLevel

114 data Behave 'OperationLevel 'SecurityRequirementLevel

108 = SecurityRequirementStep Int

115 = SecurityRequirementStep Int

109 deriving stock (Eq, Ord, Show)

116 deriving stock (Eq, Ord, Show)

117+ describeBehaviour (SecurityRequirementStep i) =

118+ "Security requirement " <> (text . T.pack . show $ i)

110

119

111instance Subtree MatchedOperation where

120instance Subtree MatchedOperation where

112 type SubtreeLevel MatchedOperation = 'OperationLevel

121 type SubtreeLevel MatchedOperation = 'OperationLevel

@@ -202,7 +211,8 @@ instance Subtree MatchedOperation where

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

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

203 getFragments params mop = getPathFragments (extract mop) params

212 getFragments params mop = getPathFragments (extract mop) params

204 -- Feed path parameters to the fragments getter

213 -- Feed path parameters to the fragments getter

214+ check _ frags@(ProdCons (Traced _ p) _) =

205− check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags

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

206 elements =

216 elements =

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

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

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

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

@@ -348,12 +358,16 @@ instance Issuable 'APILevel where

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

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

349 deriving stock (Eq, Ord, Show)

359 deriving stock (Eq, Ord, Show)

350 issueIsUnsupported _ = False

360 issueIsUnsupported _ = False

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

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

351

363

352instance Behavable 'APILevel 'PathLevel where

364instance Behavable 'APILevel 'PathLevel where

353 data Behave 'APILevel 'PathLevel

365 data Behave 'APILevel 'PathLevel

354− = AtPath (ProdCons FilePath) -- TODO: why are there two?

366+ = AtPath FilePath

355 deriving stock (Eq, Ord, Show)

367 deriving stock (Eq, Ord, Show)

356

368

369+ describeBehaviour (AtPath p) = str (T.pack p)

370+

357instance Subtree ProcessedPathItems where

371instance Subtree ProcessedPathItems where

358 type SubtreeLevel ProcessedPathItems = 'APILevel

372 type SubtreeLevel ProcessedPathItems = 'APILevel

359 type

373 type

@@ -376,15 +390,16 @@ instance Subtree ProcessedPathItems where

376 -- one way

390 -- one way

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

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

378 let prodPath = path prodItem

392 let prodPath = path prodItem

393+ beh' = beh >>> step (AtPath prodPath)

379 matchedItems = do

394 matchedItems = do

380 consItem <- unProcessedPathItems . extract $ c

395 consItem <- unProcessedPathItems . extract $ c

381 F.toList $ matchingPathItems $ ProdCons prodItem consItem

396 F.toList $ matchingPathItems $ ProdCons prodItem consItem

382 case matchedItems of

397 case matchedItems of

383 [] -> issueAt beh $ NoPathsMatched prodPath

398 [] -> issueAt beh $ NoPathsMatched prodPath

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

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

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

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

386 match <- matches

401 match <- matches

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

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

388 where

403 where

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

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

390

405

@@ -429,7 +444,6 @@ tracedMatchedPathItemParameters mpi =

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

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

430 ]

445 ]

431

446

432−-- TODO: simplify?

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

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

434tracedFragments mpi =

448tracedFragments mpi =

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

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

@@ -447,12 +461,26 @@ instance Issuable 'PathLevel where

447 = OperationMissing OperationMethod

461 = OperationMissing OperationMethod

448 deriving stock (Eq, Ord, Show)

462 deriving stock (Eq, Ord, Show)

449 issueIsUnsupported _ = False

463 issueIsUnsupported _ = False

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

450

465

451instance Behavable 'PathLevel 'OperationLevel where

466instance Behavable 'PathLevel 'OperationLevel where

452 data Behave 'PathLevel 'OperationLevel

467 data Behave 'PathLevel 'OperationLevel

453 = InOperation OperationMethod

468 = InOperation OperationMethod

454 deriving (Eq, Ord, Show)

469 deriving (Eq, Ord, Show)

455

470

471+ describeBehaviour (InOperation method) = showMethod method

472+

473+showMethod :: IsString s => OperationMethod -> s

474+showMethod = \case

475+ GetMethod -> "GET"

476+ PutMethod -> "PUT"

477+ PostMethod -> "POST"

478+ DeleteMethod -> "DELETE"

479+ OptionsMethod -> "OPTIONS"

480+ HeadMethod -> "HEAD"

481+ PatchMethod -> "PATCH"

482+ TraceMethod -> "TRACE"

483+

456instance Subtree MatchedPathItem where

484instance Subtree MatchedPathItem where

457 type SubtreeLevel MatchedPathItem = 'PathLevel

485 type SubtreeLevel MatchedPathItem = 'PathLevel

458 type

486 type

@@ -550,6 +578,7 @@ instance Issuable 'CallbackLevel where

550 deriving (Eq, Ord, Show)

578 deriving (Eq, Ord, Show)

551 issueIsUnsupported = \case

579 issueIsUnsupported = \case

552 CallbacksUnsupported -> True

580 CallbacksUnsupported -> True

581+ describeIssue CallbacksUnsupported = para "OpenApi Diff does not currently support callbacks."

553

582

554tracedCallbackPathItems :: Traced Callback -> Traced ProcessedPathItems

583tracedCallbackPathItems :: Traced Callback -> Traced ProcessedPathItems

555tracedCallbackPathItems (Traced t (Callback x)) =

584tracedCallbackPathItems (Traced t (Callback x)) =

@@ -562,3 +591,5 @@ instance Steppable Callback ProcessedPathItems where

562instance Behavable 'OperationLevel 'CallbackLevel where

591instance Behavable 'OperationLevel 'CallbackLevel where

563 data Behave 'OperationLevel 'CallbackLevel = OperationCallback Text

592 data Behave 'OperationLevel 'CallbackLevel = OperationCallback Text

564 deriving stock (Eq, Ord, Show)

593 deriving stock (Eq, Ord, Show)

594+

595+ describeBehaviour (OperationCallback key) = "Operation " <> code key

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

@@ -6,7 +6,7 @@ module OpenAPI.Checker.Validate.Param

6 , Issue (..)

7 ) where

8

9−import Control.Lens

9+import Control.Lens hiding (para)

10import Control.Monad

11import Data.Maybe

12import Data.OpenApi

@@ -15,6 +15,7 @@ import OpenAPI.Checker.Behavior

15import OpenAPI.Checker.Orphans ()

16import OpenAPI.Checker.Subtree

17import OpenAPI.Checker.Validate.Schema ()

18+import Text.Pandoc.Builder

18

19

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

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

20-- styles are equal then parameters are compatible with their encoding style

21-- styles are equal then parameters are compatible with their encoding style

@@ -62,11 +63,20 @@ instance Issuable 'PathFragmentLevel where

62 | PathFragmentsDontMatch Text Text

63 | PathFragmentsDontMatch Text Text

63 deriving (Eq, Ord, Show)

64 deriving (Eq, Ord, Show)

64 issueIsUnsupported _ = False

65 issueIsUnsupported _ = False

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

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

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

69+ describeIssue ParamPlaceIncompatible = para "Parameters in incompatible locations."

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

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

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

65

73

66instance Behavable 'PathFragmentLevel 'SchemaLevel where

74instance Behavable 'PathFragmentLevel 'SchemaLevel where

67 data Behave 'PathFragmentLevel 'SchemaLevel

75 data Behave 'PathFragmentLevel 'SchemaLevel

68 = InParamSchema

76 = InParamSchema

69 deriving (Eq, Ord, Show)

77 deriving (Eq, Ord, Show)

78+

79+ describeBehaviour InParamSchema = "JSON Schema"

70

80

71instance Subtree Param where

81instance Subtree Param where

72 type SubtreeLevel Param = 'PathFragmentLevel

82 type SubtreeLevel Param = 'PathFragmentLevel

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

@@ -32,7 +32,7 @@ parsePath = fmap partition . T.splitOn "/" . T.pack

32data PathFragment param

33 = StaticPath Text

34 | DynamicPath param

35− deriving stock (Eq, Ord)

35+ deriving stock (Eq, Ord, Show, Functor)

36

37type PathFragmentParam = PathFragment (Traced Param)

38

src/OpenAPI/Checker/Validate/RequestBody.hs+8

@@ -2,6 +2,7 @@

2

3module OpenAPI.Checker.Validate.RequestBody

4 ( Issue (..)

5+ , Behave (..)

5 )

6 )

6where

7where

7

8

@@ -10,11 +11,13 @@ import Data.HashMap.Strict.InsOrd as IOHM

10import Data.Map.Strict as M

11import Data.Map.Strict as M

11import Data.Maybe

12import Data.Maybe

12import Data.OpenApi

13import Data.OpenApi

14+import qualified Data.Text as T

13import Network.HTTP.Media (MediaType)

15import Network.HTTP.Media (MediaType)

14import OpenAPI.Checker.Behavior

16import OpenAPI.Checker.Behavior

15import OpenAPI.Checker.Subtree

17import OpenAPI.Checker.Subtree

16import OpenAPI.Checker.Validate.MediaTypeObject

18import OpenAPI.Checker.Validate.MediaTypeObject

17import OpenAPI.Checker.Validate.Sums

19import OpenAPI.Checker.Validate.Sums

20+import Text.Pandoc.Builder

18

21

19-- TODO: Use RequestMediaTypeObjectMapping

22-- TODO: Use RequestMediaTypeObjectMapping

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

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

@@ -28,11 +31,16 @@ instance Issuable 'RequestLevel where

28 | RequestMediaTypeNotFound MediaType

31 | RequestMediaTypeNotFound MediaType

29 deriving stock (Eq, Ord, Show)

32 deriving stock (Eq, Ord, Show)

30 issueIsUnsupported _ = False

33 issueIsUnsupported _ = False

34+ describeIssue RequestBodyRequired =

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

36+ describeIssue (RequestMediaTypeNotFound t) =

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

31

38

32instance Behavable 'RequestLevel 'PayloadLevel where

39instance Behavable 'RequestLevel 'PayloadLevel where

33 data Behave 'RequestLevel 'PayloadLevel

40 data Behave 'RequestLevel 'PayloadLevel

34 = InPayload

41 = InPayload

35 deriving stock (Eq, Ord, Show)

42 deriving stock (Eq, Ord, Show)

43+ describeBehaviour InPayload = "Payload"

36

44

37instance Subtree RequestBody where

45instance Subtree RequestBody where

38 type SubtreeLevel RequestBody = 'RequestLevel

46 type SubtreeLevel RequestBody = 'RequestLevel

src/OpenAPI/Checker/Validate/Responses.hs+11−1

@@ -2,7 +2,7 @@

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

3

4module OpenAPI.Checker.Validate.Responses

5− (

5+ ( Behave (..)

6 )

7where

8

@@ -11,6 +11,7 @@ import Data.HashMap.Strict.InsOrd as IOHM

11import Data.Map.Strict as M

12import Data.Maybe

13import Data.OpenApi

14+import qualified Data.Text as T

14import Network.HTTP.Media (MediaType)

15import Network.HTTP.Media (MediaType)

15import OpenAPI.Checker.Behavior

16import OpenAPI.Checker.Behavior

16import OpenAPI.Checker.References

17import OpenAPI.Checker.References

@@ -21,6 +22,7 @@ import OpenAPI.Checker.Validate.MediaTypeObject

21import OpenAPI.Checker.Validate.Products

22import OpenAPI.Checker.Validate.Products

22import OpenAPI.Checker.Validate.Schema ()

23import OpenAPI.Checker.Validate.Schema ()

23import OpenAPI.Checker.Validate.Sums

24import OpenAPI.Checker.Validate.Sums

25+import Text.Pandoc.Builder

24

26

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

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

26tracedResponses resp =

28tracedResponses resp =

@@ -70,17 +72,25 @@ instance Issuable 'ResponseLevel where

70 | ResponseHeaderMissing HeaderName

72 | ResponseHeaderMissing HeaderName

71 deriving stock (Eq, Ord, Show)

73 deriving stock (Eq, Ord, Show)

72 issueIsUnsupported _ = False

74 issueIsUnsupported _ = False

75+ describeIssue (ResponseMediaTypeMissing t) =

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

77+ describeIssue (ResponseHeaderMissing h) =

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

73

79

74instance Behavable 'ResponseLevel 'PayloadLevel where

80instance Behavable 'ResponseLevel 'PayloadLevel where

75 data Behave 'ResponseLevel 'PayloadLevel

81 data Behave 'ResponseLevel 'PayloadLevel

76 = ResponsePayload

82 = ResponsePayload

77 deriving stock (Eq, Ord, Show)

83 deriving stock (Eq, Ord, Show)

78

84

85+ describeBehaviour ResponsePayload = "Payload"

86+

79instance Behavable 'ResponseLevel 'HeaderLevel where

87instance Behavable 'ResponseLevel 'HeaderLevel where

80 data Behave 'ResponseLevel 'HeaderLevel

88 data Behave 'ResponseLevel 'HeaderLevel

81 = InHeader HeaderName

89 = InHeader HeaderName

82 deriving stock (Eq, Ord, Show)

90 deriving stock (Eq, Ord, Show)

83

91

92+ describeBehaviour (InHeader name) = "Header " <> code name

93+

84instance Subtree Response where

94instance Subtree Response where

85 type SubtreeLevel Response = 'ResponseLevel

95 type SubtreeLevel Response = 'ResponseLevel

86 type

96 type

src/OpenAPI/Checker/Validate/Schema.hs+212−107

@@ -17,12 +17,13 @@ import Algebra.Lattice

17import Control.Applicative

18import Control.Arrow

19import Control.Comonad.Env hiding (env)

20−import Control.Lens hiding (cons)

20+import Control.Lens hiding (cons, para)

21import Control.Monad.Reader hiding (ask)

22import qualified Control.Monad.Reader as R

23import Control.Monad.State

24import Control.Monad.Writer

25import qualified Data.Aeson as A

26+import qualified Data.ByteString.Lazy as BSL

26import Data.Coerce

27import Data.Coerce

27import qualified Data.Foldable as F

28import qualified Data.Foldable as F

28import Data.HList

29import Data.HList

@@ -40,8 +41,8 @@ import Data.Scientific

40import qualified Data.Set as S

41import qualified Data.Set as S

41import Data.Text (Text)

42import Data.Text (Text)

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

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

44+import qualified Data.Text.Encoding as T

43import Data.Typeable

45import Data.Typeable

44−import Text.Regex.Pcre2

45import OpenAPI.Checker.Behavior

46import OpenAPI.Checker.Behavior

46import OpenAPI.Checker.Memo

47import OpenAPI.Checker.Memo

47import OpenAPI.Checker.Orphans ()

48import OpenAPI.Checker.Orphans ()

@@ -49,6 +50,8 @@ import OpenAPI.Checker.Paths

49import qualified OpenAPI.Checker.PathsPrefixTree as P

50import qualified OpenAPI.Checker.PathsPrefixTree as P

50import OpenAPI.Checker.References

51import OpenAPI.Checker.References

51import OpenAPI.Checker.Subtree

52import OpenAPI.Checker.Subtree

53+import Text.Pandoc.Builder hiding (Format, Null)

54+import Text.Regex.Pcre2

52

55

53-- | Type of a JSON value

56-- | Type of a JSON value

54data JsonType

57data JsonType

@@ -84,7 +87,7 @@ untypeValue (TArray a) = A.Array a

84untypeValue (TObject o) = A.Object o

87untypeValue (TObject o) = A.Object o

85

88

86data Bound a = Exclusive !a | Inclusive !a

89data Bound a = Exclusive !a | Inclusive !a

87− deriving (Eq, Show)

90+ deriving (Eq, Show, Functor)

88

91

89-- | The order is lexicographical on @a * Bool@.

92-- | The order is lexicographical on @a * Bool@.

90instance Ord a => Ord (Bound a) where

93instance Ord a => Ord (Bound a) where

@@ -128,6 +131,45 @@ data Condition :: JsonType -> Type where

128 MaxProperties :: !Integer -> Condition 'Object

131 MaxProperties :: !Integer -> Condition 'Object

129 MinProperties :: !Integer -> Condition 'Object

132 MinProperties :: !Integer -> Condition 'Object

130

133

134+showCondition :: Condition a -> Blocks

135+showCondition = \case

136+ (Exactly v) -> para "The value should be:" <> showJSONValue (untypeValue v)

137+ (Maximum b) -> para $ "The value should be less than " <> showBound b <> "."

138+ (Minimum (Down b)) -> para $ "The value should be more than " <> showBound (getDown <$> b) <> "."

139+ (MultipleOf n) -> para $ "The value should be a multiple of " <> show' n <> "."

140+ (NumberFormat p) -> para $ "The number should have the following format:" <> code p <> "."

141+ (Pattern p) -> para "The value should satisfy the following pattern (regular expression):" <> codeBlock p

142+ (StringFormat p) -> para $ "The string should have the following format:" <> code p <> "."

143+ (MaxLength p) -> para $ "The length of the string should be less than or equal to " <> show' p <> "."

144+ (MinLength p) -> para $ "The length of the string should be more than or equal to " <> show' p <> "."

145+ (Items i _) -> para "The items of the array should satisfy:" <> showForEachJsonFormula i

146+ (MaxItems n) -> para $ "The length of the array should be less than or equal to " <> show' n <> "."

147+ (MinItems n) -> para $ "The length of the array should be more than or equal to " <> show' n <> "."

148+ UniqueItems -> para "The elements in the array should be unique."

149+ (Properties props additional _) ->

150+ bulletList $

151+ (M.toList props

152+ <&> (\(k, p) ->

153+ para (code k)

154+ <> para (strong $ if propRequired p then "Required" else "Optional")

155+ <> showForEachJsonFormula (propFormula p)))

156+ <> [ para (emph "Additional properties")

157+ <> showForEachJsonFormula additional

158+ ]

159+ (MaxProperties n) -> para $ "The maximum number of fields should be " <> show' n <> "."

160+ (MinProperties n) -> para $ "The minimum number of fields should be " <> show' n <> "."

161+ where

162+ showForEachJsonFormula :: ForeachType JsonFormula -> Blocks

163+ showForEachJsonFormula i =

164+ bulletList $

165+ foldType

166+ (\t f ->

167+ let (DNF conds') = f i

168+ conds = S.toList <$> S.toList conds'

169+ in [ para (describeJSONType t)

170+ <> bulletList (conds <&> \cond -> bulletList (showCondition <$> cond))

171+ ])

172+

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

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

132satisfiesTyped e (Exactly e') = e == e'

174satisfiesTyped e (Exactly e') = e == e'

133satisfiesTyped (TNumber n) (Maximum (Exclusive m)) = n < m

175satisfiesTyped (TNumber n) (Maximum (Exclusive m)) = n < m

@@ -363,10 +405,6 @@ instance

363 , forObject = top

405 , forObject = top

364 }

406 }

365

407

366−instance Behavable 'SchemaLevel 'SchemaLevel where

367− data Behave 'SchemaLevel 'SchemaLevel

368− deriving (Eq, Ord, Show)

369−

370instance Steppable Schema (Referenced Schema) where

408instance Steppable Schema (Referenced Schema) where

371 data Step Schema (Referenced Schema)

409 data Step Schema (Referenced Schema)

372 = AllOfStep Int

410 = AllOfStep Int

@@ -396,7 +434,7 @@ parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$r

396 A.Error _ -> Ref $ Reference v

434 A.Error _ -> Ref $ Reference v

397

435

398-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.

436-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.

399−newtype Silent q f r a = Silent { runSilent :: a }

437+newtype Silent q f r a = Silent {runSilent :: a}

400 deriving stock (Functor)

438 deriving stock (Functor)

401 deriving (Applicative, Monad) via Identity

439 deriving (Applicative, Monad) via Identity

402

440

@@ -427,11 +465,12 @@ silently m = do

427 pure . runSilent $ runReaderT m defs

465 pure . runSilent $ runReaderT m defs

428

466

429warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m

467warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m

430−warnKnot = KnotTier

468+warnKnot =

469+ KnotTier

431− { onKnotFound = warn UnguardedRecursion

470+ { onKnotFound = warn UnguardedRecursion

432− , onKnotUsed = \_ -> pure bottom

471+ , onKnotUsed = \_ -> pure bottom

433− , tieKnot = \_ -> pure

472+ , tieKnot = \_ -> pure

434− }

473+ }

435

474

436processRefSchema

475processRefSchema

437 :: MonadProcess m

476 :: MonadProcess m

@@ -835,19 +874,19 @@ checkImplication env beh prods cons = case findExactly prods of

835 Just m' ->

874 Just m' ->

836 if m' <= m

875 if m' <= m

837 then pure ()

876 then pure ()

838− else issueAt beh (MatchingMaximumWeak m m')

877+ else issueAt beh (MatchingMaximumWeak $ ProdCons {producer = m', consumer = m})

839 Nothing -> issueAt beh (NoMatchingMaximum m)

878 Nothing -> issueAt beh (NoMatchingMaximum m)

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

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

841 Just m' ->

880 Just m' ->

842 if m' >= m

881 if m' >= m

843 then pure ()

882 then pure ()

844− else issueAt beh (MatchingMinimumWeak (coerce m) (coerce m'))

883+ else issueAt beh (MatchingMinimumWeak ProdCons {producer = coerce m', consumer = coerce m})

845 Nothing -> issueAt beh (NoMatchingMinimum (coerce m))

884 Nothing -> issueAt beh (NoMatchingMinimum (coerce m))

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

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

847 Just m' ->

886 Just m' ->

848 if lcmScientific m m' == m'

887 if lcmScientific m m' == m'

849 then pure ()

888 then pure ()

850− else issueAt beh (MatchingMultipleOfWeak m m')

889+ else issueAt beh (MatchingMultipleOfWeak $ ProdCons {producer = m', consumer = m})

851 Nothing -> issueAt beh (NoMatchingMultipleOf m)

890 Nothing -> issueAt beh (NoMatchingMultipleOf m)

852 NumberFormat f ->

891 NumberFormat f ->

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

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

@@ -857,13 +896,13 @@ checkImplication env beh prods cons = case findExactly prods of

857 Just m' ->

896 Just m' ->

858 if m' <= m

897 if m' <= m

859 then pure ()

898 then pure ()

860− else issueAt beh (MatchingMaxLengthWeak m m')

899+ else issueAt beh (MatchingMaxLengthWeak $ ProdCons {producer = m', consumer = m})

861 Nothing -> issueAt beh (NoMatchingMaxLength m)

900 Nothing -> issueAt beh (NoMatchingMaxLength m)

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

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

863 Just m' ->

902 Just m' ->

864 if m' >= m

903 if m' >= m

865 then pure ()

904 then pure ()

866− else issueAt beh (MatchingMinLengthWeak m m')

905+ else issueAt beh (MatchingMinLengthWeak $ ProdCons {producer = m', consumer = m})

867 Nothing -> issueAt beh (NoMatchingMinLength m)

906 Nothing -> issueAt beh (NoMatchingMinLength m)

868 Pattern p ->

907 Pattern p ->

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

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

@@ -883,50 +922,52 @@ checkImplication env beh prods cons = case findExactly prods of

883 Just m' ->

922 Just m' ->

884 if m' <= m

923 if m' <= m

885 then pure ()

924 then pure ()

886− else issueAt beh (MatchingMaxItemsWeak m m')

925+ else issueAt beh (MatchingMaxItemsWeak ProdCons {producer = m', consumer = m})

887 Nothing -> issueAt beh (NoMatchingMaxItems m)

926 Nothing -> issueAt beh (NoMatchingMaxItems m)

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

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

889 Just m' ->

928 Just m' ->

890 if m' >= m

929 if m' >= m

891 then pure ()

930 then pure ()

892− else issueAt beh (MatchingMinItemsWeak m m')

931+ else issueAt beh (MatchingMinItemsWeak ProdCons {producer = m', consumer = m})

893 Nothing -> issueAt beh (NoMatchingMinItems m)

932 Nothing -> issueAt beh (NoMatchingMinItems m)

894 UniqueItems ->

933 UniqueItems ->

895 if any (== UniqueItems) $ prods

934 if any (== UniqueItems) $ prods

896 then pure ()

935 then pure ()

897 else issueAt beh NoMatchingUniqueItems

936 else issueAt beh NoMatchingUniqueItems

898 Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of

937 Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of

938+ Just pm ->

899− Just pm -> anyOfAt beh NoMatchingProperties $ NE.toList pm <&> \(props', madd') -> do

939+ anyOfAt beh NoMatchingProperties $

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

910− (False, True) -> issueAt beh (PropertyNowRequired k)

951+ (False, True) -> issueAt beh (PropertyNowRequired k)

911− _ -> pure ()

952+ _ -> pure ()

912− pure ()

953+ pure ()

913− case (madd', madd) of

954+ case (madd', madd) of

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

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

915− (_, Nothing) -> issueAt beh NoAdditionalProperties

956+ (_, Nothing) -> issueAt beh NoAdditionalProperties

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

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

917− pure ()

958+ pure ()

918 Nothing -> issueAt beh NoMatchingProperties

959 Nothing -> issueAt beh NoMatchingProperties

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

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

920 Just m' ->

961 Just m' ->

921 if m' <= m

962 if m' <= m

922 then pure ()

963 then pure ()

923− else issueAt beh (MatchingMaxPropertiesWeak m m')

964+ else issueAt beh (MatchingMaxPropertiesWeak ProdCons {producer = m', consumer = m})

924 Nothing -> issueAt beh (NoMatchingMaxProperties m)

965 Nothing -> issueAt beh (NoMatchingMaxProperties m)

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

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

926 Just m' ->

967 Just m' ->

927 if m' >= m

968 if m' >= m

928 then pure ()

969 then pure ()

929− else issueAt beh (MatchingMinPropertiesWeak m m')

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

930 Nothing -> issueAt beh (NoMatchingMinProperties m)

971 Nothing -> issueAt beh (NoMatchingMinProperties m)

931 where

972 where

932 findExactly (Exactly x : _) = Just x

973 findExactly (Exactly x : _) = Just x

@@ -939,85 +980,145 @@ checkImplication env beh prods cons = case findExactly prods of

939

980

940instance Issuable 'TypedSchemaLevel where

981instance Issuable 'TypedSchemaLevel where

941 data Issue 'TypedSchemaLevel

982 data Issue 'TypedSchemaLevel

942− = EnumDoesntSatisfy A.Value

943− -- ^ producer produces a specific value ($1), consumer has a condition that is not satisfied by said value

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

984+ EnumDoesntSatisfy A.Value

985+ | -- | consumer only expects a specific value which the producer does not produce.

944− | NoMatchingEnum A.Value

986+ NoMatchingEnum A.Value

945− -- ^ producer produces a specific value ($1) which is not listed in the consumer's list of specific values

987+ | -- | consumer declares a maximum numeric value ($1), producer doesn't

946− | NoMatchingMaximum (Bound Scientific)

988+ NoMatchingMaximum (Bound Scientific)

947− -- ^ producer declares a maximum numeric value ($1), consumer doesnt

989+ | -- | consumer declares a maximum numeric value ($1), producer declares a weaker (higher) limit ($2)

948− | MatchingMaximumWeak (Bound Scientific) (Bound Scientific)

990+ MatchingMaximumWeak (ProdCons (Bound Scientific))

949− -- ^ producer declares a maximum numeric value ($1), consumer declares a weaker (higher) limit ($2)

991+ | -- | consumer declares a minimum numeric value, producer doesn't

950− | NoMatchingMinimum (Bound Scientific)

992+ NoMatchingMinimum (Bound Scientific)

951− -- ^ producer declares a minimum numeric value, consumer doesnt

993+ | -- | consumer declares a minimum numeric value ($1), producer declares a weaker (lower) limit ($2)

952− | MatchingMinimumWeak (Bound Scientific) (Bound Scientific)

994+ MatchingMinimumWeak (ProdCons (Bound Scientific))

953− -- ^ producer declares a minimum numeric value ($1), consumer declares a weaker (lower) limit ($2)

995+ | -- | consumer declares that the numeric value must be a multiple of $1, producer doesn't

954− | NoMatchingMultipleOf Scientific

996+ NoMatchingMultipleOf Scientific

955− -- ^ producer declares that the numeric value must be a multiple of $1, consumer doesn't

997+ | -- | consumer declares that the numeric value must be a multiple of $1, producer declares a weaker condition (multiple of $2)

956− | MatchingMultipleOfWeak Scientific Scientific

998+ MatchingMultipleOfWeak (ProdCons Scientific)

957− -- ^ producer declares that the numeric value must be a multiple of $1, consumer declares a weaker condition (multiple of $2)

958− | NoMatchingFormat Format

959− -- ^ producer declares a string/number format, consumer declares none or a different format (TODO: improve via regex #32)

999+ | -- | consumer declares a string/number format, producer declares none or a different format (TODO: improve via regex #32)

1000+ NoMatchingFormat Format

1001+ | -- | consumer declares a maximum length of the string ($1), producer doesn't.

960− | NoMatchingMaxLength Integer

1002+ NoMatchingMaxLength Integer

961− -- ^ producer declares a maximum length of the string ($1), consumer doesn't.

1003+ | -- | consumer declares a maximum length of the string ($1), producer declares a weaker (higher) limit ($2)

962− | MatchingMaxLengthWeak Integer Integer

1004+ MatchingMaxLengthWeak (ProdCons Integer)

963− -- ^ producer declares a maximum length of the string ($1), consumer declares a weaker (higher) limit ($2)

1005+ | -- | consumer declares a minimum length of the string ($1), producer doesn't.

964− | NoMatchingMinLength Integer

1006+ NoMatchingMinLength Integer

965− -- ^ producer declares a minimum length of the string ($1), consumer doesn't.

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

966− | MatchingMinLengthWeak Integer Integer

1008+ MatchingMinLengthWeak (ProdCons Integer)

967− -- ^ producer declares a minimum length of the string ($1), consumer declares a weaker (lower) limit ($2)

968− | NoMatchingPattern Pattern

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

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

1010+ NoMatchingPattern Pattern

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

970− | NoMatchingItems

1012+ NoMatchingItems

971− -- ^ producer declares the items of an array must satisfy some condition, consumer doesn't

1013+ | -- | consumer declares a maximum length of the array ($1), producer doesn't.

972− | NoMatchingMaxItems Integer

1014+ NoMatchingMaxItems Integer

973− -- ^ producer declares a maximum length of the array ($1), consumer doesn't.

1015+ | -- | consumer declares a maximum length of the array ($1), producer declares a weaker (higher) limit ($2)

974− | MatchingMaxItemsWeak Integer Integer

1016+ MatchingMaxItemsWeak (ProdCons Integer)

975− -- ^ producer declares a maximum length of the array ($1), consumer declares a weaker (higher) limit ($2)

1017+ | -- | consumer declares a minimum length of the array ($1), producer doesn't.

976− | NoMatchingMinItems Integer

1018+ NoMatchingMinItems Integer

977− -- ^ producer declares a minimum length of the array ($1), consumer doesn't.

1019+ | -- | consumer declares a minimum length of the array ($1), producer declares a weaker (lower) limit ($2)

978− | MatchingMinItemsWeak Integer Integer

1020+ MatchingMinItemsWeak (ProdCons Integer)

979− -- ^ producer declares a minimum length of the array ($1), consumer declares a weaker (lower) limit ($2)

1021+ | -- | consumer declares that items must be unique, producer doesn't

980− | NoMatchingUniqueItems

1022+ NoMatchingUniqueItems

981− -- ^ producer declares that items must be unique, consumer doesn't

1023+ | -- | consumer declares the properties of an object must satisfy some condition, producer doesn't

982− | NoMatchingProperties

1024+ NoMatchingProperties

983− -- ^ producer declares the properties of an object must satisfy some condition, consumer doesn't

1025+ | -- | producer allows a property that is not allowed in the consumer

984− | UnexpectedProperty Text

1026+ UnexpectedProperty Text

985− -- ^ producer allows a property that is not allowed in the consumer

986− | PropertyNowRequired Text

987− -- ^ consumer requires a property that is not required/allowed in the consumer

1027+ | -- | consumer requires a property that is not required/allowed in the producer

988− | NoAdditionalProperties

1028+ PropertyNowRequired Text

989− -- ^ producer allows additional properties, consumer doesn't

1029+ | -- | producer allows additional properties, consumer doesn't

1030+ NoAdditionalProperties

1031+ | -- | consumer declares a maximum number of properties in the object ($1), producer doesn't.

990− | NoMatchingMaxProperties Integer

1032+ NoMatchingMaxProperties Integer

991− -- ^ producer declares a maximum number of properties in the object ($1), consumer doesn't.

1033+ | -- | consumer declares a maximum number of properties in the object ($1), producer declares a weaker (higher) limit ($2)

992− | MatchingMaxPropertiesWeak Integer Integer

1034+ MatchingMaxPropertiesWeak (ProdCons Integer)

993− -- ^ producer declares a maximum number of properties in the object ($1), consumer declares a weaker (higher) limit ($2)

1035+ | -- | consumer declares a minimum number of properties in the object ($1), producer doesn't.

994− | NoMatchingMinProperties Integer

1036+ NoMatchingMinProperties Integer

995− -- ^ producer declares a minimum number of properties in the object ($1), consumer doesn't.

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

996− | MatchingMinPropertiesWeak Integer Integer

1038+ MatchingMinPropertiesWeak (ProdCons Integer)

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

998− | NoMatchingCondition [SomeCondition]

999− -- ^ 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)

1039+ | -- | 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)

1000− | NoContradiction

1040+ NoMatchingCondition [SomeCondition]

1001− -- ^ 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)

1041+ | -- | 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)

1042+ NoContradiction

1002 deriving stock (Eq, Ord, Show)

1043 deriving stock (Eq, Ord, Show)

1003 issueIsUnsupported _ = False

1044 issueIsUnsupported _ = False

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1059+ describeIssue NoMatchingItems = para "Couldn't find any matching items."

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

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

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

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

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

1065+ describeIssue NoMatchingProperties = para "Couldn't find matching properties."

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

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

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

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

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

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

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

1073+ describeIssue (NoMatchingCondition conds) =

1074+ para "Expected the following conditions to hold, but they didn't:"

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

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

1077+

1078+showJSONValue :: A.Value -> Blocks

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

1080+

1081+showBound :: Show a => Bound a -> Inlines

1082+showBound (Inclusive x) = show' x <> " inclusive"

1083+showBound (Exclusive x) = show' x <> " exclusive"

1084+

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

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

1004

1087

1005instance Issuable 'SchemaLevel where

1088instance Issuable 'SchemaLevel where

1006 data Issue 'SchemaLevel

1089 data Issue 'SchemaLevel

1007− = NotSupported Text

1008− -- ^ Some (openapi-supported) feature that we do not support was encountered in the schema

1090+ = -- | Some (openapi-supported) feature that we do not support was encountered in the schema

1009− | InvalidSchema Text

1091+ NotSupported Text

1010− -- ^ The schema is actually invalid

1092+ | -- | The schema is actually invalid

1011− | UnguardedRecursion

1093+ InvalidSchema Text

1012− -- ^ The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".

1094+ | -- | The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".

1095+ UnguardedRecursion

1013 deriving stock (Eq, Ord, Show)

1096 deriving stock (Eq, Ord, Show)

1014 issueIsUnsupported _ = True

1097 issueIsUnsupported _ = True

1015

1098

1099+ describeIssue (NotSupported i) =

1100+ para (emph "Encountered a feature that OpenApi Diff does not support: " <> text i <> ".")

1101+ describeIssue (InvalidSchema i) =

1102+ para (emph "The schema is invalid: " <> text i <> ".")

1103+ describeIssue UnguardedRecursion =

1104+ para "Encountered recursion that is too complex for OpenApi Diff to untangle."

1105+

1016instance Behavable 'SchemaLevel 'TypedSchemaLevel where

1106instance Behavable 'SchemaLevel 'TypedSchemaLevel where

1017 data Behave 'SchemaLevel 'TypedSchemaLevel

1107 data Behave 'SchemaLevel 'TypedSchemaLevel

1018 = OfType JsonType

1108 = OfType JsonType

1019 deriving stock (Eq, Ord, Show)

1109 deriving stock (Eq, Ord, Show)

1020

1110

1111+ describeBehaviour (OfType t) = describeJSONType t

1112+

1113+describeJSONType :: JsonType -> Inlines

1114+describeJSONType = \case

1115+ Null -> "Null"

1116+ Boolean -> "Boolean"

1117+ Number -> "Number"

1118+ String -> "String"

1119+ Array -> "Array"

1120+ Object -> "Object"

1121+

1021instance Behavable 'TypedSchemaLevel 'SchemaLevel where

1122instance Behavable 'TypedSchemaLevel 'SchemaLevel where

1022 data Behave 'TypedSchemaLevel 'SchemaLevel

1123 data Behave 'TypedSchemaLevel 'SchemaLevel

1023 = InItems

1124 = InItems

@@ -1025,6 +1126,10 @@ instance Behavable 'TypedSchemaLevel 'SchemaLevel where

1025 | InAdditionalProperty

1126 | InAdditionalProperty

1026 deriving stock (Eq, Ord, Show)

1127 deriving stock (Eq, Ord, Show)

1027

1128

1129+ describeBehaviour InItems = "Items"

1130+ describeBehaviour (InProperty p) = "Property " <> code p

1131+ describeBehaviour InAdditionalProperty = "Additional properties"

1132+

1028instance Subtree Schema where

1133instance Subtree Schema where

1029 type SubtreeLevel Schema = 'SchemaLevel

1134 type SubtreeLevel Schema = 'SchemaLevel

1030 type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]

1135 type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]

src/OpenAPI/Checker/Validate/Server.hs+10

@@ -28,6 +28,7 @@ import OpenAPI.Checker.Common

28import OpenAPI.Checker.Paths

29import OpenAPI.Checker.Subtree

30import OpenAPI.Checker.Validate.MediaTypeObject

31+import Text.Pandoc.Builder

31import Prelude as P

32import Prelude as P

32

33

33tracedParsedServerUrlParts

34tracedParsedServerUrlParts

@@ -45,6 +46,8 @@ instance Behavable 'OperationLevel 'ServerLevel where

45 = InServer Text

46 = InServer Text

46 deriving stock (Eq, Ord, Show)

47 deriving stock (Eq, Ord, Show)

47

48

49+ describeBehaviour (InServer n) = "Server " <> code n

50+

48instance Subtree [Server] where

51instance Subtree [Server] where

49 type SubtreeLevel [Server] = 'OperationLevel

52 type SubtreeLevel [Server] = 'OperationLevel

50 type CheckEnv [Server] = '[]

53 type CheckEnv [Server] = '[]

@@ -131,6 +134,13 @@ instance Issuable 'ServerLevel where

131 | ServerNotMatched

134 | ServerNotMatched

132 deriving stock (Eq, Ord, Show)

135 deriving stock (Eq, Ord, Show)

133 issueIsUnsupported _ = False

136 issueIsUnsupported _ = False

137+ describeIssue (EnumValueNotConsumed _ v) =

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

139+ describeIssue (ConsumerNotOpen _) =

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

141+ describeIssue (ServerVariableNotDefined k) =

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

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

134

144

135instance Subtree ProcessedServer where

145instance Subtree ProcessedServer where

136 type SubtreeLevel ProcessedServer = 'ServerLevel

146 type SubtreeLevel ProcessedServer = 'ServerLevel

stack.yaml+1−1

@@ -1 +1 @@

1−resolver: lts-17.12

1+resolver: nightly-2021-06-01

stack.yaml.lock+4−4

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

6packages: []

7snapshots:

8- completed:

9− size: 567669

9+ size: 587963

10− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/12.yaml

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

11− sha256: facf6cac73b22a83ca955b580a98a7a09ed71f8f974c7a55d28e608c23e689a9

11+ sha256: 6f13285c82266d1d06f7f68366a5190dcbc6758ae8806813005cf56daa6bb9be

12− original: lts-17.12

12+ original: nightly-2021-06-01

test/Spec.hs+1−5

@@ -9,8 +9,4 @@ main = defaultMain =<< tests

9tests :: IO TestTree

10tests = do

11 goldenReportTree <- Spec.Golden.TraceTree.tests

12− return . localOption (mkTimeout 1000000) $

12+ return . localOption (mkTimeout 1000000) $ goldenReportTree

13− testGroup

14− "Golden tests"

15− [ goldenReportTree

16− ]

test/Spec/Golden/Extra.hs+11−37

@@ -8,15 +8,11 @@ where

8

9import Control.Lens

10import Control.Monad

11−import Data.Aeson hiding (Result)

12import qualified Data.ByteString.Lazy as BSL

11import qualified Data.ByteString.Lazy as BSL

13−import qualified Data.Yaml as Yaml

14−import OpenAPI.Checker.Subtree

15import System.Directory

12import System.Directory

16import System.FilePath

13import System.FilePath

17import Test.Tasty

14import Test.Tasty

18import Test.Tasty.Golden

15import Test.Tasty.Golden

19−import Test.Tasty.Providers

20

16

21data TestInput t

17data TestInput t

22 = TestInputNode TestName [TestInput t]

18 = TestInputNode TestName [TestInput t]

@@ -54,62 +50,40 @@ getGoldenInputsUniform

54getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)

50getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)

55

51

56goldenInputsTree

52goldenInputsTree

57− :: (Each s t (FilePath, FilePath -> IO a) a, ToJSON x, HasUnsupportedFeature x)

53+ :: (Each s t (FilePath, FilePath -> IO a) a)

58 => TestName

54 => TestName

59 -> FilePath -- ^ Root path

55 -> FilePath -- ^ Root path

60 -> FilePath -- ^ Name of golden file

56 -> FilePath -- ^ Name of golden file

61 -> s

57 -> s

62− -> (t -> x)

58+ -> (t -> IO BSL.ByteString)

63 -> IO TestTree

59 -> IO TestTree

64goldenInputsTree name filepath golden inp f = do

60goldenInputsTree name filepath golden inp f = do

65 runTestInputTree golden f <$> getGoldenInputs name filepath inp

61 runTestInputTree golden f <$> getGoldenInputs name filepath inp

66

62

67runTestInputTree

63runTestInputTree

68− :: (ToJSON x, HasUnsupportedFeature x)

69− => FilePath

64+ :: FilePath

70− -> (t -> x)

65+ -> (t -> IO BSL.ByteString)

71 -> TestInput t

66 -> TestInput t

72 -> TestTree

67 -> TestTree

73runTestInputTree golden f (TestInputNode name rest) =

68runTestInputTree golden f (TestInputNode name rest) =

74 testGroup name (runTestInputTree golden f <$> rest)

69 testGroup name (runTestInputTree golden f <$> rest)

75−runTestInputTree golden f (TestInputLeaf name t path)

70+runTestInputTree golden f (TestInputLeaf name t path) =

76− | testSupported name =

77− goldenVsStringDiff

71+ goldenVsStringDiff

78− name

72+ name

79− (\ref new -> ["diff", "-u", ref, new])

73+ (\ref new -> ["diff", "-u", ref, new])

80− (path </> golden)

74+ (path </> golden)

81− (pure . BSL.fromStrict . Yaml.encode . f $ t)

75+ (f t)

82−runTestInputTree _ f (TestInputLeaf name t _) =

83− reportResult name $

84− if hasUnsupportedFeature (f t)

85− then testPassed "Feature unsupported"

86− else testFailed "Unexpected feature support"

87−

88−reportResult :: TestName -> Result -> TestTree

89−reportResult name result = singleTest name $ SimpleTestReporter result

90−

91−newtype SimpleTestReporter = SimpleTestReporter Result

92−

93−instance IsTest SimpleTestReporter where

94− run _ (SimpleTestReporter result) _ = return result

95− testOptions = mempty

96−

97−testSupported :: TestName -> Bool

98−testSupported ('x' : ' ' : _) = False

99−testSupported _ = True

100

76

101goldenInputsTreeUniform

77goldenInputsTreeUniform

102 :: ( Each t h (FilePath, FilePath -> IO a) a

78 :: ( Each t h (FilePath, FilePath -> IO a) a

103− , ToJSON x

104 , Each s t FilePath (FilePath, FilePath -> IO a)

79 , Each s t FilePath (FilePath, FilePath -> IO a)

105− , HasUnsupportedFeature x

106 )

80 )

107 => String

81 => String

108 -> FilePath -- ^ Root path

82 -> FilePath -- ^ Root path

109 -> FilePath -- ^ Name of golden file

83 -> FilePath -- ^ Name of golden file

110 -> s

84 -> s

111 -> (FilePath -> IO a)

85 -> (FilePath -> IO a)

112− -> (h -> x)

86+ -> (h -> IO BSL.ByteString)

113 -> IO TestTree

87 -> IO TestTree

114goldenInputsTreeUniform name filepath golden inp h =

88goldenInputsTreeUniform name filepath golden inp h =

115 goldenInputsTree name filepath golden (inp & each %~ (,h))

89 goldenInputsTree name filepath golden (inp & each %~ (,h))

test/Spec/Golden/TraceTree.hs+44−14

@@ -4,26 +4,56 @@ module Spec.Golden.TraceTree

4where

5

6import Control.Category

7+import Control.Exception

8+import qualified Data.ByteString.Lazy as BSL

9+import Data.Default

7import Data.HList

10import Data.HList

11+import Data.OpenApi

12+import Data.Text (Text)

13+import qualified Data.Text.Encoding as T

8import qualified Data.Yaml as Yaml

14import qualified Data.Yaml as Yaml

9−import OpenAPI.Checker.Subtree

15+import OpenAPI.Checker.Behavior

10import OpenAPI.Checker.Paths

16import OpenAPI.Checker.Paths

17+import OpenAPI.Checker.PathsPrefixTree

18+import OpenAPI.Checker.Report

19+import OpenAPI.Checker.Subtree

11import OpenAPI.Checker.Validate.OpenApi ()

20import OpenAPI.Checker.Validate.OpenApi ()

12import Spec.Golden.Extra

21import Spec.Golden.Extra

13−import Test.Tasty (TestTree)

22+import Test.Tasty (TestTree, testGroup)

23+import Text.Pandoc.Class

24+import Text.Pandoc.Writers

14import Prelude hiding (id, (.))

25import Prelude hiding (id, (.))

15

26

16tests :: IO TestTree

27tests :: IO TestTree

17−tests =

28+tests = do

18− goldenInputsTreeUniform

29+ traceTreeTests <-

30+ goldenInputsTreeUniform

19− "Golden TraceTree"

31+ "TraceTree"

20− "test/golden/common"

32+ "test/golden/common"

21− "trace-tree.yaml"

33+ "trace-tree.yaml"

22− ("a.yaml", "b.yaml")

34+ ("a.yaml", "b.yaml")

23− Yaml.decodeFileThrow

35+ Yaml.decodeFileThrow

36+ (pure . BSL.fromStrict . Yaml.encode . runChecker)

37+

38+ reportTests <-

39+ goldenInputsTreeUniform

40+ "Report"

41+ "test/golden/common"

42+ "report.md"

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

44+ Yaml.decodeFileThrow

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

46+

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

48+

49+runPandoc :: PandocPure Text -> IO BSL.ByteString

50+runPandoc = either throwIO (pure . BSL.fromStrict . T.encodeUtf8) . runPure

51+

52+runChecker :: (OpenApi, OpenApi) -> Either (PathsPrefixTree Behave AnIssue 'APILevel) ()

24− (runCompatFormula . checkCompatibility HNil Root . toPC)

53+runChecker = runCompatFormula . checkCompatibility HNil Root . toPC

25− where

54+ where

55+ toPC (c, s) =

26− toPC (client, server) = ProdCons

56+ ProdCons

27− { producer = traced (step ClientSchema) client

57+ { producer = traced (step ClientSchema) c

28− , consumer = traced (step ServerSchema) server

58+ , consumer = traced (step ServerSchema) s

29 }

59 }

test/golden/common/enum-anyof/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/id/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/json/recursive/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/maximum-lowered/report.mdnew file+7

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

1+# **POST** /test

2+

3+## JSON Request

4+

5+### Number

6+

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

test/golden/common/maximum-lowered/trace-tree.yaml+3−2

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 InRequest:

5 InPayload:

6 PayloadSchema:

7− OfType Number: MatchingMaximumWeak (Inclusive 2.0) (Inclusive 3.0)

7+ OfType Number: MatchingMaximumWeak (ProdCons {producer = Inclusive 3.0,

8+ consumer = Inclusive 2.0})

test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/report.mdnew file+5

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

1+# **POST** /test

2+

3+## Parameter test1

4+

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

test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/trace-tree.yaml+1−1

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 InParam "test1": ParamEmptinessIncompatible

test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/parameters/change/report.mdnew file+9

@@ -0,0 +1,9 @@

1+# **POST** /test

2+

3+## Parameter test

4+

5+### JSON Schema

6+

7+#### String

8+

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

test/golden/common/pathItem/operation/parameters/change/trace-tree.yaml+1−1

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 InParam "test":

5 InParamSchema:

test/golden/common/pathItem/operation/parameters/required/false/add/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/parameters/required/false/del/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/parameters/required/reset/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/parameters/required/set/report.mdnew file+5

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

1+# **POST** /test

2+

3+## Parameter test1

4+

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

test/golden/common/pathItem/operation/parameters/required/set/trace-tree.yaml+1−1

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 InParam "test1": ParamRequired

test/golden/common/pathItem/operation/parameters/required/true/add/report.mdnew file+3

@@ -0,0 +1,3 @@

1+# **POST** /test

2+

3+Parameter test2 is not supported.

test/golden/common/pathItem/operation/parameters/required/true/add/trace-tree.yaml+1−1

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod: ParamNotMatched "test2"

test/golden/common/pathItem/operation/parameters/required/true/del/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.mdnew file+7

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

1+# **POST** /test

2+

3+## JSON Request

4+

5+### String

6+

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

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

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 InRequest:

5 InPayload:

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/report.mdnew file+6

@@ -0,0 +1,6 @@

1+# **POST** /test

2+

3+## Request

4+

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

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

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

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 InRequest: RequestMediaTypeNotFound application/x-www-form-urlencoded

test/golden/common/pathItem/operation/requestBody/required/reset/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/requestBody/required/set/report.mdnew file+5

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

1+# **POST** /test

2+

3+## Request

4+

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

test/golden/common/pathItem/operation/requestBody/required/set/trace-tree.yaml+1−1

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 InRequest: RequestBodyRequired

test/golden/common/pathItem/operation/responses/add/report.mdnew file+3

@@ -0,0 +1,3 @@

1+# **POST** /test

2+

3+Reponse code 500 is not supported.

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

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod: ResponseCodeNotFound 500

test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/report.mdnew file+5

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

1+# **POST** /test

2+

3+## Response code 200

4+

5+Couldn't find header `Test2`.

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

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 WithStatusCode 200: ResponseHeaderMissing "Test2"

test/golden/common/pathItem/operation/responses/change/headers/optional/add/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/responses/change/headers/optional/del/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/report.mdnew file+6

@@ -0,0 +1,6 @@

1+# **POST** /test

2+

3+## Response code 200

4+

5+Couldn't find reponse for media type

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

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

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

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

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.mdnew file+7

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

1+# **POST** /test

2+

3+## JSON Response – 200

4+

5+### Number

6+

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

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

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 WithStatusCode 200:

5 ResponsePayload:

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/pathItem/operation/responses/del/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/property-removed/report.mdnew file+13

@@ -0,0 +1,13 @@

1+# **POST** /test

2+

3+## JSON Request

4+

5+### Object

6+

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

8+

9+## JSON Response – 200

10+

11+### Object

12+

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

test/golden/common/property-removed/trace-tree.yaml+1−1

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 InRequest:

5 InPayload:

test/golden/common/property-required/report.mdnew file+7

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

1+# **POST** /test

2+

3+## JSON Request

4+

5+### Object

6+

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

test/golden/common/property-required/trace-tree.yaml+1−1

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

1Left:

2− AtPath (ProdCons {producer = "/test", consumer = "/test"}):

2+ AtPath "/test":

3 InOperation PostMethod:

4 InRequest:

5 InPayload:

test/golden/common/recursive/report.mdnew file+1

@@ -0,0 +1 @@

1+# No breaking changes found ✨

test/golden/common/security-scheme/report.mdnew file+15

@@ -0,0 +1,15 @@

1+# **POST** /oauth/check

2+

3+## Security requirement 0

4+

5+### oauth

6+

7+Security scheme not met.

8+

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

10+

11+## Security requirement 1

12+

13+### oauth

14+

15+Security scheme not met.

test/golden/common/security-scheme/trace-tree.yaml+5−5

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

1Left:

2− AtPath (ProdCons {producer = "/oauth/check", consumer = "/oauth/check"}):

2+ AtPath "/oauth/sign_out":

3− InOperation PostMethod:

4− SecurityRequirementStep 0:

5− SecuritySchemeStep "oauth": SecuritySchemeNotMatched

6− AtPath (ProdCons {producer = "/oauth/sign_out", consumer = "/oauth/sign_out"}):

7 InOperation GetMethod:

3 InOperation GetMethod:

8 SecurityRequirementStep 1:

4 SecurityRequirementStep 1:

9 SecuritySchemeStep "oauth": SecuritySchemeNotMatched

5 SecuritySchemeStep "oauth": SecuritySchemeNotMatched

6+ AtPath "/oauth/check":

7+ InOperation PostMethod:

8+ SecurityRequirementStep 0:

9+ SecuritySchemeStep "oauth": SecuritySchemeNotMatched

test/golden/common/servers/report.mdnew file+11

@@ -0,0 +1,11 @@

1+# **GET** /pets

2+

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

4+

5+Couldn't find a matching server.

6+

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

8+

9+Enum value `a` is not supported.

10+

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

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

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

1Left:

2− AtPath (ProdCons {producer = "/pets", consumer = "/pets"}):

2+ AtPath "/pets":

3 InOperation GetMethod:

4 InServer "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":

5 - EnumValueNotConsumed 1 "a"

test/golden/common/unguarded-recursive/report.mdnew file+5

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

1+# **GET** /api/foo

2+

3+## JSON Response – 200

4+

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

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

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

1Left:

2− AtPath (ProdCons {producer = "/api/foo", consumer = "/api/foo"}):

2+ AtPath "/api/foo":

3 InOperation GetMethod:

4 WithStatusCode 200:

5 ResponsePayload: