ilyakooo0/compaREST
1
0
Fork 0
mirror of https://github.com/ilyakooo0/compaREST.git synced 2024-08-16 01:40:26 +03:00
Code Issues Projects Releases Wiki Activity

Added report generation (#73)

Browse Source 
* first stab

* Made things compile

* Fixed headers

* Implemented jets

* Added method-path jet

* Added yet more jets

* Rerun tests

* Updated formatting

* Added some issue descriptions

* resolved producer/consumer mixup in schema

* Added UnguardedRecursion descriptions

* Added condition formatting

* Added jet docs

* Added different format outputs
This commit is contained in:
iko 2021-06-05 19:15:04 +03:00 committed by GitHub
parent f39734fc00
commit 218336b11e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
76 changed files with 884 additions and 268 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
app/FormatHeuristic.hs Normal file
View File

@ -0,0 +1,69 @@
-- |
-- Originally based on:
-- https://github.com/jgm/pandoc/blob/master/src/Text/Pandoc/App/FormatHeuristics.hs
module FormatHeuristic
( formatFromFilePath
)
where
import Data.Char (toLower)
import System.FilePath (takeExtension)
import Text.Pandoc
formatFromFilePath :: PandocMonad m => FilePath -> Maybe (Writer m)
formatFromFilePath x =
case takeExtension (map toLower x) of
".adoc" -> f "asciidoc"
".asciidoc" -> f "asciidoc"
".context" -> f "context"
".ctx" -> f "context"
".db" -> f "docbook"
".doc" -> f "doc" -- so we get an "unknown reader" error
".docx" -> f "docx"
".dokuwiki" -> f "dokuwiki"
".epub" -> f "epub"
".fb2" -> f "fb2"
".htm" -> f "html"
".html" -> f "html"
".icml" -> f "icml"
".json" -> f "json"
".latex" -> f "latex"
".lhs" -> f "markdown+lhs"
".ltx" -> f "latex"
".markdown" -> f "markdown"
".mkdn" -> f "markdown"
".mkd" -> f "markdown"
".mdwn" -> f "markdown"
".mdown" -> f "markdown"
".Rmd" -> f "markdown"
".md" -> f "markdown"
".ms" -> f "ms"
".muse" -> f "muse"
".native" -> f "native"
".odt" -> f "odt"
".opml" -> f "opml"
".org" -> f "org"
".pdf" -> f "pdf" -- so we get an "unknown reader" error
".pptx" -> f "pptx"
".roff" -> f "ms"
".rst" -> f "rst"
".rtf" -> f "rtf"
".s5" -> f "s5"
".t2t" -> f "t2t"
".tei" -> f "tei"
".tei.xml" -> f "tei"
".tex" -> f "latex"
".texi" -> f "texinfo"
".texinfo" -> f "texinfo"
".text" -> f "markdown"
".textile" -> f "textile"
".txt" -> f "markdown"
".wiki" -> f "mediawiki"
".xhtml" -> f "html"
".ipynb" -> f "ipynb"
".csv" -> f "csv"
".bib" -> f "biblatex"
['.', y] | y `elem` ['1' .. '9'] -> f "man"
_ -> Nothing
where
f k = lookup k writers

62
app/Main.hs
View File

@ -1,7 +1,63 @@
module Main (main) where
import OpenAPI.Checker.Run (runChecker)
import Control.Monad
import Control.Monad.Except
import Data.Aeson
import qualified Data.ByteString.Lazy as BSL
import Data.Default
import Data.HList
import qualified Data.Text.IO as T
import qualified Data.Yaml as Yaml
import FormatHeuristic
import OpenAPI.Checker.Behavior
import OpenAPI.Checker.Options
import OpenAPI.Checker.Paths
import OpenAPI.Checker.PathsPrefixTree
import OpenAPI.Checker.Report
import OpenAPI.Checker.Subtree
import System.Exit
import System.IO
import Text.Pandoc
main :: IO ()
main = runChecker
main = do
opts <- execParser optionsParserInfo
let parseSchema path =
eitherDecodeFileStrict path >>= \case
Left jsonErr -> do
Yaml.decodeFileEither path >>= \case
Left yamlErr -> do
putStrLn "Could not parse as json or yaml"
print jsonErr
print yamlErr
fail "Exiting"
Right s -> pure s
Right s -> pure s
a <- traced (step ClientSchema) <$> parseSchema (clientFile opts)
b <- traced (step ServerSchema) <$> parseSchema (serverFile opts)
let result = runCompatFormula $ checkCompatibility HNil Root (ProdCons a b)
runPandocIO :: PandocIO a -> ExceptT Errors IO a
runPandocIO x = lift (runIO x) >>= either (throwError . DocumentError) pure
output :: Either (PathsPrefixTree Behave AnIssue 'APILevel) () -> ExceptT Errors IO ()
output = case outputMode opts of
StdoutMode -> lift . T.putStrLn <=< runPandocIO . writeMarkdown def . generateReport
FileMode f -> case formatFromFilePath f of
Nothing -> \_ -> throwError UnknownOutputFormat
Just (TextWriter writer) -> lift . T.writeFile f <=< runPandocIO . writer def . generateReport
Just (ByteStringWriter writer) -> lift . BSL.writeFile f <=< runPandocIO . writer def . generateReport
either handler pure <=< runExceptT $ output result
case result of
Right () -> exitSuccess
Left _ -> exitWith $ ExitFailure 1
data Errors
= DocumentError PandocError
| UnknownOutputFormat
handler :: Errors -> IO a
handler (DocumentError err) = do
T.hPutStrLn stderr (renderError err)
exitWith $ ExitFailure 100
handler UnknownOutputFormat = do
T.hPutStrLn stderr "Could not determine output format from file extension."
exitWith $ ExitFailure 101

15
openapi-diff.cabal
View File

@ -63,6 +63,7 @@ common common-options
, vector
, yaml
, hashable
, pandoc-types
default-extensions: ApplicativeDo
, BangPatterns
@ -117,7 +118,6 @@ library
, OpenAPI.Checker.Paths
, OpenAPI.Checker.PathsPrefixTree
, OpenAPI.Checker.References
, OpenAPI.Checker.Run
, OpenAPI.Checker.Subtree
, OpenAPI.Checker.Validate.MediaTypeObject
, OpenAPI.Checker.Validate.OpenApi
@ -136,15 +136,24 @@ library
, OpenAPI.Checker.Common
, OpenAPI.Checker.Validate.SecurityScheme
, OpenAPI.Checker.Validate.OAuth2Flows
, OpenAPI.Checker.Report
executable openapi-diff
import: common-options
hs-source-dirs: app
main-is: Main.hs
build-depends: openapi-diff
build-depends:
openapi-diff
, pandoc
, data-default
, bytestring
, yaml
, filepath
ghc-options: -threaded
-rtsopts
-with-rtsopts=-N
other-modules:
FormatHeuristic
test-suite openapi-diff-test
import: common-options
@ -163,6 +172,8 @@ test-suite openapi-diff-test
, yaml
, directory
, filepath
, pandoc
, data-default
ghc-options: -threaded
-rtsopts
-with-rtsopts=-N

10
src/OpenAPI/Checker/Behavior.hs
View File

@ -9,9 +9,9 @@ where
import Data.Aeson
import Data.Kind
import Data.Text as T
import Data.Typeable
import OpenAPI.Checker.Paths
import Text.Pandoc.Builder
-- | Kind
data BehaviorLevel
@ -37,18 +37,20 @@ class
Behavable (a :: BehaviorLevel) (b :: BehaviorLevel)
where
data Behave a b
describeBehaviour :: Behave a b -> Inlines
type instance AdditionalQuiverConstraints Behave a b = Behavable a b
class (Typeable l, Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where
data Issue l :: Type
describeIssue :: Issue l -> Text
describeIssue = T.pack . show -- TODO: remove this default
describeIssue :: Issue l -> Blocks
issueIsUnsupported :: Issue l -> Bool
-- | A set of interactions having common unifying features
type Behavior = Paths Behave 'APILevel
instance Issuable l => ToJSON (Issue l) where
toJSON = toJSON . describeIssue
toJSON = toJSON . show
data AnIssue (l :: BehaviorLevel) where
AnIssue :: Issuable l => Issue l -> AnIssue l

6
src/OpenAPI/Checker/Paths.hs
View File

@ -3,6 +3,7 @@
-- structure.
module OpenAPI.Checker.Paths
( NiceQuiver
, AdditionalQuiverConstraints
, Paths (..)
, DiffPaths (..)
, catDiffPaths
@ -24,7 +25,10 @@ import Data.Type.Equality
import Type.Reflection
import Prelude hiding ((.))
type NiceQuiver (q :: k -> j -> Type) (a :: k) (b :: j) = (Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q a b))
type NiceQuiver (q :: k -> j -> Type) (a :: k) (b :: j) =
(Typeable q, Typeable a, Typeable b, Ord (q a b), Show (q a b), AdditionalQuiverConstraints q a b)
type family AdditionalQuiverConstraints (q :: k -> j -> Type) (a :: k) (b :: j) :: Constraint
-- | All the possible ways to navigate between nodes in a heterogeneous tree
-- form a quiver. The hom-sets of the free category constructed from this quiver

24
src/OpenAPI/Checker/PathsPrefixTree.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE QuantifiedConstraints #-}
module OpenAPI.Checker.PathsPrefixTree
( PathsPrefixTree
( PathsPrefixTree (PathsPrefixNode)
, AStep (..)
, empty
, singleton
, fromList
@ -24,6 +25,7 @@ import qualified Data.Text as T
import Data.Type.Equality
import qualified Data.TypeRepMap as TRM
import qualified Data.Vector as V
import qualified GHC.Exts as Exts
import qualified GHC.Exts as TRM
import OpenAPI.Checker.Paths
import Type.Reflection
@ -35,6 +37,15 @@ data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPref
, snocItems :: !(TRM.TypeRepMap (AStep q f r))
}
pattern PathsPrefixNode :: Ord (f r) => S.Set (f r) -> [TRM.WrapTypeable (AStep q f r)] -> PathsPrefixTree q f r
pattern PathsPrefixNode s steps <-
(\(PathsPrefixTree aset m) -> (toSet aset, Exts.toList m) -> (s, steps))
where
PathsPrefixNode s steps | S.null s = PathsPrefixTree AnEmptySet (Exts.fromList steps)
PathsPrefixNode s steps = PathsPrefixTree (ASet s) (Exts.fromList steps)
{-# COMPLETE PathsPrefixNode #-}
instance (forall a. ToJSON (f a)) => ToJSON (PathsPrefixTree q f r) where
toJSON =
Object . getMergableObject
@ -78,6 +89,10 @@ data ASet (a :: Type) where
AnEmptySet :: ASet a
ASet :: Ord a => S.Set a -> ASet a
toSet :: ASet a -> S.Set a
toSet AnEmptySet = S.empty
toSet (ASet s) = s
instance ToJSON a => ToJSON (ASet a) where
toJSON =
toJSON . \case
@ -123,6 +138,7 @@ instance Semigroup (PathsPrefixTree q f r) where
PathsPrefixTree r1 s1 <> PathsPrefixTree r2 s2 =
PathsPrefixTree (r1 <> r2) (TRM.unionWith joinSteps s1 s2)
where
joinSteps :: AStep q f r a -> AStep q f r a -> AStep q f r a
joinSteps (AStep m1) (AStep m2) = AStep $ M.unionWith (<>) m1 m2
instance Monoid (PathsPrefixTree q f r) where
@ -135,7 +151,7 @@ fromList :: [AnItem q f r] -> PathsPrefixTree q f r
fromList = foldMap singleton
null :: PathsPrefixTree q f r -> Bool
null (PathsPrefixTree AnEmptySet s) = TRM.size s == 0
null (PathsPrefixTree AnEmptySet s) = all (\(TRM.WrapTypeable (AStep x)) -> all null x) (Exts.toList s)
null _ = False
foldWith
@ -161,11 +177,11 @@ toList :: PathsPrefixTree q f r -> [AnItem q f r]
toList t = appEndo (foldWith (\xs f -> Endo (AnItem xs f :)) t) []
-- | Select a subtree by prefix
filter :: Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a
filter :: forall q f r a. Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a
filter Root t = t
filter (Snoc xs x) t =
foldMap (\(AStep m) -> fold $ M.lookup x m) $
TRM.lookup $ snocItems $ filter xs t
TRM.lookup @a $ snocItems $ filter xs t
-- | Embed a subtree in a larger tree with given prefix
embed :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r

136
src/OpenAPI/Checker/Report.hs Normal file
View File

@ -0,0 +1,136 @@
module OpenAPI.Checker.Report
( generateReport
)
where
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Foldable
import Data.Functor
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import Data.Traversable
import Data.TypeRepMap hiding (empty)
import Data.Typeable
import OpenAPI.Checker.Behavior
import OpenAPI.Checker.Paths
import OpenAPI.Checker.PathsPrefixTree hiding (empty)
import qualified OpenAPI.Checker.PathsPrefixTree as P hiding (empty)
import OpenAPI.Checker.Validate.OpenApi
import Text.Pandoc.Builder
generateReport :: Either (P.PathsPrefixTree Behave AnIssue 'APILevel) () -> Pandoc
generateReport (Right ()) = doc $ header 1 "No breaking changes found ✨"
generateReport (Left errs) = doc $ runReportMonad jets $ showErrs errs
data ReportState = ReportState
{ sourceJets :: [SomeReportJet Behave]
, headerLevel :: Int
}
type ReportMonad = ReaderT ReportState (Writer Blocks)
runReportMonad :: [SomeReportJet Behave] -> ReportMonad () -> Blocks
runReportMonad jts =
execWriter
. flip
runReaderT
ReportState
{ sourceJets = jts
, headerLevel = 1
}
smartHeader :: Inlines -> ReportMonad ()
smartHeader i = do
h <- asks headerLevel
tell $ header h i
showErrs :: Typeable a => P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
showErrs x@(P.PathsPrefixNode currentIssues _) = do
jts <- asks sourceJets
for_ currentIssues $ \(AnIssue i) -> tell . describeIssue $ i
unfoldM x (observeSomeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do
for_ subIssues $ \(WrapTypeable (AStep m)) ->
for_ (M.toList m) $ \(bhv, subErrors) -> do
unless (P.null subErrors) $ do
smartHeader $ describeBehaviour bhv
incrementHeaders $ showErrs subErrors
unfoldM :: Monad m => a -> [a -> m a] -> (a -> m ()) -> m ()
unfoldM a [] g = g a
unfoldM a (f : ff) g = do
a' <- f a
unfoldM a' ff g
observeSomeJetShowErrs
:: forall a.
Typeable a
=> SomeReportJet Behave
-> P.PathsPrefixTree Behave AnIssue a
-> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
observeSomeJetShowErrs (SomeReportJet (Proxy :: Proxy a') f) x
| Just Refl <- eqT @a @a' = observeJetShowErrs f x
observeSomeJetShowErrs _ x = pure x
observeJetShowErrs :: ReportJet Behave a -> P.PathsPrefixTree Behave AnIssue a -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
observeJetShowErrs jet (P.PathsPrefixNode currentIssues subIssues) = do
rest <- fmap (fold . join) $
for subIssues $ \(WrapTypeable (AStep m)) -> fmap catMaybes $
for (M.toList m) $ \(bhv, subErrs) ->
case applyReportJet jet bhv of
Just (Left h) -> do
smartHeader h
incrementHeaders $ showErrs subErrs
return Nothing
Just (Right jet') -> do
rest <- observeJetShowErrs jet' subErrs
return $ Just $ embed (step bhv) rest
Nothing -> return $ Just $ embed (step bhv) subErrs
return $ PathsPrefixNode currentIssues mempty <> rest
-- | A "jet" is a way of simplifying expressions from "outside". The "jetted"
-- expressions should still be completely valid and correct without the jets.
-- Jets just make the expression more "optimized" by identifying patterns and
-- replacing the expressions with "better" ones that have the same sematics.
--
-- The tem "jet" in this context was introduced in the Urbit project:
-- https://urbit.org/docs/vere/jetting/
--
-- The pattern fits well for simplifying 'Behaviour' tree paths.
class ConstructReportJet f a b c where
constructReportJet :: (f a b -> c) -> ReportJet f a
instance (ConstructReportJet f b c d, Typeable b) => ConstructReportJet f a b (f b c -> d) where
constructReportJet f = ReportJet Proxy $ \x -> constructReportJet $ f x
instance Typeable b => ConstructReportJet f a b Inlines where
constructReportJet f = TerminalJet Proxy f
constructSomeReportJet :: (ConstructReportJet f a b c, Typeable a) => (f a b -> c) -> SomeReportJet f
constructSomeReportJet = SomeReportJet Proxy . constructReportJet
data ReportJet f a where
ReportJet :: Typeable b => Proxy b -> (f a b -> ReportJet f b) -> ReportJet f a
TerminalJet :: Typeable b => Proxy b -> (f a b -> Inlines) -> ReportJet f a
data SomeReportJet f where
SomeReportJet :: Typeable a => Proxy a -> ReportJet f a -> SomeReportJet f
applyReportJet :: forall f a b. Typeable b => ReportJet f a -> f a b -> Maybe (Either Inlines (ReportJet f b))
applyReportJet (TerminalJet (Proxy :: Proxy b') f) x = eqT @b @b' <&> \Refl -> Left $ f x
applyReportJet (ReportJet (Proxy :: Proxy b') f) x = eqT @b @b' <&> \Refl -> Right $ f x
incrementHeaders :: ReportMonad x -> ReportMonad x
incrementHeaders m = do
l <- asks headerLevel
local (\x -> x {headerLevel = l + 1}) m
jets :: [SomeReportJet Behave]
jets =
[ constructSomeReportJet $ \p@(AtPath _) op@(InOperation _) ->
strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
, constructSomeReportJet $ \InRequest InPayload PayloadSchema -> "JSON Request" :: Inlines
, constructSomeReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
"JSON Response – " <> str (T.pack . show $ c) :: Inlines
]

40
src/OpenAPI/Checker/Run.hs
View File

@ -1,40 +0,0 @@
module OpenAPI.Checker.Run (runChecker) where
import Data.Aeson
import qualified Data.ByteString.Char8 as BSC
import Data.HList
import qualified Data.Yaml as Yaml
import OpenAPI.Checker.Options
import OpenAPI.Checker.Paths
import OpenAPI.Checker.Subtree
import OpenAPI.Checker.Validate.OpenApi ()
import System.Exit
import Prelude hiding (id, (.))
runChecker :: IO ()
runChecker = do
opts <- execParser optionsParserInfo
let parseSchema path =
eitherDecodeFileStrict path >>= \case
Left jsonErr -> do
Yaml.decodeFileEither path >>= \case
Left yamlErr -> do
putStrLn "Could not parse as json or yaml"
print jsonErr
print yamlErr
fail "Exiting"
Right s -> pure s
Right s -> pure s
a <- traced (step ClientSchema) <$> parseSchema (clientFile opts)
b <- traced (step ServerSchema) <$> parseSchema (serverFile opts)
let report = runCompatFormula $ checkCompatibility HNil Root (ProdCons a b)
output = case outputMode opts of
StdoutMode -> BSC.putStrLn
FileMode f -> BSC.writeFile f
case report of
Right () -> do
output "No breaking changes found"
exitSuccess
Left e -> do
output $ Yaml.encode e
exitFailure

19
src/OpenAPI/Checker/Subtree.hs
View File

@ -64,7 +64,7 @@ import OpenAPI.Checker.Paths
import qualified OpenAPI.Checker.PathsPrefixTree as P
class
NiceQuiver Step a b =>
(Typeable Step, Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>
Steppable (a :: Type) (b :: Type)
where
-- | How to get from an @a@ node to a @b@ node
@ -80,6 +80,8 @@ instance Steppable TraceRoot OpenApi where
type Trace = Paths Step TraceRoot
type instance AdditionalQuiverConstraints Step a b = ()
type Traced' a b = Env (Trace a) b
type Traced a = Traced' a a
@ -128,10 +130,12 @@ type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel
type StructuralCompatFormula = CompatFormula' VoidQuiver Proxy ()
data VoidQuiver a b where
data VoidQuiver a b
deriving stock instance Eq (VoidQuiver a b)
type instance AdditionalQuiverConstraints VoidQuiver a b = ()
deriving stock instance Ord (VoidQuiver a b)
deriving stock instance Show (VoidQuiver a b)
@ -297,10 +301,13 @@ memo
-> (ProdCons (Traced a) -> CompatFormula' q f r ())
-> (ProdCons (Traced a) -> CompatFormula' q f r ())
memo bhv k f pc = Compose $ do
formula' <- memoWithKnot fixpointKnot (do
formula <- getCompose $ f pc
pure $ mapErrors (P.filter bhv) formula
) (k, ask <$> pc)
formula' <-
memoWithKnot
fixpointKnot
(do
formula <- getCompose $ f pc
pure $ mapErrors (P.filter bhv) formula)
(k, ask <$> pc)
pure $ mapErrors (P.embed bhv) formula'
data MemoKey = SemanticMemoKey | StructuralMemoKey

5
src/OpenAPI/Checker/Validate/Header.hs
View File

@ -13,6 +13,7 @@ import OpenAPI.Checker.Behavior
import OpenAPI.Checker.References ()
import OpenAPI.Checker.Subtree
import OpenAPI.Checker.Validate.Schema ()
import Text.Pandoc.Builder
instance Subtree Header where
type SubtreeLevel Header = 'HeaderLevel
@ -50,8 +51,12 @@ instance Issuable 'HeaderLevel where
| HeaderSchemaRequired
deriving stock (Eq, Ord, Show)
issueIsUnsupported _ = False
describeIssue RequiredHeaderMissing = para "Header expected, but missing."
describeIssue NonEmptyHeaderRequired = para "Empty header not allowed."
describeIssue HeaderSchemaRequired = para "Expected header schema, but it is not present."
instance Behavable 'HeaderLevel 'SchemaLevel where
data Behave 'HeaderLevel 'SchemaLevel
= InSchema
deriving stock (Eq, Ord, Show)
describeBehaviour InSchema = "JSON Schema"

2
src/OpenAPI/Checker/Validate/Link.hs
View File

@ -5,6 +5,7 @@ module OpenAPI.Checker.Validate.Link () where
import Data.OpenApi
import OpenAPI.Checker.Behavior
import OpenAPI.Checker.Subtree
import Text.Pandoc.Builder
instance Subtree Link where
type SubtreeLevel Link = 'LinkLevel
@ -18,3 +19,4 @@ instance Issuable 'LinkLevel where
deriving (Eq, Ord, Show)
issueIsUnsupported = \case
LinksUnsupported -> True
describeIssue LinksUnsupported = para "OpenApi Diff does not currently support Link Objects."

25
src/OpenAPI/Checker/Validate/MediaTypeObject.hs
View File

@ -6,19 +6,22 @@ module OpenAPI.Checker.Validate.MediaTypeObject
)
where
import Control.Lens
import Control.Lens hiding (para)
import Data.Foldable as F
import Data.HList
import Data.HashMap.Strict.InsOrd as IOHM
import Data.Map.Strict as M
import Data.OpenApi
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Network.HTTP.Media (MediaType, mainType, subType)
import OpenAPI.Checker.Behavior
import OpenAPI.Checker.Subtree
import OpenAPI.Checker.Validate.Header ()
import OpenAPI.Checker.Validate.Products
import OpenAPI.Checker.Validate.Schema ()
import Text.Pandoc.Builder
tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))
tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
@ -31,9 +34,7 @@ tracedEncoding mto =
instance Issuable 'PayloadLevel where
data Issue 'PayloadLevel
= PayloadMediaTypeNotFound
| MediaEncodingIncompat
| MediaTypeSchemaRequired
= MediaTypeSchemaRequired
| MediaEncodingMissing Text
| EncodingNotSupported
deriving (Eq, Ord, Show)
@ -41,10 +42,15 @@ instance Issuable 'PayloadLevel where
EncodingNotSupported -> True
_ -> False
describeIssue MediaTypeSchemaRequired = para "Media type expected, but was not specified."
describeIssue (MediaEncodingMissing enc) = para $ "Media encoding " <> str enc <> " expected, but was not specified."
describeIssue EncodingNotSupported = para "OpenApi Diff does not currently support media encodings other than JSON."
instance Behavable 'PayloadLevel 'SchemaLevel where
data Behave 'PayloadLevel 'SchemaLevel
= PayloadSchema
deriving (Eq, Ord, Show)
describeBehaviour PayloadSchema = "JSON Schema"
instance Subtree MediaTypeObject where
type SubtreeLevel MediaTypeObject = 'PayloadLevel
@ -136,15 +142,22 @@ instance Behavable 'OperationLevel 'ResponseLevel where
data Behave 'OperationLevel 'ResponseLevel
= WithStatusCode HttpStatusCode
deriving stock (Eq, Ord, Show)
describeBehaviour (WithStatusCode c) = "Response code " <> (fromString . show $ c)
instance Issuable 'OperationLevel where
data Issue 'OperationLevel
= ResponseCodeNotFound HttpStatusCode
| CallbacksNotSupported
| ParamNotMatched Text
| PathFragmentNotMatched Int
| NoRequestBody
deriving stock (Eq, Ord, Show)
issueIsUnsupported = \case
CallbacksNotSupported -> True
_ -> False
describeIssue (ResponseCodeNotFound c) =
para $ "Reponse code " <> (str . T.pack . show $ c) <> " is not supported."
describeIssue (ParamNotMatched param) =
para $ "Parameter " <> str param <> " is not supported."
describeIssue (PathFragmentNotMatched i) =
-- TODO: Indices are meaningless in this context. Replace with a better error.
para $ "Path fragment " <> (str . T.pack . show $ i) <> " not matched."
describeIssue NoRequestBody = para "Request body not specified."

25
src/OpenAPI/Checker/Validate/OAuth2Flows.hs
View File

@ -9,6 +9,7 @@ where
import Control.Monad
import Data.Function
import Data.Functor
import qualified Data.HashMap.Strict.InsOrd as IOHM
import Data.OpenApi
import Data.Proxy
@ -18,6 +19,7 @@ import Data.Text (Text)
import OpenAPI.Checker.Behavior
import OpenAPI.Checker.Orphans ()
import OpenAPI.Checker.Subtree
import Text.Pandoc.Builder
instance Subtree OAuth2Flows where
type CheckEnv OAuth2Flows = '[]
@ -102,6 +104,8 @@ instance Issuable 'SecurityRequirementLevel where
| UndefinedSecurityScheme Text
deriving stock (Eq, Ord, Show)
issueIsUnsupported _ = False
describeIssue SecurityRequirementNotMet = para "Security scheme was not met."
describeIssue (UndefinedSecurityScheme k) = para $ "Security scheme " <> code k <> " is not defined."
instance Issuable 'SecuritySchemeLevel where
data Issue 'SecuritySchemeLevel
@ -125,8 +129,29 @@ instance Issuable 'SecuritySchemeLevel where
| ScopeNotDefined Text
deriving stock (Eq, Ord, Show)
issueIsUnsupported _ = False
describeIssue RefreshUrlsDontMatch = para "Refresh URLs differ."
describeIssue (HttpSchemeTypesDontMatch _ _) = para "HTTP scheme types don't match."
describeIssue (ApiKeyParamsDontMatch _ _) = para "API Key parameters don't match."
describeIssue (OpenIdConnectUrlsDontMatch _ _) = para "OpenaId Connect URLs don't match."
describeIssue (CustomHttpSchemesDontMatch e a) =
para $ "Expected HTTP scheme " <> code e <> " but got " <> code a <> "."
describeIssue ConsumerDoesNotSupportImplicitFlow = para "Implicit flow not supported."
describeIssue ConsumerDoesNotSupportPasswordFlow = para "Password flow not supported."
describeIssue ConsumerDoesNotSupportClientCridentialsFlow = para "Client Cridentials flow not supported."
describeIssue ConsumerDoesNotSupportAuthorizationCodeFlow = para "Authorization Code flow not supported."
describeIssue SecuritySchemeNotMatched = para "Security scheme not met."
describeIssue OAuth2ImplicitFlowNotEqual = para "Implicit Flows don't match."
describeIssue OAuth2PasswordFlowNotEqual = para "Password Flows don't match."
describeIssue OAuth2ClientCredentialsFlowNotEqual = para "Client Cridentials Flows don't match."
describeIssue OAuth2AuthorizationCodeFlowNotEqual = para "Authorization Code Flows don't match."
describeIssue (ScopesMissing ss) =
para "Scopes missing:" <> bulletList (S.toList ss <&> codeBlock)
describeIssue DifferentSecuritySchemes = para "Completely different security scheme types."
describeIssue CanNotHaveScopes = para "The specified security scheme can not have scopes."
describeIssue (ScopeNotDefined k) = para $ "Scope with key " <> code k <> " is not defined."
instance Behavable 'SecurityRequirementLevel 'SecuritySchemeLevel where
data Behave 'SecurityRequirementLevel 'SecuritySchemeLevel
= SecuritySchemeStep Text
deriving stock (Eq, Ord, Show)
describeBehaviour (SecuritySchemeStep s) = text s

2
src/OpenAPI/Checker/Validate/OpenApi.hs
View File

@ -3,7 +3,7 @@
{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}
module OpenAPI.Checker.Validate.OpenApi
(
( Behave (..)
)
where

47
src/OpenAPI/Checker/Validate/Operation.hs
View File

@ -13,6 +13,7 @@ module OpenAPI.Checker.Validate.Operation
, ProcessedPathItems (..)
, processPathItems
, Step (..)
, Behave (..)
)
where
@ -27,6 +28,7 @@ import qualified Data.List as L
import Data.Map.Strict as M
import Data.Maybe
import Data.OpenApi
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import OpenAPI.Checker.Behavior
@ -36,11 +38,12 @@ import OpenAPI.Checker.Validate.MediaTypeObject
import OpenAPI.Checker.Validate.OAuth2Flows
import OpenAPI.Checker.Validate.PathFragment
import OpenAPI.Checker.Validate.Products
import OpenAPI.Checker.Validate.RequestBody ()
import OpenAPI.Checker.Validate.Responses ()
import OpenAPI.Checker.Validate.RequestBody
import OpenAPI.Checker.Validate.Responses
import OpenAPI.Checker.Validate.SecurityRequirement ()
import OpenAPI.Checker.Validate.Server ()
import OpenAPI.Checker.Validate.Sums
import Text.Pandoc.Builder
data MatchedOperation = MatchedOperation
{ operation :: !Operation
@ -95,18 +98,24 @@ getServers env oper =
instance Behavable 'OperationLevel 'PathFragmentLevel where
data Behave 'OperationLevel 'PathFragmentLevel
= InParam Text
| InFragment Int
| InFragment (PathFragment Text)
deriving stock (Eq, Ord, Show)
describeBehaviour (InParam p) = "Parameter " <> text p
describeBehaviour (InFragment (StaticPath p)) = "Static fragment " <> code p
describeBehaviour (InFragment (DynamicPath p)) = "Dynamic fragment " <> code p
instance Behavable 'OperationLevel 'RequestLevel where
data Behave 'OperationLevel 'RequestLevel
= InRequest
deriving stock (Eq, Ord, Show)
describeBehaviour InRequest = "Request"
instance Behavable 'OperationLevel 'SecurityRequirementLevel where
data Behave 'OperationLevel 'SecurityRequirementLevel
= SecurityRequirementStep Int
deriving stock (Eq, Ord, Show)
describeBehaviour (SecurityRequirementStep i) =
"Security requirement " <> (text . T.pack . show $ i)
instance Subtree MatchedOperation where
type SubtreeLevel MatchedOperation = 'OperationLevel
@ -202,7 +211,8 @@ instance Subtree MatchedOperation where
fragments = getFragments <$> pathParams <*> prodCons
getFragments params mop = getPathFragments (extract mop) params
-- Feed path parameters to the fragments getter
check idx frags = checkCompatibility @PathFragmentParam env (beh >>> step (InFragment idx)) frags
check _ frags@(ProdCons (Traced _ p) _) =
checkCompatibility @PathFragmentParam env (beh >>> step (InFragment $ _paramName . extract <$> p)) frags
elements =
fragments <&> \frags -> M.fromList $
zip [0 :: Int ..] $ do
@ -348,12 +358,16 @@ instance Issuable 'APILevel where
-- When several paths match given but all checks failed
deriving stock (Eq, Ord, Show)
issueIsUnsupported _ = False
describeIssue (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " did not match anything."
describeIssue (AllPathsFailed p) = para $ "The path " <> (code . T.pack) p <> " did not match anything."
instance Behavable 'APILevel 'PathLevel where
data Behave 'APILevel 'PathLevel
= AtPath (ProdCons FilePath) -- TODO: why are there two?
= AtPath FilePath
deriving stock (Eq, Ord, Show)
describeBehaviour (AtPath p) = str (T.pack p)
instance Subtree ProcessedPathItems where
type SubtreeLevel ProcessedPathItems = 'APILevel
type
@ -376,15 +390,16 @@ instance Subtree ProcessedPathItems where
-- one way
for_ (unProcessedPathItems . extract $ p) $ \prodItem -> do
let prodPath = path prodItem
beh' = beh >>> step (AtPath prodPath)
matchedItems = do
consItem <- unProcessedPathItems . extract $ c
F.toList $ matchingPathItems $ ProdCons prodItem consItem
case matchedItems of
[] -> issueAt beh $ NoPathsMatched prodPath
[match] -> checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)
[match] -> checkCompatibility env beh' (retraced <$> pc <*> match)
matches -> anyOfAt beh (AllPathsFailed prodPath) $ do
match <- matches
pure $ checkCompatibility env (beh >>> step (AtPath $ matchedPath <$> match)) (retraced <$> pc <*> match)
pure $ checkCompatibility env beh' (retraced <$> pc <*> match)
where
retraced pc mpi = traced (ask pc >>> step (MatchedPathStep $ matchedPath mpi)) mpi
@ -429,7 +444,6 @@ tracedMatchedPathItemParameters mpi =
| (i, x) <- L.zip [0 ..] $ _pathItemParameters . pathItem $ extract mpi
]
-- TODO: simplify?
tracedFragments :: Traced MatchedPathItem -> [Env (Trace PathFragmentParam) (PathFragment Text)]
tracedFragments mpi =
[ env (ask mpi >>> step (PathFragmentStep i)) x
@ -447,12 +461,26 @@ instance Issuable 'PathLevel where
= OperationMissing OperationMethod
deriving stock (Eq, Ord, Show)
issueIsUnsupported _ = False
describeIssue (OperationMissing op) = para $ "Method " <> strong (showMethod op) <> " is not defined."
instance Behavable 'PathLevel 'OperationLevel where
data Behave 'PathLevel 'OperationLevel
= InOperation OperationMethod
deriving (Eq, Ord, Show)
describeBehaviour (InOperation method) = showMethod method
showMethod :: IsString s => OperationMethod -> s
showMethod = \case
GetMethod -> "GET"
PutMethod -> "PUT"
PostMethod -> "POST"
DeleteMethod -> "DELETE"
OptionsMethod -> "OPTIONS"
HeadMethod -> "HEAD"
PatchMethod -> "PATCH"
TraceMethod -> "TRACE"
instance Subtree MatchedPathItem where
type SubtreeLevel MatchedPathItem = 'PathLevel
type
@ -550,6 +578,7 @@ instance Issuable 'CallbackLevel where
deriving (Eq, Ord, Show)
issueIsUnsupported = \case
CallbacksUnsupported -> True
describeIssue CallbacksUnsupported = para "OpenApi Diff does not currently support callbacks."
tracedCallbackPathItems :: Traced Callback -> Traced ProcessedPathItems
tracedCallbackPathItems (Traced t (Callback x)) =
@ -562,3 +591,5 @@ instance Steppable Callback ProcessedPathItems where
instance Behavable 'OperationLevel 'CallbackLevel where
data Behave 'OperationLevel 'CallbackLevel = OperationCallback Text
deriving stock (Eq, Ord, Show)
describeBehaviour (OperationCallback key) = "Operation " <> code key

12
src/OpenAPI/Checker/Validate/Param.hs
View File

@ -6,7 +6,7 @@ module OpenAPI.Checker.Validate.Param
, Issue (..)
) where
import Control.Lens
import Control.Lens hiding (para)
import Control.Monad
import Data.Maybe
import Data.OpenApi
@ -15,6 +15,7 @@ import OpenAPI.Checker.Behavior
import OpenAPI.Checker.Orphans ()
import OpenAPI.Checker.Subtree
import OpenAPI.Checker.Validate.Schema ()
import Text.Pandoc.Builder
-- | The type is normalized encoding style of the parameter. If two encoding
-- styles are equal then parameters are compatible with their encoding style
@ -62,11 +63,20 @@ instance Issuable 'PathFragmentLevel where
| PathFragmentsDontMatch Text Text
deriving (Eq, Ord, Show)
issueIsUnsupported _ = False
describeIssue ParamNameMismatch = para "The path fragments don't match."
describeIssue ParamEmptinessIncompatible = para "Expected that an empty parameter is allowed, but it isn't."
describeIssue ParamRequired = para "Expected the parameter to be optional, but it is required."
describeIssue ParamPlaceIncompatible = para "Parameters in incompatible locations."
describeIssue ParamStyleMismatch = para "Different parameter styles (encodings)."
describeIssue ParamSchemaMismatch = para "Expected a schema, but didn't find one."
describeIssue (PathFragmentsDontMatch e a) = para $ "Expected " <> code e <> " but got " <> code a <> "."
instance Behavable 'PathFragmentLevel 'SchemaLevel where
data Behave 'PathFragmentLevel 'SchemaLevel
= InParamSchema
deriving (Eq, Ord, Show)
describeBehaviour InParamSchema = "JSON Schema"
instance Subtree Param where
type SubtreeLevel Param = 'PathFragmentLevel

2
src/OpenAPI/Checker/Validate/PathFragment.hs
View File

@ -32,7 +32,7 @@ parsePath = fmap partition . T.splitOn "/" . T.pack
data PathFragment param
= StaticPath Text
| DynamicPath param
deriving stock (Eq, Ord)
deriving stock (Eq, Ord, Show, Functor)
type PathFragmentParam = PathFragment (Traced Param)

8
src/OpenAPI/Checker/Validate/RequestBody.hs
View File

@ -2,6 +2,7 @@
module OpenAPI.Checker.Validate.RequestBody
( Issue (..)
, Behave (..)
)
where
@ -10,11 +11,13 @@ import Data.HashMap.Strict.InsOrd as IOHM
import Data.Map.Strict as M
import Data.Maybe
import Data.OpenApi
import qualified Data.Text as T
import Network.HTTP.Media (MediaType)
import OpenAPI.Checker.Behavior
import OpenAPI.Checker.Subtree
import OpenAPI.Checker.Validate.MediaTypeObject
import OpenAPI.Checker.Validate.Sums
import Text.Pandoc.Builder
-- TODO: Use RequestMediaTypeObjectMapping
tracedContent :: Traced RequestBody -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
@ -28,11 +31,16 @@ instance Issuable 'RequestLevel where
| RequestMediaTypeNotFound MediaType
deriving stock (Eq, Ord, Show)
issueIsUnsupported _ = False
describeIssue RequestBodyRequired =
para "Expected the request body to be optional, but found it to be required."
describeIssue (RequestMediaTypeNotFound t) =
para $ "Couldn't find a request body for media type " <> (code . T.pack . show $ t) <> "."
instance Behavable 'RequestLevel 'PayloadLevel where
data Behave 'RequestLevel 'PayloadLevel
= InPayload
deriving stock (Eq, Ord, Show)
describeBehaviour InPayload = "Payload"
instance Subtree RequestBody where
type SubtreeLevel RequestBody = 'RequestLevel

12
src/OpenAPI/Checker/Validate/Responses.hs
View File

@ -2,7 +2,7 @@
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module OpenAPI.Checker.Validate.Responses
(
( Behave (..)
)
where
@ -11,6 +11,7 @@ import Data.HashMap.Strict.InsOrd as IOHM
import Data.Map.Strict as M
import Data.Maybe
import Data.OpenApi
import qualified Data.Text as T
import Network.HTTP.Media (MediaType)
import OpenAPI.Checker.Behavior
import OpenAPI.Checker.References
@ -21,6 +22,7 @@ import OpenAPI.Checker.Validate.MediaTypeObject
import OpenAPI.Checker.Validate.Products
import OpenAPI.Checker.Validate.Schema ()
import OpenAPI.Checker.Validate.Sums
import Text.Pandoc.Builder
tracedResponses :: Traced Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced (Referenced Response))
tracedResponses resp =
@ -70,17 +72,25 @@ instance Issuable 'ResponseLevel where
| ResponseHeaderMissing HeaderName
deriving stock (Eq, Ord, Show)
issueIsUnsupported _ = False
describeIssue (ResponseMediaTypeMissing t) =
para $ "Couldn't find reponse for media type " <> (code . T.pack . show $ t) <> "."
describeIssue (ResponseHeaderMissing h) =
para $ "Couldn't find header " <> code h <> "."
instance Behavable 'ResponseLevel 'PayloadLevel where
data Behave 'ResponseLevel 'PayloadLevel
= ResponsePayload
deriving stock (Eq, Ord, Show)
describeBehaviour ResponsePayload = "Payload"
instance Behavable 'ResponseLevel 'HeaderLevel where
data Behave 'ResponseLevel 'HeaderLevel
= InHeader HeaderName
deriving stock (Eq, Ord, Show)
describeBehaviour (InHeader name) = "Header " <> code name
instance Subtree Response where
type SubtreeLevel Response = 'ResponseLevel
type

319
src/OpenAPI/Checker/Validate/Schema.hs
View File

@ -17,12 +17,13 @@ import Algebra.Lattice
import Control.Applicative
import Control.Arrow
import Control.Comonad.Env hiding (env)
import Control.Lens hiding (cons)
import Control.Lens hiding (cons, para)
import Control.Monad.Reader hiding (ask)
import qualified Control.Monad.Reader as R
import Control.Monad.State
import Control.Monad.Writer
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BSL
import Data.Coerce
import qualified Data.Foldable as F
import Data.HList
@ -40,8 +41,8 @@ import Data.Scientific
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T hiding (singleton)
import qualified Data.Text.Encoding as T
import Data.Typeable
import Text.Regex.Pcre2
import OpenAPI.Checker.Behavior
import OpenAPI.Checker.Memo
import OpenAPI.Checker.Orphans ()
@ -49,6 +50,8 @@ import OpenAPI.Checker.Paths
import qualified OpenAPI.Checker.PathsPrefixTree as P
import OpenAPI.Checker.References
import OpenAPI.Checker.Subtree
import Text.Pandoc.Builder hiding (Format, Null)
import Text.Regex.Pcre2
-- | Type of a JSON value
data JsonType
@ -84,7 +87,7 @@ untypeValue (TArray a) = A.Array a
untypeValue (TObject o) = A.Object o
data Bound a = Exclusive !a | Inclusive !a
deriving (Eq, Show)
deriving (Eq, Show, Functor)
-- | The order is lexicographical on @a * Bool@.
instance Ord a => Ord (Bound a) where
@ -128,6 +131,45 @@ data Condition :: JsonType -> Type where
MaxProperties :: !Integer -> Condition 'Object
MinProperties :: !Integer -> Condition 'Object
showCondition :: Condition a -> Blocks
showCondition = \case
(Exactly v) -> para "The value should be:" <> showJSONValue (untypeValue v)
(Maximum b) -> para $ "The value should be less than " <> showBound b <> "."
(Minimum (Down b)) -> para $ "The value should be more than " <> showBound (getDown <$> b) <> "."
(MultipleOf n) -> para $ "The value should be a multiple of " <> show' n <> "."
(NumberFormat p) -> para $ "The number should have the following format:" <> code p <> "."
(Pattern p) -> para "The value should satisfy the following pattern (regular expression):" <> codeBlock p
(StringFormat p) -> para $ "The string should have the following format:" <> code p <> "."
(MaxLength p) -> para $ "The length of the string should be less than or equal to " <> show' p <> "."
(MinLength p) -> para $ "The length of the string should be more than or equal to " <> show' p <> "."
(Items i _) -> para "The items of the array should satisfy:" <> showForEachJsonFormula i
(MaxItems n) -> para $ "The length of the array should be less than or equal to " <> show' n <> "."
(MinItems n) -> para $ "The length of the array should be more than or equal to " <> show' n <> "."
UniqueItems -> para "The elements in the array should be unique."
(Properties props additional _) ->
bulletList $
(M.toList props
<&> (\(k, p) ->
para (code k)
<> para (strong $ if propRequired p then "Required" else "Optional")
<> showForEachJsonFormula (propFormula p)))
<> [ para (emph "Additional properties")
<> showForEachJsonFormula additional
]
(MaxProperties n) -> para $ "The maximum number of fields should be " <> show' n <> "."
(MinProperties n) -> para $ "The minimum number of fields should be " <> show' n <> "."
where
showForEachJsonFormula :: ForeachType JsonFormula -> Blocks
showForEachJsonFormula i =
bulletList $
foldType
(\t f ->
let (DNF conds') = f i
conds = S.toList <$> S.toList conds'
in [ para (describeJSONType t)
<> bulletList (conds <&> \cond -> bulletList (showCondition <$> cond))
])
satisfiesTyped :: TypedValue t -> Condition t -> Bool
satisfiesTyped e (Exactly e') = e == e'
satisfiesTyped (TNumber n) (Maximum (Exclusive m)) = n < m
@ -363,10 +405,6 @@ instance
, forObject = top
}
instance Behavable 'SchemaLevel 'SchemaLevel where
data Behave 'SchemaLevel 'SchemaLevel
deriving (Eq, Ord, Show)
instance Steppable Schema (Referenced Schema) where
data Step Schema (Referenced Schema)
= AllOfStep Int
@ -396,7 +434,7 @@ parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$r
A.Error _ -> Ref $ Reference v
-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.
newtype Silent q f r a = Silent { runSilent :: a }
newtype Silent q f r a = Silent {runSilent :: a}
deriving stock (Functor)
deriving (Applicative, Monad) via Identity
@ -427,11 +465,12 @@ silently m = do
pure . runSilent $ runReaderT m defs
warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
warnKnot = KnotTier
{ onKnotFound = warn UnguardedRecursion
, onKnotUsed = \_ -> pure bottom
, tieKnot = \_ -> pure
}
warnKnot =
KnotTier
{ onKnotFound = warn UnguardedRecursion
, onKnotUsed = \_ -> pure bottom
, tieKnot = \_ -> pure
}
processRefSchema
:: MonadProcess m
@ -835,19 +874,19 @@ checkImplication env beh prods cons = case findExactly prods of
Just m' ->
if m' <= m
then pure ()
else issueAt beh (MatchingMaximumWeak m m')
else issueAt beh (MatchingMaximumWeak $ ProdCons {producer = m', consumer = m})
Nothing -> issueAt beh (NoMatchingMaximum m)
Minimum m -> case findRelevant max (\case Minimum m' -> Just m'; _ -> Nothing) prods of
Just m' ->
if m' >= m
then pure ()
else issueAt beh (MatchingMinimumWeak (coerce m) (coerce m'))
else issueAt beh (MatchingMinimumWeak ProdCons {producer = coerce m', consumer = coerce m})
Nothing -> issueAt beh (NoMatchingMinimum (coerce m))
MultipleOf m -> case findRelevant lcmScientific (\case MultipleOf m' -> Just m'; _ -> Nothing) prods of
Just m' ->
if lcmScientific m m' == m'
then pure ()
else issueAt beh (MatchingMultipleOfWeak m m')
else issueAt beh (MatchingMultipleOfWeak $ ProdCons {producer = m', consumer = m})
Nothing -> issueAt beh (NoMatchingMultipleOf m)
NumberFormat f ->
if any (\case NumberFormat f' -> f == f'; _ -> False) prods
@ -857,13 +896,13 @@ checkImplication env beh prods cons = case findExactly prods of
Just m' ->
if m' <= m
then pure ()
else issueAt beh (MatchingMaxLengthWeak m m')
else issueAt beh (MatchingMaxLengthWeak $ ProdCons {producer = m', consumer = m})
Nothing -> issueAt beh (NoMatchingMaxLength m)
MinLength m -> case findRelevant max (\case MinLength m' -> Just m'; _ -> Nothing) prods of
Just m' ->
if m' >= m
then pure ()
else issueAt beh (MatchingMinLengthWeak m m')
else issueAt beh (MatchingMinLengthWeak $ ProdCons {producer = m', consumer = m})
Nothing -> issueAt beh (NoMatchingMinLength m)
Pattern p ->
if any (\case Pattern p' -> p == p'; _ -> False) prods
@ -883,50 +922,52 @@ checkImplication env beh prods cons = case findExactly prods of
Just m' ->
if m' <= m
then pure ()
else issueAt beh (MatchingMaxItemsWeak m m')
else issueAt beh (MatchingMaxItemsWeak ProdCons {producer = m', consumer = m})
Nothing -> issueAt beh (NoMatchingMaxItems m)
MinItems m -> case findRelevant max (\case MinItems m' -> Just m'; _ -> Nothing) prods of
Just m' ->
if m' >= m
then pure ()
else issueAt beh (MatchingMinItemsWeak m m')
else issueAt beh (MatchingMinItemsWeak ProdCons {producer = m', consumer = m})
Nothing -> issueAt beh (NoMatchingMinItems m)
UniqueItems ->
if any (== UniqueItems) $ prods
then pure ()
else issueAt beh NoMatchingUniqueItems
Properties props _ madd -> case findRelevant (<>) (\case Properties props' _ madd' -> Just $ (props', madd') NE.:| []; _ -> Nothing) prods of
Just pm -> anyOfAt beh NoMatchingProperties $ NE.toList pm <&> \(props', madd') -> do
F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do
let go sch sch' = checkCompatibility env (beh >>> step (InProperty k)) (ProdCons sch sch')
case (M.lookup k props', madd', M.lookup k props, madd) of
(Nothing, Nothing, _, _) -> pure () -- vacuously
(_, _, Nothing, Nothing) -> issueAt beh (UnexpectedProperty k)
(Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)
(Nothing, Just add', Just p, _) -> go add' (propRefSchema p)
(Just p', _, Nothing, Just add) -> go (propRefSchema p') add
(Nothing, Just _, Nothing, Just _) -> pure ()
case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of
(False, True) -> issueAt beh (PropertyNowRequired k)
_ -> pure ()
pure ()
case (madd', madd) of
(Nothing, _) -> pure () -- vacuously
(_, Nothing) -> issueAt beh NoAdditionalProperties
(Just add', Just add) -> checkCompatibility env (beh >>> step InAdditionalProperty) (ProdCons add' add)
pure ()
Just pm ->
anyOfAt beh NoMatchingProperties $
NE.toList pm <&> \(props', madd') -> do
F.for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do
let go sch sch' = checkCompatibility env (beh >>> step (InProperty k)) (ProdCons sch sch')
case (M.lookup k props', madd', M.lookup k props, madd) of
(Nothing, Nothing, _, _) -> pure () -- vacuously
(_, _, Nothing, Nothing) -> issueAt beh (UnexpectedProperty k)
(Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)
(Nothing, Just add', Just p, _) -> go add' (propRefSchema p)
(Just p', _, Nothing, Just add) -> go (propRefSchema p') add
(Nothing, Just _, Nothing, Just _) -> pure ()
case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of
(False, True) -> issueAt beh (PropertyNowRequired k)
_ -> pure ()
pure ()
case (madd', madd) of
(Nothing, _) -> pure () -- vacuously
(_, Nothing) -> issueAt beh NoAdditionalProperties
(Just add', Just add) -> checkCompatibility env (beh >>> step InAdditionalProperty) (ProdCons add' add)
pure ()
Nothing -> issueAt beh NoMatchingProperties
MaxProperties m -> case findRelevant min (\case MaxProperties m' -> Just m'; _ -> Nothing) prods of
Just m' ->
if m' <= m
then pure ()
else issueAt beh (MatchingMaxPropertiesWeak m m')
else issueAt beh (MatchingMaxPropertiesWeak ProdCons {producer = m', consumer = m})
Nothing -> issueAt beh (NoMatchingMaxProperties m)
MinProperties m -> case findRelevant max (\case MinProperties m' -> Just m'; _ -> Nothing) prods of
Just m' ->
if m' >= m
then pure ()
else issueAt beh (MatchingMinPropertiesWeak m m')
else issueAt beh (MatchingMinPropertiesWeak ProdCons {producer = m', consumer = m})
Nothing -> issueAt beh (NoMatchingMinProperties m)
where
findExactly (Exactly x : _) = Just x
@ -939,85 +980,145 @@ checkImplication env beh prods cons = case findExactly prods of
instance Issuable 'TypedSchemaLevel where
data Issue 'TypedSchemaLevel
= EnumDoesntSatisfy A.Value
-- ^ producer produces a specific value ($1), consumer has a condition that is not satisfied by said value
| NoMatchingEnum A.Value
-- ^ producer produces a specific value ($1) which is not listed in the consumer's list of specific values
| NoMatchingMaximum (Bound Scientific)
-- ^ producer declares a maximum numeric value ($1), consumer doesnt
| MatchingMaximumWeak (Bound Scientific) (Bound Scientific)
-- ^ producer declares a maximum numeric value ($1), consumer declares a weaker (higher) limit ($2)
| NoMatchingMinimum (Bound Scientific)
-- ^ producer declares a minimum numeric value, consumer doesnt
| MatchingMinimumWeak (Bound Scientific) (Bound Scientific)
-- ^ producer declares a minimum numeric value ($1), consumer declares a weaker (lower) limit ($2)
| NoMatchingMultipleOf Scientific
-- ^ producer declares that the numeric value must be a multiple of $1, consumer doesn't
| MatchingMultipleOfWeak Scientific Scientific
-- ^ producer declares that the numeric value must be a multiple of $1, consumer declares a weaker condition (multiple of $2)
| NoMatchingFormat Format
-- ^ producer declares a string/number format, consumer declares none or a different format (TODO: improve via regex #32)
| NoMatchingMaxLength Integer
-- ^ producer declares a maximum length of the string ($1), consumer doesn't.
| MatchingMaxLengthWeak Integer Integer
-- ^ producer declares a maximum length of the string ($1), consumer declares a weaker (higher) limit ($2)
| NoMatchingMinLength Integer
-- ^ producer declares a minimum length of the string ($1), consumer doesn't.
| MatchingMinLengthWeak Integer Integer
-- ^ producer declares a minimum length of the string ($1), consumer declares a weaker (lower) limit ($2)
| NoMatchingPattern Pattern
-- ^ producer declares the string value must matrix a regex ($1), consumer doesn't declare or declares different regex (TODO: #32)
| NoMatchingItems
-- ^ producer declares the items of an array must satisfy some condition, consumer doesn't
| NoMatchingMaxItems Integer
-- ^ producer declares a maximum length of the array ($1), consumer doesn't.
| MatchingMaxItemsWeak Integer Integer
-- ^ producer declares a maximum length of the array ($1), consumer declares a weaker (higher) limit ($2)
| NoMatchingMinItems Integer
-- ^ producer declares a minimum length of the array ($1), consumer doesn't.
| MatchingMinItemsWeak Integer Integer
-- ^ producer declares a minimum length of the array ($1), consumer declares a weaker (lower) limit ($2)
| NoMatchingUniqueItems
-- ^ producer declares that items must be unique, consumer doesn't
| NoMatchingProperties
-- ^ producer declares the properties of an object must satisfy some condition, consumer doesn't
| UnexpectedProperty Text
-- ^ producer allows a property that is not allowed in the consumer
| PropertyNowRequired Text
-- ^ consumer requires a property that is not required/allowed in the consumer
| NoAdditionalProperties
-- ^ producer allows additional properties, consumer doesn't
| NoMatchingMaxProperties Integer
-- ^ producer declares a maximum number of properties in the object ($1), consumer doesn't.
| MatchingMaxPropertiesWeak Integer Integer
-- ^ producer declares a maximum number of properties in the object ($1), consumer declares a weaker (higher) limit ($2)
| NoMatchingMinProperties Integer
-- ^ producer declares a minimum number of properties in the object ($1), consumer doesn't.
| MatchingMinPropertiesWeak Integer Integer
-- ^ producer declares a minimum number of properties in the object ($1), consumer declares a weaker (lower) limit ($2)
| NoMatchingCondition [SomeCondition]
-- ^ 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)
| NoContradiction
-- ^ 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)
= -- | producer produces a specific value ($1), consumer has a condition that is not satisfied by said value
EnumDoesntSatisfy A.Value
| -- | consumer only expects a specific value which the producer does not produce.
NoMatchingEnum A.Value
| -- | consumer declares a maximum numeric value ($1), producer doesn't
NoMatchingMaximum (Bound Scientific)
| -- | consumer declares a maximum numeric value ($1), producer declares a weaker (higher) limit ($2)
MatchingMaximumWeak (ProdCons (Bound Scientific))
| -- | consumer declares a minimum numeric value, producer doesn't
NoMatchingMinimum (Bound Scientific)
| -- | consumer declares a minimum numeric value ($1), producer declares a weaker (lower) limit ($2)
MatchingMinimumWeak (ProdCons (Bound Scientific))
| -- | consumer declares that the numeric value must be a multiple of $1, producer doesn't
NoMatchingMultipleOf Scientific
| -- | consumer declares that the numeric value must be a multiple of $1, producer declares a weaker condition (multiple of $2)
MatchingMultipleOfWeak (ProdCons Scientific)
| -- | consumer declares a string/number format, producer declares none or a different format (TODO: improve via regex #32)
NoMatchingFormat Format
| -- | consumer declares a maximum length of the string ($1), producer doesn't.
NoMatchingMaxLength Integer
| -- | consumer declares a maximum length of the string ($1), producer declares a weaker (higher) limit ($2)
MatchingMaxLengthWeak (ProdCons Integer)
| -- | consumer declares a minimum length of the string ($1), producer doesn't.
NoMatchingMinLength Integer
| -- | consumer declares a minimum length of the string ($1), producer declares a weaker (lower) limit ($2)
MatchingMinLengthWeak (ProdCons Integer)
| -- | consumer declares the string value must matrix a regex ($1), producer doesn't declare or declares different regex (TODO: #32)
NoMatchingPattern Pattern
| -- | consumer declares the items of an array must satisfy some condition, producer doesn't
NoMatchingItems
| -- | consumer declares a maximum length of the array ($1), producer doesn't.
NoMatchingMaxItems Integer
| -- | consumer declares a maximum length of the array ($1), producer declares a weaker (higher) limit ($2)
MatchingMaxItemsWeak (ProdCons Integer)
| -- | consumer declares a minimum length of the array ($1), producer doesn't.
NoMatchingMinItems Integer
| -- | consumer declares a minimum length of the array ($1), producer declares a weaker (lower) limit ($2)
MatchingMinItemsWeak (ProdCons Integer)
| -- | consumer declares that items must be unique, producer doesn't
NoMatchingUniqueItems
| -- | consumer declares the properties of an object must satisfy some condition, producer doesn't
NoMatchingProperties
| -- | producer allows a property that is not allowed in the consumer
UnexpectedProperty Text
| -- | consumer requires a property that is not required/allowed in the producer
PropertyNowRequired Text
| -- | producer allows additional properties, consumer doesn't
NoAdditionalProperties
| -- | consumer declares a maximum number of properties in the object ($1), producer doesn't.
NoMatchingMaxProperties Integer
| -- | consumer declares a maximum number of properties in the object ($1), producer declares a weaker (higher) limit ($2)
MatchingMaxPropertiesWeak (ProdCons Integer)
| -- | consumer declares a minimum number of properties in the object ($1), producer doesn't.
NoMatchingMinProperties Integer
| -- | consumer declares a minimum number of properties in the object ($1), producer declares a weaker (lower) limit ($2)
MatchingMinPropertiesWeak (ProdCons Integer)
| -- | 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)
NoMatchingCondition [SomeCondition]
| -- | 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)
NoContradiction
deriving stock (Eq, Ord, Show)
issueIsUnsupported _ = False
describeIssue (EnumDoesntSatisfy v) = para "The following enum value will yield an error:" <> showJSONValue v
describeIssue (NoMatchingEnum v) = para "The following enum value is not supported:" <> showJSONValue v
describeIssue (NoMatchingMaximum b) = para $ "Unexpected upper bound " <> showBound b <> "."
describeIssue (MatchingMaximumWeak (ProdCons p c)) = para $ "Expected upper bound " <> showBound p <> " but but found " <> showBound c <> "."
describeIssue (NoMatchingMinimum b) = para $ "Unexpected lower bound " <> showBound b <> "."
describeIssue (MatchingMinimumWeak (ProdCons p c)) = para $ "Expected lower bound " <> showBound p <> " but but found " <> showBound c <> "."
describeIssue (NoMatchingMultipleOf n) = para $ "Didn't expect the value to be a multiple of " <> show' n <> " but it was."
describeIssue (MatchingMultipleOfWeak (ProdCons p c)) = para $ "Expected the value to be a multiple of " <> show' p <> " but found a multiple of " <> show' c <> "."
describeIssue (NoMatchingFormat f) = para $ "Unexpected format: " <> code f <> "."
describeIssue (NoMatchingMaxLength n) = para $ "Unexpected maximum length of the string " <> show' n <> "."
describeIssue (MatchingMaxLengthWeak (ProdCons p c)) = para $ "Expected the maximum length of the string to be " <> show' p <> "but it was " <> show' c <> "."
describeIssue (NoMatchingMinLength n) = para $ "Unexpected minimum length of the string " <> show' n <> "."
describeIssue (MatchingMinLengthWeak (ProdCons p c)) = para $ "Expected the minimum length of the string to be " <> show' p <> "but it was " <> show' c <> "."
describeIssue (NoMatchingPattern p) = para "Unexpected pattern (regular expression): " <> codeBlock p
describeIssue NoMatchingItems = para "Couldn't find any matching items."
describeIssue (NoMatchingMaxItems n) = para $ "Unexpected maximum length of the array " <> show' n <> "."
describeIssue (MatchingMaxItemsWeak (ProdCons p c)) = para $ "Expected the maximum length of the array to be " <> show' p <> "but it was " <> show' c <> "."
describeIssue (NoMatchingMinItems n) = para $ "Unexpected minimum length of the array " <> show' n <> "."
describeIssue (MatchingMinItemsWeak (ProdCons p c)) = para $ "Expected the minimum length of the array to be " <> show' p <> "but it was " <> show' c <> "."
describeIssue NoMatchingUniqueItems = para "Didn't expect the items to be unique, but they were."
describeIssue NoMatchingProperties = para "Couldn't find matching properties."
describeIssue (UnexpectedProperty p) = para $ "Expected the property " <> code p <> " to be allowed, but it wasn't."
describeIssue (PropertyNowRequired p) = para $ "Don't have a required property " <> code p <> "."
describeIssue NoAdditionalProperties = para "Expected additional properties to be allowed, but they weren't."
describeIssue (NoMatchingMaxProperties n) = para $ "Unexpected maximum number of properties " <> show' n <> "."
describeIssue (MatchingMaxPropertiesWeak (ProdCons p c)) = para $ "Expected the maximum number of properties to be " <> show' p <> "but it was " <> show' c <> "."
describeIssue (NoMatchingMinProperties n) = para $ "Unexpected minimum number of properties " <> show' n <> "."
describeIssue (MatchingMinPropertiesWeak (ProdCons p c)) = para $ "Expected the minimum number of properties to be " <> show' p <> "but it was " <> show' c <> "."
describeIssue (NoMatchingCondition conds) =
para "Expected the following conditions to hold, but they didn't:"
<> bulletList ((\(SomeCondition c) -> showCondition c) <$> conds)
describeIssue NoContradiction = para "Expected the type to be allowed, but it wasn't."
showJSONValue :: A.Value -> Blocks
showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
showBound :: Show a => Bound a -> Inlines
showBound (Inclusive x) = show' x <> " inclusive"
showBound (Exclusive x) = show' x <> " exclusive"
show' :: Show x => x -> Inlines
show' = str . T.pack . show
instance Issuable 'SchemaLevel where
data Issue 'SchemaLevel
= NotSupported Text
-- ^ Some (openapi-supported) feature that we do not support was encountered in the schema
| InvalidSchema Text
-- ^ The schema is actually invalid
| UnguardedRecursion
-- ^ The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
= -- | Some (openapi-supported) feature that we do not support was encountered in the schema
NotSupported Text
| -- | The schema is actually invalid
InvalidSchema Text
| -- | The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
UnguardedRecursion
deriving stock (Eq, Ord, Show)
issueIsUnsupported _ = True
describeIssue (NotSupported i) =
para (emph "Encountered a feature that OpenApi Diff does not support: " <> text i <> ".")
describeIssue (InvalidSchema i) =
para (emph "The schema is invalid: " <> text i <> ".")
describeIssue UnguardedRecursion =
para "Encountered recursion that is too complex for OpenApi Diff to untangle."
instance Behavable 'SchemaLevel 'TypedSchemaLevel where
data Behave 'SchemaLevel 'TypedSchemaLevel
= OfType JsonType
deriving stock (Eq, Ord, Show)
describeBehaviour (OfType t) = describeJSONType t
describeJSONType :: JsonType -> Inlines
describeJSONType = \case
Null -> "Null"
Boolean -> "Boolean"
Number -> "Number"
String -> "String"
Array -> "Array"
Object -> "Object"
instance Behavable 'TypedSchemaLevel 'SchemaLevel where
data Behave 'TypedSchemaLevel 'SchemaLevel
= InItems
@ -1025,6 +1126,10 @@ instance Behavable 'TypedSchemaLevel 'SchemaLevel where
| InAdditionalProperty
deriving stock (Eq, Ord, Show)
describeBehaviour InItems = "Items"
describeBehaviour (InProperty p) = "Property " <> code p
describeBehaviour InAdditionalProperty = "Additional properties"
instance Subtree Schema where
type SubtreeLevel Schema = 'SchemaLevel
type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]

10
src/OpenAPI/Checker/Validate/Server.hs
View File

@ -28,6 +28,7 @@ import OpenAPI.Checker.Common
import OpenAPI.Checker.Paths
import OpenAPI.Checker.Subtree
import OpenAPI.Checker.Validate.MediaTypeObject
import Text.Pandoc.Builder
import Prelude as P
tracedParsedServerUrlParts
@ -45,6 +46,8 @@ instance Behavable 'OperationLevel 'ServerLevel where
= InServer Text
deriving stock (Eq, Ord, Show)
describeBehaviour (InServer n) = "Server " <> code n
instance Subtree [Server] where
type SubtreeLevel [Server] = 'OperationLevel
type CheckEnv [Server] = '[]
@ -131,6 +134,13 @@ instance Issuable 'ServerLevel where
| ServerNotMatched
deriving stock (Eq, Ord, Show)
issueIsUnsupported _ = False
describeIssue (EnumValueNotConsumed _ v) =
para $ "Enum value " <> code v <> " is not supported."
describeIssue (ConsumerNotOpen _) =
para $ "Expected a variable to be open (any value), but it wasn't."
describeIssue (ServerVariableNotDefined k) =
para $ "Variable " <> code k <> " is not defined."
describeIssue ServerNotMatched = para $ "Couldn't find a matching server."
instance Subtree ProcessedServer where
type SubtreeLevel ProcessedServer = 'ServerLevel

2
stack.yaml
View File

@ -1 +1 @@
resolver: lts-17.12
resolver: nightly-2021-06-01

8
stack.yaml.lock
View File

@ -6,7 +6,7 @@
packages: []
snapshots:
- completed:
size: 567669
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/12.yaml
sha256: facf6cac73b22a83ca955b580a98a7a09ed71f8f974c7a55d28e608c23e689a9
original: lts-17.12
size: 587963
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/6/1.yaml
sha256: 6f13285c82266d1d06f7f68366a5190dcbc6758ae8806813005cf56daa6bb9be
original: nightly-2021-06-01

6
test/Spec.hs
View File

@ -9,8 +9,4 @@ main = defaultMain =<< tests
tests :: IO TestTree
tests = do
goldenReportTree <- Spec.Golden.TraceTree.tests
return . localOption (mkTimeout 1000000) $
testGroup
"Golden tests"
[ goldenReportTree
]
return . localOption (mkTimeout 1000000) $ goldenReportTree

48
test/Spec/Golden/Extra.hs
View File

@ -8,15 +8,11 @@ where
import Control.Lens
import Control.Monad
import Data.Aeson hiding (Result)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Yaml as Yaml
import OpenAPI.Checker.Subtree
import System.Directory
import System.FilePath
import Test.Tasty
import Test.Tasty.Golden
import Test.Tasty.Providers
data TestInput t
= TestInputNode TestName [TestInput t]
@ -54,62 +50,40 @@ getGoldenInputsUniform
getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)
goldenInputsTree
:: (Each s t (FilePath, FilePath -> IO a) a, ToJSON x, HasUnsupportedFeature x)
:: (Each s t (FilePath, FilePath -> IO a) a)
=> TestName
-> FilePath -- ^ Root path
-> FilePath -- ^ Name of golden file
-> s
-> (t -> x)
-> (t -> IO BSL.ByteString)
-> IO TestTree
goldenInputsTree name filepath golden inp f = do
runTestInputTree golden f <$> getGoldenInputs name filepath inp
runTestInputTree
:: (ToJSON x, HasUnsupportedFeature x)
=> FilePath
-> (t -> x)
:: FilePath
-> (t -> IO BSL.ByteString)
-> TestInput t
-> TestTree
runTestInputTree golden f (TestInputNode name rest) =
testGroup name (runTestInputTree golden f <$> rest)
runTestInputTree golden f (TestInputLeaf name t path)
| testSupported name =
goldenVsStringDiff
name
(\ref new -> ["diff", "-u", ref, new])
(path </> golden)
(pure . BSL.fromStrict . Yaml.encode . f $ t)
runTestInputTree _ f (TestInputLeaf name t _) =
reportResult name $
if hasUnsupportedFeature (f t)
then testPassed "Feature unsupported"
else testFailed "Unexpected feature support"
reportResult :: TestName -> Result -> TestTree
reportResult name result = singleTest name $ SimpleTestReporter result
newtype SimpleTestReporter = SimpleTestReporter Result
instance IsTest SimpleTestReporter where
run _ (SimpleTestReporter result) _ = return result
testOptions = mempty
testSupported :: TestName -> Bool
testSupported ('x' : ' ' : _) = False
testSupported _ = True
runTestInputTree golden f (TestInputLeaf name t path) =
goldenVsStringDiff
name
(\ref new -> ["diff", "-u", ref, new])
(path </> golden)
(f t)
goldenInputsTreeUniform
:: ( Each t h (FilePath, FilePath -> IO a) a
, ToJSON x
, Each s t FilePath (FilePath, FilePath -> IO a)
, HasUnsupportedFeature x
)
=> String
-> FilePath -- ^ Root path
-> FilePath -- ^ Name of golden file
-> s
-> (FilePath -> IO a)
-> (h -> x)
-> (h -> IO BSL.ByteString)
-> IO TestTree
goldenInputsTreeUniform name filepath golden inp h =
goldenInputsTree name filepath golden (inp & each %~ (,h))

58
test/Spec/Golden/TraceTree.hs
View File

@ -4,26 +4,56 @@ module Spec.Golden.TraceTree
where
import Control.Category
import Control.Exception
import qualified Data.ByteString.Lazy as BSL
import Data.Default
import Data.HList
import Data.OpenApi
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import qualified Data.Yaml as Yaml
import OpenAPI.Checker.Subtree
import OpenAPI.Checker.Behavior
import OpenAPI.Checker.Paths
import OpenAPI.Checker.PathsPrefixTree
import OpenAPI.Checker.Report
import OpenAPI.Checker.Subtree
import OpenAPI.Checker.Validate.OpenApi ()
import Spec.Golden.Extra
import Test.Tasty (TestTree)
import Test.Tasty (TestTree, testGroup)
import Text.Pandoc.Class
import Text.Pandoc.Writers
import Prelude hiding (id, (.))
tests :: IO TestTree
tests =
goldenInputsTreeUniform
"Golden TraceTree"
"test/golden/common"
"trace-tree.yaml"
("a.yaml", "b.yaml")
Yaml.decodeFileThrow
(runCompatFormula . checkCompatibility HNil Root . toPC)
where
toPC (client, server) = ProdCons
{ producer = traced (step ClientSchema) client
, consumer = traced (step ServerSchema) server
tests = do
traceTreeTests <-
goldenInputsTreeUniform
"TraceTree"
"test/golden/common"
"trace-tree.yaml"
("a.yaml", "b.yaml")
Yaml.decodeFileThrow
(pure . BSL.fromStrict . Yaml.encode . runChecker)
reportTests <-
goldenInputsTreeUniform
"Report"
"test/golden/common"
"report.md"
("a.yaml", "b.yaml")
Yaml.decodeFileThrow
(runPandoc . writeMarkdown def . generateReport . runChecker)
return $ testGroup "Golden tests" [traceTreeTests, reportTests]
runPandoc :: PandocPure Text -> IO BSL.ByteString
runPandoc = either throwIO (pure . BSL.fromStrict . T.encodeUtf8) . runPure
runChecker :: (OpenApi, OpenApi) -> Either (PathsPrefixTree Behave AnIssue 'APILevel) ()
runChecker = runCompatFormula . checkCompatibility HNil Root . toPC
where
toPC (c, s) =
ProdCons
{ producer = traced (step ClientSchema) c
, consumer = traced (step ServerSchema) s
}

1
test/golden/common/enum-anyof/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

1
test/golden/common/id/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

1
test/golden/common/json/recursive/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

7
test/golden/common/maximum-lowered/report.md Normal file
View File

@ -0,0 +1,7 @@
# **POST** /test
## JSON Request
### Number
Expected upper bound 3.0 inclusive but but found 2.0 inclusive.

5
test/golden/common/maximum-lowered/trace-tree.yaml
View File

@ -1,7 +1,8 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
InRequest:
InPayload:
PayloadSchema:
OfType Number: MatchingMaximumWeak (Inclusive 2.0) (Inclusive 3.0)
OfType Number: MatchingMaximumWeak (ProdCons {producer = Inclusive 3.0,
consumer = Inclusive 2.0})

5
test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/report.md Normal file
View File

@ -0,0 +1,5 @@
# **POST** /test
## Parameter test1
Expected that an empty parameter is allowed, but it isn't.

2
test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/trace-tree.yaml
View File

@ -1,4 +1,4 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
InParam "test1": ParamEmptinessIncompatible

1
test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

9
test/golden/common/pathItem/operation/parameters/change/report.md Normal file
View File

@ -0,0 +1,9 @@
# **POST** /test
## Parameter test
### JSON Schema
#### String
Expected the type to be allowed, but it wasn't.

2
test/golden/common/pathItem/operation/parameters/change/trace-tree.yaml
View File

@ -1,5 +1,5 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
InParam "test":
InParamSchema:

1
test/golden/common/pathItem/operation/parameters/required/false/add/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

1
test/golden/common/pathItem/operation/parameters/required/false/del/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

1
test/golden/common/pathItem/operation/parameters/required/reset/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

5
test/golden/common/pathItem/operation/parameters/required/set/report.md Normal file
View File

@ -0,0 +1,5 @@
# **POST** /test
## Parameter test1
Expected the parameter to be optional, but it is required.

2
test/golden/common/pathItem/operation/parameters/required/set/trace-tree.yaml
View File

@ -1,4 +1,4 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
InParam "test1": ParamRequired

3
test/golden/common/pathItem/operation/parameters/required/true/add/report.md Normal file
View File

@ -0,0 +1,3 @@
# **POST** /test
Parameter test2 is not supported.

2
test/golden/common/pathItem/operation/parameters/required/true/add/trace-tree.yaml
View File

@ -1,3 +1,3 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod: ParamNotMatched "test2"

1
test/golden/common/pathItem/operation/parameters/required/true/del/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

1
test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

7
test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md Normal file
View File

@ -0,0 +1,7 @@
# **POST** /test
## JSON Request
### String
Expected the type to be allowed, but it wasn't.

2
test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/trace-tree.yaml
View File

@ -1,5 +1,5 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
InRequest:
InPayload:

6
test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/report.md Normal file
View File

@ -0,0 +1,6 @@
# **POST** /test
## Request
Couldn't find a request body for media type
`application/x-www-form-urlencoded`.

2
test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/trace-tree.yaml
View File

@ -1,4 +1,4 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
InRequest: RequestMediaTypeNotFound application/x-www-form-urlencoded

1
test/golden/common/pathItem/operation/requestBody/required/reset/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

5
test/golden/common/pathItem/operation/requestBody/required/set/report.md Normal file
View File

@ -0,0 +1,5 @@
# **POST** /test
## Request
Expected the request body to be optional, but found it to be required.

2
test/golden/common/pathItem/operation/requestBody/required/set/trace-tree.yaml
View File

@ -1,4 +1,4 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
InRequest: RequestBodyRequired

3
test/golden/common/pathItem/operation/responses/add/report.md Normal file
View File

@ -0,0 +1,3 @@
# **POST** /test
Reponse code 500 is not supported.

2
test/golden/common/pathItem/operation/responses/add/trace-tree.yaml
View File

@ -1,3 +1,3 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod: ResponseCodeNotFound 500

1
test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

5
test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/report.md Normal file
View File

@ -0,0 +1,5 @@
# **POST** /test
## Response code 200
Couldn't find header `Test2`.

2
test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/trace-tree.yaml
View File

@ -1,4 +1,4 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
WithStatusCode 200: ResponseHeaderMissing "Test2"

1
test/golden/common/pathItem/operation/responses/change/headers/optional/add/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

1
test/golden/common/pathItem/operation/responses/change/headers/optional/del/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

6
test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/report.md Normal file
View File

@ -0,0 +1,6 @@
# **POST** /test
## Response code 200
Couldn't find reponse for media type
`application/x-www-form-urlencoded`.

2
test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/trace-tree.yaml
View File

@ -1,4 +1,4 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
WithStatusCode 200: ResponseMediaTypeMissing application/x-www-form-urlencoded

7
test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md Normal file
View File

@ -0,0 +1,7 @@
# **POST** /test
## JSON Response – 200
### Number
Expected the type to be allowed, but it wasn't.

2
test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/trace-tree.yaml
View File

@ -1,5 +1,5 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
WithStatusCode 200:
ResponsePayload:

1
test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

1
test/golden/common/pathItem/operation/responses/del/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

13
test/golden/common/property-removed/report.md Normal file
View File

@ -0,0 +1,13 @@
# **POST** /test
## JSON Request
### Object
Expected the property `property2` to be allowed, but it wasn't.
## JSON Response – 200
### Object
Don't have a required property `property2`.

2
test/golden/common/property-removed/trace-tree.yaml
View File

@ -1,5 +1,5 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
InRequest:
InPayload:

7
test/golden/common/property-required/report.md Normal file
View File

@ -0,0 +1,7 @@
# **POST** /test
## JSON Request
### Object
Don't have a required property `property2`.

2
test/golden/common/property-required/trace-tree.yaml
View File

@ -1,5 +1,5 @@
Left:
AtPath (ProdCons {producer = "/test", consumer = "/test"}):
AtPath "/test":
InOperation PostMethod:
InRequest:
InPayload:

1
test/golden/common/recursive/report.md Normal file
View File

@ -0,0 +1 @@
# No breaking changes found ✨

15
test/golden/common/security-scheme/report.md Normal file
View File

@ -0,0 +1,15 @@
# **POST** /oauth/check
## Security requirement 0
### oauth
Security scheme not met.
# **GET** /oauth/sign\_out
## Security requirement 1
### oauth
Security scheme not met.

10
test/golden/common/security-scheme/trace-tree.yaml
View File

@ -1,9 +1,9 @@
Left:
AtPath (ProdCons {producer = "/oauth/check", consumer = "/oauth/check"}):
InOperation PostMethod:
SecurityRequirementStep 0:
SecuritySchemeStep "oauth": SecuritySchemeNotMatched
AtPath (ProdCons {producer = "/oauth/sign_out", consumer = "/oauth/sign_out"}):
AtPath "/oauth/sign_out":
InOperation GetMethod:
SecurityRequirementStep 1:
SecuritySchemeStep "oauth": SecuritySchemeNotMatched
AtPath "/oauth/check":
InOperation PostMethod:
SecurityRequirementStep 0:
SecuritySchemeStep "oauth": SecuritySchemeNotMatched

11
test/golden/common/servers/report.md Normal file
View File

@ -0,0 +1,11 @@
# **GET** /pets
## Server `http://missing.url`
Couldn't find a matching server.
## Server `http://{x}variable.path/{y}/{openVariable1}/{openVariable2}`
Enum value `a` is not supported.
Expected a variable to be open (any value), but it wasn't.

2
test/golden/common/servers/trace-tree.yaml
View File

@ -1,5 +1,5 @@
Left:
AtPath (ProdCons {producer = "/pets", consumer = "/pets"}):
AtPath "/pets":
InOperation GetMethod:
InServer "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":
- EnumValueNotConsumed 1 "a"

5
test/golden/common/unguarded-recursive/report.md Normal file
View File

@ -0,0 +1,5 @@
# **GET** /api/foo
## JSON Response – 200
Encountered recursion that is too complex for OpenApi Diff to untangle.

2
test/golden/common/unguarded-recursive/trace-tree.yaml
View File

@ -1,5 +1,5 @@
Left:
AtPath (ProdCons {producer = "/api/foo", consumer = "/api/foo"}):
AtPath "/api/foo":
InOperation GetMethod:
WithStatusCode 200:
ResponsePayload: