diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,9 @@
+# Changelog
+
+`comparest` uses [PVP Versioning][1].
+
+## 0.1.0.0
+
+* Initial release.
+
+[1]: https://pvp.haskell.org
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2021 Typeable
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,332 @@
+# compaREST
+
+[](https://hackage.haskell.org/package/comparest)
+[](http://stackage.org/lts/package/comparest)
+[](http://stackage.org/nightly/package/comparest)
+[](LICENSE)
+
+Compatibility checker for OpenAPI
+
+## Using compaREST in Github Actions
+
+Add the following step to your Github Actions workflow:
+
+```yaml
+- uses: typeable/comparest
+ if: ${{ github.event_name == 'pull_request' }}
+ with:
+ old: old-openapi.yaml
+ new: new-openapi.yaml
+```
+
+The `new` and `old` values should be paths to your OpenAPI specifications you want to compare.
+
+You will get something like this in your pull requests:
+
+
+
+For more detail please see our [integration guide](docs/Integration_guide.md).
+
+## An example
+
+### Your situation
+
+You are developing a very important server with a REST API. You have clients who use your API that you do not control. Say, you are also developing a mobile app that uses your API and you can't force someone to update to the latest version. (Or you prefer not to for UX reasons.)
+
+You have recently released version 1.0 and things are going great: user are downloading your app, servers are processing requests.
+
+You describe your API in a file `api-1.0.0.yaml`:
+
+```yaml
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: https://example.com
+paths:
+ /pets:
+ get:
+ parameters:
+ - name: limit
+ in: query
+ required: false
+ schema:
+ type: integer
+ maximum: 20
+ responses:
+ "200":
+ description: ""
+ headers:
+ x-next:
+ schema:
+ type: string
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pets"
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pet"
+ responses:
+ "201":
+ description: ""
+components:
+ schemas:
+ Pet:
+ type: object
+ required:
+ - id
+ - name
+ properties:
+ id:
+ type: integer
+ name:
+ type: string
+ minLength: 3
+ maxLength: 10
+ Pets:
+ type: array
+ items:
+ $ref: "#/components/schemas/Pet"
+```
+
+### Evolving your product
+
+Enthused over your initial success you hurry to release a new and improved version of your API and mobile app.
+
+After a round of very intense programming you take a look at your new `api-1.1.0.yaml`:
+
+```yaml
+openapi: "3.0.0"
+info:
+ version: 1.1.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: https://example.com
+paths:
+ /pets:
+ get:
+ parameters:
+ - name: limit
+ in: query
+ required: false
+ schema:
+ type: integer
+ maximum: 30
+ responses:
+ "200":
+ description: ""
+ headers:
+ x-next:
+ schema:
+ type: string
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pets"
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pet"
+ responses:
+ "201":
+ description: ""
+components:
+ schemas:
+ Pet:
+ type: object
+ required:
+ - id
+ - name
+ properties:
+ id:
+ type: integer
+ name:
+ type: string
+ minLength: 1
+ maxLength: 15
+ weight:
+ type: integer
+ Pets:
+ type: array
+ items:
+ $ref: "#/components/schemas/Pet"
+```
+
+Looking at the very large and complex API description, you grow more and more concerned that your old mobile app might stop working when you update the server. But the spec is too large and too complex to reasonably assess this manually.
+
+### Assessing compatibility automatically
+
+Luckily, you have access to compaREST which can programmatically analyze your APIs and determine what, if anything, breaks compatibility and what doesn't.
+
+You can call it, passing the API your client will be aware of, and the API your server will serve like so:
+
+```bash
+docker run --rm -v $(pwd):/data:rw typeable/comparest --client /data/api-1.0.0.yaml --server /data/api-1.1.0.yaml --output /data/report.md
+```
+
+Running this command will output a file `report.md`, containing the compatibility report between the two APIs:
+
+> # Summary
+>
+> | [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+> |------------------------------------------|--------------------------------------------------|
+> | 5 | 6 |
+>
+> # ❌ Breaking changes
+>
+> ## **GET** /pets
+>
+> ### ⬅️☁️ JSON Response – 200
+>
+> #### `$[*].name(String)`
+>
+> 1. Maximum length of the string changed from 10 to 15.
+>
+> 2. Minimum length of the string changed from 3 to 1.
+>
+> ## **POST** /pets
+>
+> ### ➡️☁️ JSON Request
+>
+> #### `$.weight`
+>
+> 1. Values are now limited to the following types:
+>
+> - Number
+>
+> 2. The property was previously implicitly described by the catch-all
+> "additional properties" case. It is now explicitly defined.
+>
+> #### `$.weight(Number)`
+>
+> Value is now a multiple of 1.0.
+>
+> # ⚠️ Non-breaking changes
+>
+> ## **GET** /pets
+>
+> ### Parameter limit
+>
+> #### JSON Schema
+>
+> ##### `$(Number)`
+>
+> Upper bound changed from 20.0 inclusive to 30.0 inclusive.
+>
+> ### ⬅️☁️ JSON Response – 200
+>
+> #### `$[*].weight`
+>
+> 1. Values are now limited to the following types:
+>
+> - Number
+>
+> 2. The property was previously implicitly described by the catch-all
+> "additional properties" case. It is now explicitly defined.
+>
+> #### `$[*].weight(Number)`
+>
+> Value is now a multiple of 1.0.
+>
+> ## **POST** /pets
+>
+> ### ➡️☁️ JSON Request
+>
+> #### `$.name(String)`
+>
+> 1. Maximum length of the string changed from 10 to 15.
+>
+> 2. Minimum length of the string changed from 3 to 1.
+
+You now know exactly in what situations and in what way your 1.0 version of the app will break if you deploy your 1.1 version of the server.
+
+### Additional formats
+
+You can also produce a self-contained HTML report that you can open in your browser by simply omitting the file extension of the output file:
+
+```bash
+docker run --rm -v $(pwd):/data:rw typeable/comparest --client /data/api-1.0.0.yaml --server /data/api-1.1.0.yaml --output /data/report
+```
+
+## CLI docs
+
+For more detail please see our [user guide](docs/User_guide.md).
+
+```
+Usage: comparest (-c|--client ARG) (-s|--server ARG)
+ [--silent | --only-breaking | --all] [-o|--output ARG]
+ [--folding-block-quotes-style | --header-style]
+ [--signal-exit-code]
+ A tool to check compatibility between two OpenAPI specifications.
+
+ Usage examples
+
+ Compare files old.yaml with new.yaml and output the resulting report to
+ stdout:
+
+ comparest -c old.yaml -s new.yaml
+
+ Only output breaking changes and write a styled HTML report to file
+ report.html:
+
+ comparest -c old.yaml -s new.yaml --only-breaking -o report
+
+ Don't output anything, only fail if there are breaking changes:
+
+ comparest -c old.json -s new.json --silent
+
+ Write full report suitable for embedding into a GitHub comment to
+ report.html:
+
+ comparest -c old.json -s new.json --folding-block-quotes-style -o report.html
+
+Available options:
+ -h,--help Show this help text
+ -c,--client ARG A path to the file containing the specification that
+ will be used for the client of the API. Can be either
+ a YAML or JSON file.
+ -s,--server ARG A path to the file containing the specification that
+ will be used for the server of the API. Can be either
+ a YAML or JSON file.
+ --silent Silence all output. Only makes sense in combination
+ with --signal-exit-code.
+ --only-breaking Only report breaking changes in the output.
+ --all Report both incompatible and compatible changes.
+ Compatible changes will not trigger a failure exit
+ code.
+ -o,--output ARG The file path where the output should be written. If
+ the option is omitted the result will be written to
+ stdout.
+
+ The file extension is used to determine the type of
+ the output file.
+
+ Supports many formats such as markdown, html, rtf,
+ doc, txt, rst, and many more.
+
+ Leave out the extension to produce a self-contained
+ HTML report with styling.
+ --folding-block-quotes-style
+ The report tree is structured using summary/detail
+ HTML elements and indented using block quotes. This
+ style renders well on GitHub.Intended for HTML output
+ format. Markdown has rendering bugs on GitHub.
+ --header-style The report tree is structured using increasing levels
+ of headers.
+ --signal-exit-code Signal API compatibility with the exit code.
+
+ Exit with 0 if there are no breaking changes.
+ Exit with 1 if there are breaking changes.
+ Exit with 2 if could not determine compatibility.
+```
diff --git a/app/Data/OpenApi/Compare/Options.hs b/app/Data/OpenApi/Compare/Options.hs
new file mode 100644
--- /dev/null
+++ b/app/Data/OpenApi/Compare/Options.hs
@@ -0,0 +1,134 @@
+module Data.OpenApi.Compare.Options
+ ( Options (..),
+ OutputMode (..),
+ parseOptions,
+ )
+where
+
+import Data.OpenApi.Compare.Report
+import GHC.Generics (Generic)
+import Options.Applicative
+import Options.Applicative.Help hiding (fullDesc)
+
+parseOptions :: IO Options
+parseOptions = customExecParser (prefs $ showHelpOnError) optionsParserInfo
+
+data Options = Options
+ { clientFile :: FilePath
+ , serverFile :: FilePath
+ , -- | 'Nothing' means "don't produce any output"
+ mode :: Maybe ReportMode
+ , outputMode :: OutputMode
+ , reportTreeStyle :: ReportTreeStyle
+ , signalExitCode :: Bool
+ }
+ deriving stock (Generic)
+
+data OutputMode = StdoutMode | FileMode FilePath
+
+optionsParserInfo :: ParserInfo Options
+optionsParserInfo =
+ info
+ (helper <*> optionsParser)
+ ( fullDesc
+ <> header "CompaREST"
+ <> progDescDoc
+ ( Just $
+ par "A tool to check compatibility between two OpenAPI specifications."
+ <$$> hardline <> par "Usage examples" <> hardline
+ <$$> indent
+ 4
+ ( par "Compare files old.yaml with new.yaml and output the resulting report to stdout:"
+ <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml"
+ <$$> hardline <> par "Only output breaking changes and write a styled HTML report to file report.html:"
+ <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml --only-breaking -o report"
+ <$$> hardline <> par "Don't output anything, only fail if there are breaking changes:"
+ <$$> hardline <> indent 4 "comparest -c old.json -s new.json --silent"
+ <$$> hardline <> par "Write full report suitable for embedding into a GitHub comment to report.html:"
+ <$$> hardline <> indent 4 "comparest -c old.json -s new.json --folding-block-quotes-style -o report.html"
+ )
+ )
+ )
+
+optionsParser :: Parser Options
+optionsParser =
+ Options
+ <$> strOption
+ ( short 'c'
+ <> long "client"
+ <> help
+ "A path to the file containing the specification that will be \
+ \used for the client of the API. Can be either a YAML or JSON file."
+ )
+ <*> strOption
+ ( short 's'
+ <> long "server"
+ <> help
+ "A path to the file containing the specification that will be \
+ \used for the server of the API. Can be either a YAML or JSON file."
+ )
+ <*> ( flag'
+ Nothing
+ ( long "silent"
+ <> help "Silence all output. Only makes sense in combination with --signal-exit-code."
+ )
+ <|> flag'
+ (Just OnlyErrors)
+ ( long "only-breaking"
+ <> help "Only report breaking changes in the output."
+ )
+ <|> flag'
+ (Just All)
+ ( long "all"
+ <> help
+ "Report both incompatible and compatible changes. \
+ \Compatible changes will not trigger a failure exit code."
+ )
+ <|> pure (Just All)
+ )
+ <*> ( ( FileMode
+ <$> strOption
+ ( short 'o' <> long "output"
+ <> helpDoc
+ ( Just $
+ par "The file path where the output should be written. If the option is omitted the result will be written to stdout."
+ <$$> hardline <> par "The file extension is used to determine the type of the output file."
+ <$$> hardline <> par "Supports many formats such as markdown, html, rtf, doc, txt, rst, and many more."
+ <$$> hardline <> par "Leave out the extension to produce a self-contained HTML report with styling."
+ )
+ )
+ )
+ <|> pure StdoutMode
+ )
+ <*> ( flag'
+ FoldingBlockquotesTreeStyle
+ ( long "folding-block-quotes-style"
+ <> help
+ "The report tree is structured using \
+ \summary/detail HTML elements and indented using \
+ \block quotes. This style renders well on GitHub.\
+ \Intended for HTML output format. Markdown has rendering \
+ \bugs on GitHub."
+ )
+ <|> flag'
+ HeadersTreeStyle
+ ( long "header-style"
+ <> help
+ "The report tree is structured using \
+ \increasing levels of headers."
+ )
+ <|> pure HeadersTreeStyle
+ )
+ <*> switch
+ ( long "signal-exit-code"
+ <> helpDoc
+ ( Just $
+ par "Signal API compatibility with the exit code."
+ <$$> hardline <> par "Exit with 0 if there are no breaking changes."
+ <$$> par "Exit with 1 if there are breaking changes."
+ <$$> par "Exit with 2 if could not determine compatibility."
+ )
+ )
+
+par :: String -> Doc
+par = foldr1 () . fmap string . words
diff --git a/app/FormatHeuristic.hs b/app/FormatHeuristic.hs
new file mode 100644
--- /dev/null
+++ b/app/FormatHeuristic.hs
@@ -0,0 +1,95 @@
+-- |
+-- Originally based on:
+-- https://github.com/jgm/pandoc/blob/master/src/Text/Pandoc/App/FormatHeuristics.hs
+module FormatHeuristic
+ ( formatFromFilePath,
+ )
+where
+
+import Data.ByteString.Lazy (ByteString)
+import Data.Char (toLower)
+import Data.Functor
+import qualified Data.Map as M
+import qualified Data.OpenApi.Compare.Report.Html.Template as Html
+import Data.Text (Text)
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TL
+import System.FilePath (takeExtension)
+import Text.DocTemplates.Internal
+import Text.Pandoc
+
+formatFromFilePath :: forall m. PandocMonad m => FilePath -> Maybe (Pandoc -> m ByteString, FilePath)
+formatFromFilePath x =
+ case takeExtension (map toLower x) of
+ ".adoc" -> fWithDefaultFile "asciidoc" def
+ ".asciidoc" -> fWithDefaultFile "asciidoc" def
+ ".context" -> fWithDefaultFile "context" def
+ ".ctx" -> fWithDefaultFile "context" def
+ ".db" -> fWithDefaultFile "docbook" def
+ ".doc" -> fWithDefaultFile "doc" def -- so we get an "unknown reader" error
+ ".docx" -> fWithDefaultFile "docx" def
+ ".dokuwiki" -> fWithDefaultFile "dokuwiki" def
+ ".epub" -> fWithDefaultFile "epub" def
+ ".fb2" -> fWithDefaultFile "fb2" def
+ ".htm" -> fWithDefaultFile "html" def
+ ".html" -> fWithDefaultFile "html" def
+ ".icml" -> fWithDefaultFile "icml" def
+ ".json" -> fWithDefaultFile "json" def
+ ".latex" -> fWithDefaultFile "latex" def
+ ".lhs" -> fWithDefaultFile "markdown+lhs" def
+ ".ltx" -> fWithDefaultFile "latex" def
+ ".markdown" -> markdown
+ ".mkdn" -> markdown
+ ".mkd" -> markdown
+ ".mdwn" -> markdown
+ ".mdown" -> markdown
+ ".Rmd" -> markdown
+ ".md" -> markdown
+ ".ms" -> fWithDefaultFile "ms" def
+ ".muse" -> fWithDefaultFile "muse" def
+ ".native" -> fWithDefaultFile "native" def
+ ".odt" -> fWithDefaultFile "odt" def
+ ".opml" -> fWithDefaultFile "opml" def
+ ".org" -> fWithDefaultFile "org" def
+ -- so we get an "unknown reader" error
+ ".pdf" -> fWithDefaultFile "pdf" def
+ ".pptx" -> fWithDefaultFile "pptx" def
+ ".roff" -> fWithDefaultFile "ms" def
+ ".rst" -> fWithDefaultFile "rst" def
+ ".rtf" -> fWithDefaultFile "rtf" def
+ ".s5" -> fWithDefaultFile "s5" def
+ ".t2t" -> fWithDefaultFile "t2t" def
+ ".tei" -> fWithDefaultFile "tei" def
+ ".tei.xml" -> fWithDefaultFile "tei" def
+ ".tex" -> fWithDefaultFile "latex" def
+ ".texi" -> fWithDefaultFile "texinfo" def
+ ".texinfo" -> fWithDefaultFile "texinfo" def
+ ".text" -> markdown
+ ".textile" -> fWithDefaultFile "textile" def
+ ".txt" -> markdown
+ ".wiki" -> fWithDefaultFile "mediawiki" def
+ ".xhtml" -> fWithDefaultFile "html" def
+ ".ipynb" -> fWithDefaultFile "ipynb" def
+ ".csv" -> fWithDefaultFile "csv" def
+ ".bib" -> fWithDefaultFile "biblatex" def
+ ['.', y] | y `elem` ['1' .. '9'] -> fWithDefaultFile "man" def
+ "" ->
+ (,x <> ".html")
+ <$> f
+ "html"
+ def
+ { writerTemplate = Just Html.template
+ , -- Not actually used. Needed to silence warning.
+ writerVariables = Context $ M.fromList [("pagetitle", toVal ("CompaREST" :: Text))]
+ }
+ _ -> Nothing
+ where
+ markdown :: Maybe (Pandoc -> m ByteString, FilePath)
+ markdown = fWithDefaultFile "markdown" markdownOpt
+
+ markdownOpt = def {writerExtensions = githubMarkdownExtensions}
+ fWithDefaultFile k opt = (,x) <$> f k opt
+ f k opt =
+ lookup k writers <&> \case
+ TextWriter g -> fmap (TL.encodeUtf8 . TL.fromStrict) . g opt
+ ByteStringWriter g -> g opt
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,69 @@
+module Main (main) where
+
+import Control.Monad
+import Control.Monad.Except
+import Data.Aeson
+import qualified Data.ByteString.Lazy as BSL
+import Data.Default
+import Data.Maybe
+import Data.OpenApi.Compare.Options
+import Data.OpenApi.Compare.Run
+import qualified Data.Text.IO as T
+import qualified Data.Yaml as Yaml
+import FormatHeuristic
+import System.Exit
+import System.IO
+import Text.Pandoc hiding (report)
+import Text.Pandoc.Builder
+
+main :: IO ()
+main = do
+ opts <- parseOptions
+ 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 <- parseSchema (clientFile opts)
+ b <- parseSchema (serverFile opts)
+ let runPandocIO :: PandocIO a -> ExceptT Errors IO a
+ runPandocIO x = lift (runIO x) >>= either (throwError . DocumentError) pure
+ options = def {writerExtensions = githubMarkdownExtensions}
+ write :: Pandoc -> ExceptT Errors IO ()
+ write = case outputMode opts of
+ StdoutMode -> lift . T.putStrLn <=< runPandocIO . writeMarkdown options
+ FileMode f -> case formatFromFilePath f of
+ Nothing -> \_ -> throwError UnknownOutputFormat
+ Just (writer, f') -> lift . BSL.writeFile f' <=< runPandocIO . writer
+ reportConfig =
+ ReportConfig
+ { treeStyle = reportTreeStyle opts
+ , reportMode = fromMaybe All $ mode opts
+ }
+ (report, status) = runReport reportConfig (a, b)
+ case mode opts of
+ Just _ -> either handler pure <=< runExceptT $ write $ doc report
+ Nothing -> pure ()
+ when (signalExitCode opts) $
+ case status of
+ NoBreakingChanges -> exitSuccess
+ BreakingChanges -> exitWith $ ExitFailure 1
+ OnlyUnsupportedChanges -> exitWith $ ExitFailure 2
+
+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
diff --git a/awsm-css/dist/awsm.min.css b/awsm-css/dist/awsm.min.css
new file mode 100644
--- /dev/null
+++ b/awsm-css/dist/awsm.min.css
@@ -0,0 +1,7 @@
+@charset "UTF-8";
+/*!
+ * awsm.css v3.0.7 (https://igoradamenko.github.io/awsm.css/)
+ * Copyright 2015 Igor Adamenko (https://igoradamenko.com)
+ * Licensed under MIT (https://github.com/igoradamenko/awsm.css/blob/master/LICENSE.md)
+ */
+html{font-family:system-ui,-apple-system,BlinkMacSystemFont,"Segoe UI",Roboto,Oxygen,Ubuntu,Cantarell,"PT Sans","Open Sans","Fira Sans","Droid Sans","Helvetica Neue",Helvetica,Arial,sans-serif;font-size:100%;line-height:1.4;background:#fff;color:#000;-webkit-overflow-scrolling:touch}body{margin:1.2em;font-size:1rem}@media (min-width:20rem){body{font-size:calc(1rem + .00625*(100vw - 20rem))}}@media (min-width:40rem){body{font-size:1.125rem}}body article,body footer,body header,body main{position:relative;max-width:40rem;margin:0 auto}body>header{margin-bottom:3.5em}body>header h1{margin:0;font-size:1.5em}body>header p{margin:0;font-size:.85em}body>footer{margin-top:6em;padding-bottom:1.5em;text-align:center;font-size:.8rem;color:#aaa}details,nav{margin:1em 0}nav ul{list-style:none;margin:0;padding:0}nav li{display:inline-block;margin-right:1em;margin-bottom:.25em}nav li:last-child{margin-right:0}a,nav a:visited{color:#0064c1}article header h1 a:visited:hover,article header h2 a:visited:hover,nav a:hover{color:#f00000}ol,ul{margin-top:0;padding-top:0;padding-left:2.5em}article header h1+p,article header h2+p,ol li+li,ul li+li{margin-top:.25em}ol li>details,ul li>details{margin:0}p{margin:1em 0;-webkit-hyphens:auto;-ms-hyphens:auto;hyphens:auto}aside:first-child,form legend:first-child+label,p:first-child{margin-top:0}aside:last-child,p:last-child{margin-bottom:0}p+ol,p+ul{margin-top:-.75em}p img,p picture{float:right;margin-bottom:.5em;margin-left:.5em}p picture img{float:none;margin:0}blockquote,dd{padding-left:2.5em}dd{margin-bottom:1em;margin-left:0}dt{font-weight:700}blockquote{margin:0}aside{margin:.5em 0;font-style:italic;color:#aaa}@media (min-width:65rem){aside{position:absolute;right:-12.5rem;width:9.375rem;max-width:9.375rem;margin:0;padding-left:.5em;font-size:.8em;border-left:1px solid #f2f2f2}}section+section{margin-top:2em}h1,h2,h3,h4,h5,h6{margin:1.25em 0 0;line-height:1.2}h1:focus>a[href^="#"][id]:empty,h1:hover>a[href^="#"][id]:empty,h2:focus>a[href^="#"][id]:empty,h2:hover>a[href^="#"][id]:empty,h3:focus>a[href^="#"][id]:empty,h3:hover>a[href^="#"][id]:empty,h4:focus>a[href^="#"][id]:empty,h4:hover>a[href^="#"][id]:empty,h5:focus>a[href^="#"][id]:empty,h5:hover>a[href^="#"][id]:empty,h6:focus>a[href^="#"][id]:empty,h6:hover>a[href^="#"][id]:empty{opacity:1}figure+p,h1+details,h1+p,h2+details,h2+p,h3+details,h3+p,h4+details,h4+p,h5+details,h5+p,h6+details,h6+p{margin-top:.5em}h1>a[href^="#"][id]:empty,h2>a[href^="#"][id]:empty,h3>a[href^="#"][id]:empty,h4>a[href^="#"][id]:empty,h5>a[href^="#"][id]:empty,h6>a[href^="#"][id]:empty{position:absolute;left:-.65em;opacity:0;text-decoration:none;font-weight:400;line-height:1;color:#aaa}@media (min-width:40rem){h1>a[href^="#"][id]:empty,h2>a[href^="#"][id]:empty,h3>a[href^="#"][id]:empty,h4>a[href^="#"][id]:empty,h5>a[href^="#"][id]:empty,h6>a[href^="#"][id]:empty{left:-.8em}}h1>a[href^="#"][id]:empty:focus,h1>a[href^="#"][id]:empty:hover,h1>a[href^="#"][id]:empty:target,h2>a[href^="#"][id]:empty:focus,h2>a[href^="#"][id]:empty:hover,h2>a[href^="#"][id]:empty:target,h3>a[href^="#"][id]:empty:focus,h3>a[href^="#"][id]:empty:hover,h3>a[href^="#"][id]:empty:target,h4>a[href^="#"][id]:empty:focus,h4>a[href^="#"][id]:empty:hover,h4>a[href^="#"][id]:empty:target,h5>a[href^="#"][id]:empty:focus,h5>a[href^="#"][id]:empty:hover,h5>a[href^="#"][id]:empty:target,h6>a[href^="#"][id]:empty:focus,h6>a[href^="#"][id]:empty:hover,h6>a[href^="#"][id]:empty:target{opacity:1;box-shadow:none;color:#000}h1>a[href^="#"][id]:empty:target:focus,h2>a[href^="#"][id]:empty:target:focus,h3>a[href^="#"][id]:empty:target:focus,h4>a[href^="#"][id]:empty:target:focus,h5>a[href^="#"][id]:empty:target:focus,h6>a[href^="#"][id]:empty:target:focus{outline:0}h1>a[href^="#"][id]:empty::before,h2>a[href^="#"][id]:empty::before,h3>a[href^="#"][id]:empty::before,h4>a[href^="#"][id]:empty::before,h5>a[href^="#"][id]:empty::before,h6>a[href^="#"][id]:empty::before{content:"§ "}h1{font-size:2.5em}h2{font-size:1.75em}h3{font-size:1.25em}h4{font-size:1.15em}a abbr,h5,h6{font-size:1em}h6{margin-top:1em}article+article{margin-top:4em}article header p{font-size:.6em;color:#aaa}article header p+h1,article header p+h2{margin-top:-.25em}article header h1 a,article header h2 a{color:#000}article header h1 a:visited,article header h2 a:visited,h6,legend{color:#aaa}article>footer{margin-top:1.5em;font-size:.85em}a:visited{color:#8d39d0}a:active,a:hover{outline-width:0}a:hover{color:#f00000}abbr{margin-right:-.075em;text-decoration:none;-webkit-hyphens:none;-ms-hyphens:none;hyphens:none;letter-spacing:.075em;font-size:.9em}img,picture{display:block;max-width:100%;margin:0 auto}audio,video{width:100%;max-width:100%}figure{margin:1em 0 .5em;padding:0}figure figcaption{opacity:.65;font-size:.85em}table{display:inline-block;border-spacing:0;border-collapse:collapse;overflow-x:auto;max-width:100%;text-align:left;vertical-align:top;background:linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 0 0,linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 100% 0;background-attachment:scroll,scroll;background-size:1px 100%,1px 100%;background-repeat:no-repeat,no-repeat}table caption{font-size:.9em;background:#fff}table td,table th{padding:.35em .75em;vertical-align:top;font-size:.9em;border:1px solid #f2f2f2;border-top:0;border-left:0}table td:first-child,table th:first-child{padding-left:0;background-image:linear-gradient(to right,#fff 50%,rgba(255,255,255,0) 100%);background-size:2px 100%;background-repeat:no-repeat}table td:last-child,table th:last-child{padding-right:0;border-right:0;background-image:linear-gradient(to left,#fff 50%,rgba(255,255,255,0) 100%);background-position:100% 0;background-size:2px 100%;background-repeat:no-repeat}table td:only-child,table th:only-child{background-image:linear-gradient(to right,#fff 50%,rgba(255,255,255,0) 100%),linear-gradient(to left,#fff 50%,rgba(255,255,255,0) 100%);background-position:0 0,100% 0;background-size:2px 100%,2px 100%;background-repeat:no-repeat,no-repeat}table th{line-height:1.2}form{margin-right:auto;margin-left:auto}@media (min-width:40rem){form{max-width:80%}}form label,form select,output{display:block}form label:not(:first-child){margin-top:1em}form p label{display:inline}form p label+label{margin-left:1em}form input[type],form select,form textarea{margin-bottom:1em}form input[type=checkbox],form input[type=radio]{margin-bottom:0}button,fieldset{margin:0;border:1px solid #aaa}fieldset{padding:.5em 1em}button{outline:0;box-sizing:border-box;height:2em;padding:calc(.25em - 1px) .5em;font-family:inherit;font-size:1em;border-radius:2px;background:#fff;display:inline-block;width:auto;background:#f2f2f2;color:#000;cursor:pointer}button:focus,input[type=email]:focus,input[type=month]:focus,input[type=number]:focus,input[type=password]:focus,input[type=search]:focus,input[type=tel]:focus,input[type=text]:focus,input[type=time]:focus,input[type=url]:focus,input[type=week]:focus,input[type^=date]:focus,select:focus{border:1px solid #000}button:not([disabled]):hover,input[type=button]:not([disabled]):hover,input[type=file]:not([disabled]):hover,input[type=reset]:not([disabled]):hover,input[type=submit]:not([disabled]):hover,select:not([disabled]):hover{border:1px solid #000}button:active,select:active{background-color:#aaa}button[disabled],select[disabled]{color:#aaa;cursor:not-allowed}select{outline:0;box-sizing:border-box;height:2em;margin:0;padding:calc(.25em - 1px) .5em;font-family:inherit;font-size:1em;border:1px solid #aaa;border-radius:2px;background:#fff;display:inline-block;width:auto;background:#f2f2f2;color:#000;cursor:pointer;padding-right:1.2em;background-position:top 55% right .35em;background-size:.5em;background-repeat:no-repeat;-webkit-appearance:none;-moz-appearance:none;appearance:none;background-image:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' viewBox='0 0 3 2'%3E%3Cpath fill='rgb(170, 170, 170)' fill-rule='nonzero' d='M1.5 2L3 0H0z'/%3E%3C/svg%3E")}select:not([disabled]):focus,select:not([disabled]):hover{background-image:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' viewBox='0 0 3 2'%3E%3Cpath fill='rgb(0, 0, 0)' fill-rule='nonzero' d='M1.5 2L3 0H0z'/%3E%3C/svg%3E")}input[type=email],input[type=month],input[type=number],input[type=password],input[type=search],input[type=tel],input[type=text],input[type=time],input[type=url],input[type=week],input[type^=date]{outline:0;box-sizing:border-box;height:2em;margin:0;padding:calc(.25em - 1px) .5em;font-family:inherit;font-size:1em;border:1px solid #aaa;border-radius:2px;background:#fff;color:#000;display:block;width:100%;line-height:calc(2em - 1px*2 - (.25em - 1px)*2);-webkit-appearance:none;-moz-appearance:none;appearance:none}input[type=email]::-moz-placeholder,input[type=month]::-moz-placeholder,input[type=number]::-moz-placeholder,input[type=password]::-moz-placeholder,input[type=search]::-moz-placeholder,input[type=tel]::-moz-placeholder,input[type=text]::-moz-placeholder,input[type=time]::-moz-placeholder,input[type=url]::-moz-placeholder,input[type=week]::-moz-placeholder,input[type^=date]::-moz-placeholder{color:#aaa}input[type=email]::-webkit-input-placeholder,input[type=month]::-webkit-input-placeholder,input[type=number]::-webkit-input-placeholder,input[type=password]::-webkit-input-placeholder,input[type=search]::-webkit-input-placeholder,input[type=tel]::-webkit-input-placeholder,input[type=text]::-webkit-input-placeholder,input[type=time]::-webkit-input-placeholder,input[type=url]::-webkit-input-placeholder,input[type=week]::-webkit-input-placeholder,input[type^=date]::-webkit-input-placeholder{color:#aaa}input[type=email]:-ms-input-placeholder,input[type=month]:-ms-input-placeholder,input[type=number]:-ms-input-placeholder,input[type=password]:-ms-input-placeholder,input[type=search]:-ms-input-placeholder,input[type=tel]:-ms-input-placeholder,input[type=text]:-ms-input-placeholder,input[type=time]:-ms-input-placeholder,input[type=url]:-ms-input-placeholder,input[type=week]:-ms-input-placeholder,input[type^=date]:-ms-input-placeholder{color:#aaa}input[type=button],input[type=reset],input[type=submit]{outline:0;box-sizing:border-box;height:2em;margin:0;padding:calc(.25em - 1px) .5em;font-family:inherit;font-size:1em;border:1px solid #aaa;border-radius:2px;background:#fff;display:inline-block;width:auto;background:#f2f2f2;color:#000;cursor:pointer;-webkit-appearance:none;-moz-appearance:none;appearance:none}input[type=button]:focus,input[type=reset]:focus,input[type=submit]:focus{border:1px solid #000}input[type=button]:active,input[type=reset]:active,input[type=submit]:active{background-color:#aaa}input[type=button][disabled],input[type=reset][disabled],input[type=submit][disabled]{color:#aaa;cursor:not-allowed}input[type=color]{outline:0;box-sizing:border-box;height:2em;margin:0;padding:calc(.25em - 1px) .5em;font-family:inherit;font-size:1em;border:1px solid #aaa;border-radius:2px;background:#fff;color:#000;display:block;line-height:calc(2em - 1px*2 - (.25em - 1px)*2);-webkit-appearance:none;-moz-appearance:none;appearance:none;width:6em}input[type=color]:focus{border:1px solid #000}input[type=color]::-moz-placeholder,textarea::-moz-placeholder{color:#aaa}input[type=color]::-webkit-input-placeholder,textarea::-webkit-input-placeholder{color:#aaa}input[type=color]:-ms-input-placeholder{color:#aaa}input[type=color]:hover{border:1px solid #000}input[type=file]{outline:0;box-sizing:border-box;margin:0;padding:calc(.25em - 1px) .5em;font-family:inherit;border:1px solid #aaa;border-radius:2px;background:#fff;background:#f2f2f2;color:#000;cursor:pointer;display:block;width:100%;height:auto;padding:.75em .5em;font-size:12px;line-height:1}input[type=file]:focus,textarea:focus{border:1px solid #000}input[type=file]:active{background-color:#aaa}input[type=file][disabled]{color:#aaa;cursor:not-allowed}input[type=checkbox],input[type=radio]{margin:-.2em .75em 0 0;vertical-align:middle}textarea{outline:0;box-sizing:border-box;margin:0;padding:calc(.25em - 1px) .5em;font-family:inherit;font-size:1em;border:1px solid #aaa;border-radius:2px;background:#fff;color:#000;display:block;width:100%;line-height:calc(2em - 1px*2 - (.25em - 1px)*2);-webkit-appearance:none;-moz-appearance:none;appearance:none;height:4.5em;resize:vertical;padding-top:.5em;padding-bottom:.5em}textarea:-ms-input-placeholder{color:#aaa}code,kbd,samp,var{font-family:Consolas,"Lucida Console",Monaco,monospace;font-style:normal}pre{overflow-x:auto;font-size:.8em;background:linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 0 0,linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 100% 0;background-attachment:scroll,scroll;background-size:1px 100%,1px 100%;background-repeat:no-repeat,no-repeat}pre>code,summary{display:inline-block}pre>code{overflow-x:visible;box-sizing:border-box;min-width:100%;border-right:3px solid #fff;border-left:1px solid #fff}hr{height:1px;margin:2em 0;border:0;background:#f2f2f2}details[open]{padding-bottom:.5em;border-bottom:1px solid #f2f2f2}summary{font-weight:700;border-bottom:1px dashed;cursor:pointer}summary::-webkit-details-marker{display:none}noscript{color:#d00000}::selection{background:rgba(0,100,193,.25)}
diff --git a/compaREST.cabal b/compaREST.cabal
new file mode 100644
--- /dev/null
+++ b/compaREST.cabal
@@ -0,0 +1,256 @@
+cabal-version: 2.4
+name: compaREST
+version: 0.1.0.0
+license: MIT
+license-file: LICENSE
+copyright: 2021 Typeable
+maintainer: compaREST@typeable.io
+author: Typeable
+tested-with: ghc ==8.10.4
+synopsis: Compatibility checker for OpenAPI
+description: Compatibility checker for OpenAPI.
+category: Web
+build-type: Simple
+extra-source-files:
+ awsm-css/dist/awsm.min.css
+ test/golden/**/*.yaml
+ test/golden/**/*.md
+
+extra-doc-files:
+ README.md
+ CHANGELOG.md
+
+library
+ exposed-modules:
+ Data.OpenApi.Compare.Behavior
+ Data.OpenApi.Compare.Common
+ Data.OpenApi.Compare.Formula
+ Data.OpenApi.Compare.Memo
+ Data.OpenApi.Compare.Orphans
+ Data.OpenApi.Compare.Paths
+ Data.OpenApi.Compare.PathsPrefixTree
+ Data.OpenApi.Compare.References
+ Data.OpenApi.Compare.Report
+ Data.OpenApi.Compare.Report.Html.Template
+ Data.OpenApi.Compare.Report.Jet
+ Data.OpenApi.Compare.Run
+ Data.OpenApi.Compare.Subtree
+ Data.OpenApi.Compare.Validate.Header
+ Data.OpenApi.Compare.Validate.Link
+ Data.OpenApi.Compare.Validate.MediaTypeObject
+ Data.OpenApi.Compare.Validate.OAuth2Flows
+ Data.OpenApi.Compare.Validate.OpenApi
+ Data.OpenApi.Compare.Validate.Operation
+ Data.OpenApi.Compare.Validate.Param
+ Data.OpenApi.Compare.Validate.PathFragment
+ Data.OpenApi.Compare.Validate.Products
+ Data.OpenApi.Compare.Validate.RequestBody
+ Data.OpenApi.Compare.Validate.Responses
+ Data.OpenApi.Compare.Validate.Schema
+ Data.OpenApi.Compare.Validate.Schema.DNF
+ Data.OpenApi.Compare.Validate.Schema.Issues
+ Data.OpenApi.Compare.Validate.Schema.JsonFormula
+ Data.OpenApi.Compare.Validate.Schema.Partition
+ Data.OpenApi.Compare.Validate.Schema.Process
+ Data.OpenApi.Compare.Validate.Schema.Traced
+ Data.OpenApi.Compare.Validate.Schema.TypedJson
+ Data.OpenApi.Compare.Validate.SecurityRequirement
+ Data.OpenApi.Compare.Validate.SecurityScheme
+ Data.OpenApi.Compare.Validate.Server
+ Data.OpenApi.Compare.Validate.Sums
+
+ hs-source-dirs: src
+ other-modules:
+ Data.HList
+ Data.OpenUnion.Extra
+
+ default-language: Haskell2010
+ default-extensions:
+ ApplicativeDo BangPatterns ConstraintKinds DataKinds DeriveAnyClass
+ DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable
+ DerivingStrategies DerivingVia DuplicateRecordFields
+ EmptyDataDeriving FlexibleContexts FlexibleInstances
+ FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase
+ MultiParamTypeClasses MultiWayIf NamedFieldPuns NumDecimals
+ OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes
+ RecordWildCards ScopedTypeVariables StandaloneDeriving
+ TemplateHaskell TupleSections TypeApplications TypeFamilies
+ TypeOperators UndecidableInstances ViewPatterns
+ QuantifiedConstraints DefaultSignatures
+
+ ghc-options:
+ -Weverything -Wno-implicit-prelude -Wno-missing-safe-haskell-mode
+ -Wno-safe -Wno-prepositive-qualified-module
+ -Wno-missing-import-lists -Wno-partial-fields
+ -Wno-all-missed-specialisations -Wno-missing-local-signatures
+ -Wno-unsafe -fconstraint-solver-iterations=0
+
+ build-depends:
+ base >=4.12.0.0 && <4.16,
+ text >=1.2.4.1 && <1.3,
+ pcre2 >=1.1.5 && <1.2,
+ open-union >=0.4.0.0 && <0.5,
+ vector >=0.12.3.1 && <0.13,
+ unordered-containers >=0.2.14.0 && <0.3,
+ type-fun >=0.1.3 && <0.2,
+ typerep-map >=0.3.3.0 && <0.4,
+ tagged >=0.8.6.1 && <0.9,
+ scientific >=0.3.7.0 && <0.4,
+ pandoc-types >=1.22.1 && <1.23,
+ openapi3 >=3.1.0 && <3.2,
+ lattices >=2.0.2 && <2.1,
+ insert-ordered-containers >=0.2.5 && <0.3,
+ http-media >=0.8.0.0 && <0.9,
+ hashable >=1.3.0.0 && <1.4,
+ free >=5.1.7 && <5.2,
+ containers >=0.6.5.1 && <0.7,
+ comonad >=5.0.8 && <5.1,
+ attoparsec >=0.13.2.5 && <0.14,
+ transformers >=0.5.6.2 && <0.6,
+ mtl >=2.2.2 && <2.3,
+ aeson >=1.5.6.0 && <1.6,
+ generic-data >=0.9.2.1 && <0.10,
+ doctemplates ==0.9.*,
+ file-embed >=0.0.15.0 && <0.1,
+ data-default >=0.7.1.1 && <0.8,
+ ordered-containers >=0.2.2 && <0.3,
+ bytestring >=0.10.12.0 && <0.11
+
+executable compaREST
+ main-is: Main.hs
+ hs-source-dirs: app
+ other-modules:
+ FormatHeuristic
+ Data.OpenApi.Compare.Options
+
+ default-language: Haskell2010
+ default-extensions:
+ ApplicativeDo BangPatterns ConstraintKinds DataKinds DeriveAnyClass
+ DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable
+ DerivingStrategies DerivingVia DuplicateRecordFields
+ EmptyDataDeriving FlexibleContexts FlexibleInstances
+ FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase
+ MultiParamTypeClasses MultiWayIf NamedFieldPuns NumDecimals
+ OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes
+ RecordWildCards ScopedTypeVariables StandaloneDeriving
+ TemplateHaskell TupleSections TypeApplications TypeFamilies
+ TypeOperators UndecidableInstances ViewPatterns
+ QuantifiedConstraints DefaultSignatures
+
+ ghc-options:
+ -Weverything -Wno-implicit-prelude -Wno-missing-safe-haskell-mode
+ -Wno-safe -Wno-prepositive-qualified-module
+ -Wno-missing-import-lists -Wno-partial-fields
+ -Wno-all-missed-specialisations -Wno-missing-local-signatures
+ -Wno-unsafe -fconstraint-solver-iterations=0 -threaded -rtsopts
+ -with-rtsopts=-N
+
+ build-depends:
+ base >=4.12.0.0 && <4.16,
+ text >=1.2.4.1 && <1.3,
+ compaREST -any,
+ pandoc >=2.14.0.3 && <2.15,
+ data-default >=0.7.1.1 && <0.8,
+ bytestring >=0.10.12.0 && <0.11,
+ yaml >=0.11.7.0 && <0.12,
+ filepath >=1.4.2.1 && <1.5,
+ optparse-applicative >=0.16.1.0 && <0.17,
+ mtl >=2.2.2 && <2.3,
+ aeson >=1.5.6.0 && <1.6,
+ containers >=0.6.5.1 && <0.7,
+ doctemplates ==0.9.*,
+ pandoc-types >=1.22.1 && <1.23
+
+executable compaREST-GitHub-Action
+ main-is: Main.hs
+ hs-source-dirs: github-action
+ other-modules:
+ Control.Monad.Freer.GitHub
+ CompaREST.GitHub.API
+ CompaREST.GitHub.Action.Config
+ GitHub.Data.Checks
+ GitHub.Endpoints.Checks
+
+ default-language: Haskell2010
+ default-extensions:
+ ApplicativeDo BangPatterns ConstraintKinds DataKinds DeriveAnyClass
+ DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable
+ DerivingStrategies DerivingVia DuplicateRecordFields
+ EmptyDataDeriving FlexibleContexts FlexibleInstances
+ FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase
+ MultiParamTypeClasses MultiWayIf NamedFieldPuns NumDecimals
+ OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes
+ RecordWildCards ScopedTypeVariables StandaloneDeriving
+ TemplateHaskell TupleSections TypeApplications TypeFamilies
+ TypeOperators UndecidableInstances ViewPatterns
+ QuantifiedConstraints DefaultSignatures
+
+ ghc-options:
+ -Weverything -Wno-implicit-prelude -Wno-missing-safe-haskell-mode
+ -Wno-safe -Wno-prepositive-qualified-module
+ -Wno-missing-import-lists -Wno-partial-fields
+ -Wno-all-missed-specialisations -Wno-missing-local-signatures
+ -Wno-unsafe -fconstraint-solver-iterations=0 -threaded -rtsopts
+ -with-rtsopts=-N
+
+ build-depends:
+ base >=4.12.0.0 && <4.16,
+ text >=1.2.4.1 && <1.3,
+ compaREST -any,
+ pandoc >=2.14.0.3 && <2.15,
+ yaml >=0.11.7.0 && <0.12,
+ aeson >=1.5.6.0 && <1.6,
+ github ==0.26.*,
+ freer-simple >=1.2.1.1 && <1.3,
+ vector >=0.12.3.1 && <0.13,
+ pandoc-types >=1.22.1 && <1.23,
+ envy >=2.1.0.0 && <2.2,
+ filepath >=1.4.2.1 && <1.5,
+ bytestring >=0.10.12.0 && <0.11
+
+test-suite compaREST-tests
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs: test
+ other-modules:
+ Spec.Golden.Extra
+ Spec.Golden.TraceTree
+ Paths_compaREST
+
+ autogen-modules: Paths_compaREST
+ default-language: Haskell2010
+ default-extensions:
+ ApplicativeDo BangPatterns ConstraintKinds DataKinds DeriveAnyClass
+ DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable
+ DerivingStrategies DerivingVia DuplicateRecordFields
+ EmptyDataDeriving FlexibleContexts FlexibleInstances
+ FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase
+ MultiParamTypeClasses MultiWayIf NamedFieldPuns NumDecimals
+ OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes
+ RecordWildCards ScopedTypeVariables StandaloneDeriving
+ TemplateHaskell TupleSections TypeApplications TypeFamilies
+ TypeOperators UndecidableInstances ViewPatterns
+ QuantifiedConstraints DefaultSignatures
+
+ ghc-options:
+ -Weverything -Wno-implicit-prelude -Wno-missing-safe-haskell-mode
+ -Wno-safe -Wno-prepositive-qualified-module
+ -Wno-missing-import-lists -Wno-partial-fields
+ -Wno-all-missed-specialisations -Wno-missing-local-signatures
+ -Wno-unsafe -fconstraint-solver-iterations=0 -threaded -rtsopts
+ -with-rtsopts=-N
+
+ build-depends:
+ base >=4.12.0.0 && <4.16,
+ text >=1.2.4.1 && <1.3,
+ compaREST -any,
+ tasty-golden >=2.3.4 && <2.4,
+ tasty >=1.4.2 && <1.5,
+ bytestring >=0.10.12.0 && <0.11,
+ yaml >=0.11.7.0 && <0.12,
+ directory >=1.3.6.0 && <1.4,
+ filepath >=1.4.2.1 && <1.5,
+ pandoc >=2.14.0.3 && <2.15,
+ data-default >=0.7.1.1 && <0.8,
+ lens >=4.19.2 && <4.20,
+ pandoc-types >=1.22.1 && <1.23
diff --git a/github-action/CompaREST/GitHub/API.hs b/github-action/CompaREST/GitHub/API.hs
new file mode 100644
--- /dev/null
+++ b/github-action/CompaREST/GitHub/API.hs
@@ -0,0 +1,86 @@
+module CompaREST.GitHub.API
+ ( postStatus,
+ postStatusProcessing,
+ )
+where
+
+import CompaREST.GitHub.Action.Config
+import Control.Monad.Freer
+import Control.Monad.Freer.GitHub
+import Control.Monad.Freer.Reader
+import Control.Monad.IO.Class
+import Data.Aeson
+import qualified Data.ByteString.Lazy.Char8 as BSLC
+import Data.OpenApi.Compare.Report
+import Data.Proxy
+import Data.Text (Text)
+import GitHub
+import GitHub.Data.Checks
+import GitHub.Endpoints.Checks
+
+postStatusProcessing ::
+ (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>
+ Eff effs ()
+postStatusProcessing = do
+ Config {..} <- ask
+ printJSON $
+ sendGitHub $
+ checkR
+ repoOwner
+ repoName
+ Check
+ { checkName = mkName Proxy checkName
+ , checkSha = sha
+ , checkDetailsURL = Nothing
+ , checkExternalId = Nothing
+ , checkStatus = Just CheckInProgress
+ , checkStartedAt = Nothing
+ , checkConclusion = Nothing
+ , checkCompletedAt = Nothing
+ , checkOutput = Nothing
+ , checkActions = Nothing
+ }
+
+postStatus ::
+ (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>
+ -- | 'Nothing' means that there were no changes at all
+ Maybe (Text, ReportStatus) ->
+ Eff effs ()
+postStatus x = do
+ let (body, (title, conclusion)) = case x of
+ Just (b, s) -> (b,) $ case s of
+ BreakingChanges -> ("⚠️ Breaking changes found!", CheckNeutral)
+ NoBreakingChanges -> ("No breaking changes found ✨", CheckSuccess)
+ OnlyUnsupportedChanges -> ("🤷 Couldn't determine compatibility", CheckNeutral)
+ Nothing -> ("", ("✅ The API did not change", CheckSuccess))
+ Config {..} <- ask
+ printJSON $
+ sendGitHub $
+ checkR
+ repoOwner
+ repoName
+ Check
+ { checkName = mkName Proxy checkName
+ , checkSha = sha
+ , checkDetailsURL = Nothing
+ , checkExternalId = Nothing
+ , checkStatus = Just CheckCompleted
+ , checkStartedAt = Nothing
+ , checkConclusion = Just conclusion
+ , checkCompletedAt = Nothing
+ , checkOutput =
+ Just $
+ CheckOutput
+ { checkTitle = title
+ , checkSummary = body
+ , checkText = Nothing
+ , checkAnnotations = Nothing
+ , checkImages = Nothing
+ }
+ , checkActions = Nothing
+ }
+
+printJSON :: MonadIO (Eff effs) => Eff effs Value -> Eff effs ()
+printJSON m = do
+ x <- m
+ liftIO . BSLC.putStrLn $ encode x
diff --git a/github-action/CompaREST/GitHub/Action/Config.hs b/github-action/CompaREST/GitHub/Action/Config.hs
new file mode 100644
--- /dev/null
+++ b/github-action/CompaREST/GitHub/Action/Config.hs
@@ -0,0 +1,47 @@
+module CompaREST.GitHub.Action.Config
+ ( Config (..),
+ )
+where
+
+import Data.Proxy
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified GitHub as GH
+
+import Data.Functor
+import System.Envy
+
+data Config = Config
+ { githubToken :: GH.Auth
+ , repoOwner :: GH.Name GH.Owner
+ , repoName :: GH.Name GH.Repo
+ , checkName :: Text
+ , footerText :: Text
+ , root :: FilePath
+ , sha :: GH.Name GH.Commit
+ }
+
+instance FromEnv Config where
+ fromEnv _ = do
+ token <- GH.OAuth <$> env "GITHUB_TOKEN"
+ (owner, repo) <-
+ T.split (== '/') <$> env "REPO" >>= \case
+ [owner, name] -> pure (owner, name)
+ _ -> fail "malformed repo"
+ checkName <-
+ envMaybe "PROJECT_NAME" <&> \case
+ Just pName | not . T.null . T.strip $ pName -> "compaREST – " <> pName
+ _ -> "compaREST"
+ footerText <- env "FOOTER"
+ root <- envMaybe "ROOT" .!= "."
+ sha <- env "SHA"
+ pure $
+ Config
+ { githubToken = token
+ , repoOwner = GH.mkName Proxy owner
+ , repoName = GH.mkName Proxy repo
+ , checkName = checkName
+ , footerText = footerText
+ , root = root
+ , sha = GH.mkName Proxy sha
+ }
diff --git a/github-action/Control/Monad/Freer/GitHub.hs b/github-action/Control/Monad/Freer/GitHub.hs
new file mode 100644
--- /dev/null
+++ b/github-action/Control/Monad/Freer/GitHub.hs
@@ -0,0 +1,27 @@
+module Control.Monad.Freer.GitHub
+ ( GitHub (..),
+ runGitHub,
+ sendGitHub,
+ )
+where
+
+import Control.Monad.Freer
+import Control.Monad.Freer.Error
+import Control.Monad.IO.Class
+import Data.Aeson
+import GitHub hiding (Error)
+import qualified GitHub as GH
+
+data GitHub r where
+ SendGHRequest :: FromJSON x => Request 'RW x -> GitHub x
+
+runGitHub :: (Member (Error GH.Error) effs, MonadIO (Eff effs)) => Auth -> Eff (GitHub ': effs) ~> Eff effs
+runGitHub auth =
+ interpret
+ ( \(SendGHRequest req) ->
+ liftIO (executeRequest auth req)
+ >>= either throwError pure
+ )
+
+sendGitHub :: (FromJSON x, Member GitHub effs) => Request 'RW x -> Eff effs x
+sendGitHub req = send $ SendGHRequest req
diff --git a/github-action/GitHub/Data/Checks.hs b/github-action/GitHub/Data/Checks.hs
new file mode 100644
--- /dev/null
+++ b/github-action/GitHub/Data/Checks.hs
@@ -0,0 +1,173 @@
+module GitHub.Data.Checks
+ ( Check (..),
+ CheckStatus (..),
+ CheckConclusion (..),
+ CheckOutput (..),
+ CheckAnnotation (..),
+ CheckAnnotationLevel (..),
+ CheckImage (..),
+ CheckAction (..),
+ )
+where
+
+import Data.Aeson
+import Data.Aeson.Types
+import Data.Text (Text)
+import Data.Vector (Vector)
+import GHC.Generics (Generic)
+import GitHub
+import GitHub.Internal.Prelude (UTCTime)
+
+data Check = Check
+ { checkName :: !(Name Check)
+ , checkSha :: !(Name Commit)
+ , checkDetailsURL :: !(Maybe URL)
+ , checkExternalId :: !(Maybe (Id Check))
+ , checkStatus :: !(Maybe CheckStatus)
+ , checkStartedAt :: !(Maybe UTCTime)
+ , checkConclusion :: !(Maybe CheckConclusion)
+ , checkCompletedAt :: !(Maybe UTCTime)
+ , checkOutput :: !(Maybe CheckOutput)
+ , checkActions :: !(Maybe (Vector CheckAction))
+ }
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance ToJSON Check where
+ toJSON (Check n sha durl eid s sa c ca o a) =
+ object'
+ [ "name" .= n
+ , "head_sha" .= sha
+ , "details_url" .= durl
+ , "external_id" .= eid
+ , "status" .= s
+ , "started_at" .= sa
+ , "conclusion" .= c
+ , "completed_at" .= ca
+ , "output" .= o
+ , "actions" .= a
+ ]
+
+data CheckStatus
+ = CheckQueued
+ | CheckInProgress
+ | CheckCompleted
+ deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)
+
+instance ToJSON CheckStatus where
+ toJSON CheckQueued = String "queued"
+ toJSON CheckInProgress = String "in_progress"
+ toJSON CheckCompleted = String "completed"
+
+data CheckConclusion
+ = CheckActionRequired
+ | CheckCancelled
+ | CheckFailure
+ | CheckNeutral
+ | CheckSuccess
+ | CheckSkipped
+ | CheckStale
+ | CheckTimedOut
+ deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)
+
+instance ToJSON CheckConclusion where
+ toJSON CheckActionRequired = String "action_required"
+ toJSON CheckCancelled = String "cancelled"
+ toJSON CheckFailure = String "failure"
+ toJSON CheckNeutral = String "neutral"
+ toJSON CheckSuccess = String "success"
+ toJSON CheckSkipped = String "skipped"
+ toJSON CheckStale = String "stale"
+ toJSON CheckTimedOut = String "timed_out"
+
+data CheckOutput = CheckOutput
+ { checkTitle :: !Text
+ , checkSummary :: !Text
+ , checkText :: !(Maybe Text)
+ , checkAnnotations :: !(Maybe (Vector CheckAnnotation))
+ , checkImages :: !(Maybe (Vector CheckImage))
+ }
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance ToJSON CheckOutput where
+ toJSON (CheckOutput t s txt a i) =
+ object'
+ [ "title" .= t
+ , "summary" .= s
+ , "text" .= txt
+ , "annotations" .= a
+ , "images" .= i
+ ]
+
+data CheckAnnotation = CheckAnnotation
+ { checkPath :: !Text
+ , checkStartLine :: !Int
+ , checkEndLine :: !Int
+ , checkStartColumn :: !(Maybe Int)
+ , checkEndColumn :: !(Maybe Int)
+ , checkAnnotationLevel :: !CheckAnnotationLevel
+ , checkMessage :: !Text
+ , checkTitle :: !(Maybe Text)
+ , checkRawDetails :: !(Maybe Text)
+ }
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance ToJSON CheckAnnotation where
+ toJSON (CheckAnnotation p sl el sc ec al m t rd) =
+ object'
+ [ "path" .= p
+ , "start_line" .= sl
+ , "end_line" .= el
+ , "start_column" .= sc
+ , "end_column" .= ec
+ , "annotation_level" .= al
+ , "message" .= m
+ , "title" .= t
+ , "raw_details" .= rd
+ ]
+
+data CheckAnnotationLevel
+ = NoticeAnnotation
+ | WarningAnnotation
+ | FailureAnnotation
+ deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)
+
+instance ToJSON CheckAnnotationLevel where
+ toJSON NoticeAnnotation = String "notice"
+ toJSON WarningAnnotation = String "warning"
+ toJSON FailureAnnotation = String "failure"
+
+data CheckImage = CheckImage
+ { checkImageAlt :: !Text
+ , checkImageURL :: !URL
+ , checkImageCaption :: !(Maybe Text)
+ }
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance ToJSON CheckImage where
+ toJSON (CheckImage a url c) =
+ object'
+ [ "alt" .= a
+ , "image_url" .= url
+ , "caption" .= c
+ ]
+
+data CheckAction = CheckAction
+ { checkActionLabel :: !Text
+ , checkActionDescription :: !Text
+ , checkActionIdentifier :: !Text
+ }
+ deriving stock (Show, Eq, Ord, Generic)
+
+instance ToJSON CheckAction where
+ toJSON (CheckAction l d i) =
+ object'
+ [ "label" .= l
+ , "description" .= d
+ , "identifier" .= i
+ ]
+
+object' :: [Pair] -> Value
+object' = object . filter notNull
+ where
+ notNull (_, Null) = False
+ notNull (_, _) = True
diff --git a/github-action/GitHub/Endpoints/Checks.hs b/github-action/GitHub/Endpoints/Checks.hs
new file mode 100644
--- /dev/null
+++ b/github-action/GitHub/Endpoints/Checks.hs
@@ -0,0 +1,12 @@
+module GitHub.Endpoints.Checks
+ ( checkR,
+ )
+where
+
+import Data.Aeson
+import GitHub
+import GitHub.Data.Checks
+
+checkR :: Name Owner -> Name Repo -> Check -> Request 'RW Value
+checkR user repo =
+ command Post ["repos", toPathPart user, toPathPart repo, "check-runs"] . encode
diff --git a/github-action/Main.hs b/github-action/Main.hs
new file mode 100644
--- /dev/null
+++ b/github-action/Main.hs
@@ -0,0 +1,66 @@
+module Main (main) where
+
+import CompaREST.GitHub.API
+import CompaREST.GitHub.Action.Config
+import Control.Exception
+import Control.Monad.Freer
+import Control.Monad.Freer.Error
+import Control.Monad.Freer.GitHub
+import Control.Monad.Freer.Reader
+import Data.OpenApi.Compare.Run
+import Data.Text (Text)
+import qualified Data.Yaml.Aeson as Yaml
+import qualified GitHub as GH
+import System.Environment
+import System.Envy (decodeEnv)
+import System.FilePath (())
+import Text.Pandoc (runPure)
+import Text.Pandoc.Builder
+import Text.Pandoc.Options
+import Text.Pandoc.Writers
+
+main :: IO ()
+main = do
+ cfg <- decodeEnv >>= either error pure
+ getArgs >>= \case
+ ["pre"] -> runPre cfg
+ ["run"] -> do
+ oldFile <- getEnv "OLD"
+ newFile <- getEnv "NEW"
+ runRun cfg (root cfg oldFile) (root cfg newFile)
+ _ -> error "Invalid arguments."
+
+runner :: Config -> Eff '[GitHub, Error GH.Error, Reader Config, IO] a -> IO a
+runner cfg =
+ runM @IO . runReader cfg
+ . flip (handleError @GH.Error) (error . displayException)
+ . runGitHub (githubToken cfg)
+
+runPre :: Config -> IO ()
+runPre cfg = runner cfg postStatusProcessing
+
+runRun :: Config -> FilePath -> FilePath -> IO ()
+runRun cfg old' new' = runner cfg $ do
+ old <- Yaml.decodeFileThrow old'
+ new <- Yaml.decodeFileThrow new'
+ let reportConfig =
+ ReportConfig
+ { treeStyle = FoldingBlockquotesTreeStyle
+ , reportMode = All
+ }
+ (report, status) = runReport reportConfig (old, new)
+
+ body = markdown report <> "\n\n" <> footerText cfg
+
+ result =
+ if old == new
+ then Nothing
+ else Just (body, status)
+ postStatus result
+
+markdown :: Blocks -> Text
+markdown =
+ either (error . displayException) id
+ . runPure
+ . writeHtml5String def
+ . doc
diff --git a/src/Data/HList.hs b/src/Data/HList.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/HList.hs
@@ -0,0 +1,81 @@
+module Data.HList
+ ( Has,
+ HasAll,
+ getH,
+ HList (..),
+ singletonH,
+ ReassembleHList,
+ reassemble,
+ )
+where
+
+import Data.Kind
+import GHC.TypeLits
+
+data HList (xs :: [Type]) where
+ HNil :: HList '[]
+ HCons :: x -> HList xs -> HList (x ': xs)
+
+infixr 5 `HCons`
+
+type family HasAll xs ys :: Constraint where
+ HasAll '[] _ = ()
+ HasAll (x ': xs) ys = (Has x ys, HasAll xs ys)
+
+type Has x xs = Has' x xs (HeadEq x xs)
+
+type family HeadEq x xs where
+ HeadEq x (x ': _) = 'True
+ HeadEq _ _ = 'False
+
+class t ~ HeadEq x xs => Has' (x :: Type) (xs :: [Type]) (t :: Bool) where
+ getH :: HList xs -> x
+
+instance Has' x (x ': xs) 'True where
+ getH (HCons x _) = x
+ {-# INLINE getH #-}
+
+instance (Has' x xs t, HeadEq x (y : xs) ~ 'False) => Has' x (y ': xs) 'False where
+ getH (HCons _ xs) = getH xs
+ {-# INLINE getH #-}
+
+instance
+ TypeError ( 'ShowType x ':<>: 'Text " is not a part of the list.") =>
+ Has' x '[] 'False
+ where
+ getH HNil = undefined
+ {-# INLINE getH #-}
+
+singletonH :: a -> HList '[a]
+singletonH a = a `HCons` HNil
+{-# INLINE singletonH #-}
+
+instance Eq (HList '[]) where
+ HNil == HNil = True
+
+instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) where
+ (HCons x xs) == (HCons y ys) = x == y && xs == ys
+
+type family (==) a b :: Bool where
+ a == a = 'True
+ _ == _ = 'False
+
+type ReassembleHList xs ys = ReassembleHList' xs ys (xs == ys)
+
+class f ~ (xs == ys) => ReassembleHList' xs ys f where
+ reassemble :: HList xs -> HList ys
+
+instance ReassembleHList' xs xs 'True where
+ reassemble = id
+ {-# INLINE reassemble #-}
+
+instance ReassembleHList' (x ': xs) '[] 'False where
+ reassemble _ = HNil
+ {-# INLINE reassemble #-}
+
+instance
+ (Has y xs, ReassembleHList' xs ys f, (xs == (y ': ys)) ~ 'False) =>
+ ReassembleHList' xs (y ': ys) 'False
+ where
+ reassemble xs = getH @y xs `HCons` reassemble xs
+ {-# INLINE reassemble #-}
diff --git a/src/Data/OpenApi/Compare/Behavior.hs b/src/Data/OpenApi/Compare/Behavior.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Behavior.hs
@@ -0,0 +1,124 @@
+module Data.OpenApi.Compare.Behavior
+ ( BehaviorLevel (..),
+ Behavable (..),
+ IssueKind (..),
+ Issuable (..),
+ Orientation (..),
+ toggleOrientation,
+ Behavior,
+ AnIssue (..),
+ withClass,
+ anIssueKind,
+ relatedAnIssues,
+ )
+where
+
+import Data.Aeson
+import Data.Kind
+import Data.OpenApi.Compare.Paths
+import Data.Typeable
+import Text.Pandoc.Builder
+
+-- | Kind
+data BehaviorLevel
+ = APILevel
+ | ServerLevel
+ | SecurityRequirementLevel
+ | SecuritySchemeLevel
+ | PathLevel
+ | OperationLevel
+ | PathFragmentLevel
+ | RequestLevel
+ | ResponseLevel
+ | HeaderLevel
+ | -- | either request or response data
+ PayloadLevel
+ | SchemaLevel
+ | TypedSchemaLevel
+ | LinkLevel
+ | CallbackLevel
+
+class
+ (Ord (Behave a b), Show (Behave a b)) =>
+ Behavable (a :: BehaviorLevel) (b :: BehaviorLevel)
+ where
+ data Behave a b
+ describeBehavior :: Behave a b -> Inlines
+
+type instance AdditionalQuiverConstraints Behave a b = Behavable a b
+
+data IssueKind
+ = -- | This is certainly an issue, we can demonstrate a "counterexample"
+ CertainIssue
+ | -- | Change looks breaking but we don't have a complete comprehension of the problem
+ ProbablyIssue
+ | -- | We don't really support this feature at all, outside structural comparison
+ Unsupported
+ | -- | This is not an issue in itself, but a clarifying comment providing context for some other issues
+ Comment
+ | -- | We detected an issue with one of the input schemata itself
+ SchemaInvalid
+ deriving stock (Eq, Ord, Show)
+
+class (Typeable l, Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLevel) where
+ data Issue l :: Type
+
+ -- | The same issues can be rendered in multiple places and might
+ -- require different ways of represnting them to the user.
+ --
+ -- In practice each issue requires a maximum of two different representations:
+ -- based on the context the issue might need to be rendered as "opposite" ('Backward')
+ -- – for example when rendering non-breaking changes everything should be
+ -- reversed (a consequence of the way we generate non-breaking changes).
+ --
+ -- If _consumer_ doesn't have something, the element was "removed".
+ -- If _producer_ doesn't have something, the element was "added".
+ describeIssue :: Orientation -> Issue l -> Blocks
+
+ issueKind :: Issue l -> IssueKind
+
+ -- | An equivalence relation designating whether two issues are talking about the aspect of the schema. This is used
+ -- to remove duplicates from the "reverse" error tree we get when we look for non-breaking changes.
+ -- Generally if checking X->Y raises issue I, and checking Y->X raises issue J, I and J should be related.
+ relatedIssues :: Issue l -> Issue l -> Bool
+ relatedIssues = (==)
+
+-- Utility function for 'relatedIssues'. In @withClass eq f@, @f@ attempts to partition inputs into equivalence classes,
+-- and two items in the same equivalence class are related. If both items aren't assigned to a class by @f@, instead
+-- @eq@ is used to compare them.
+withClass :: Eq b => (a -> a -> Bool) -> (a -> Maybe b) -> a -> a -> Bool
+withClass eq f = \x y -> case (f x, f y) of
+ (Just fx, Just fy) -> fx == fy
+ (Nothing, Nothing) -> eq x y
+ (_, _) -> False
+
+data Orientation = Forward | Backward
+ deriving stock (Eq, Ord, Show)
+
+toggleOrientation :: Orientation -> Orientation
+toggleOrientation Forward = Backward
+toggleOrientation Backward = Forward
+
+-- | A set of interactions having common unifying features
+type Behavior = Paths Behave 'APILevel
+
+instance Issuable l => ToJSON (Issue l) where
+ toJSON = toJSON . show
+
+data AnIssue (l :: BehaviorLevel) where
+ AnIssue :: Issuable l => Orientation -> Issue l -> AnIssue l
+
+deriving stock instance Show (AnIssue l)
+
+deriving stock instance Eq (AnIssue l)
+
+deriving stock instance Ord (AnIssue l)
+
+instance ToJSON (AnIssue l) where
+ toJSON (AnIssue _ issue) = toJSON issue
+
+anIssueKind :: AnIssue l -> IssueKind
+anIssueKind (AnIssue _ i) = issueKind i
+
+relatedAnIssues :: AnIssue l -> AnIssue l -> Bool
+relatedAnIssues (AnIssue _ x) (AnIssue _ y) = relatedIssues x y
diff --git a/src/Data/OpenApi/Compare/Common.hs b/src/Data/OpenApi/Compare/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Common.hs
@@ -0,0 +1,10 @@
+module Data.OpenApi.Compare.Common
+ ( zipAll,
+ )
+where
+
+zipAll :: [a] -> [b] -> Maybe [(a, b)]
+zipAll [] [] = Just []
+zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys
+zipAll (_ : _) [] = Nothing
+zipAll [] (_ : _) = Nothing
diff --git a/src/Data/OpenApi/Compare/Formula.hs b/src/Data/OpenApi/Compare/Formula.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Formula.hs
@@ -0,0 +1,135 @@
+module Data.OpenApi.Compare.Formula
+ ( FormulaF,
+ VarRef,
+ variable,
+ eitherOf,
+ anError,
+ errors,
+ calculate,
+ maxFixpoint,
+ mapErrors,
+ )
+where
+
+import Data.Kind
+import qualified Data.List.NonEmpty as NE
+import Data.Monoid
+import Data.OpenApi.Compare.Paths
+import qualified Data.OpenApi.Compare.PathsPrefixTree as P
+
+type VarRef = Int
+
+-- | The type @FormulaF f r ()@ describes (modulo contents of errors) boolean
+-- formulas involving variables, conjunctions, and disjunctions. These
+-- operations (and the generated algebra) are monotonous. This ensures that
+-- fixpoints always exist, i.e. that @x = f x@ has at least one solution.
+data FormulaF (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: Type) where
+ Result :: a -> FormulaF q f r a
+ Errors ::
+ !(P.PathsPrefixTree q f r) ->
+ -- | invariant: never empty
+ FormulaF q f r a
+ Apply ::
+ FormulaF q f r (b -> c) ->
+ FormulaF q f r b ->
+ (c -> a) ->
+ -- | invariant: at least one of LHS and RHS is not 'Errors', and they are
+ -- both not 'Result'
+ FormulaF q f r a
+ SelectFirst ::
+ NE.NonEmpty (SomeFormulaF b) ->
+ !(P.PathsPrefixTree q f r) ->
+ (b -> a) ->
+ -- | invariant: the list doesn't contain any 'Result's, 'Errors' or
+ -- 'SelectFirst'
+ FormulaF q f r a
+ Variable :: !VarRef -> a -> FormulaF q f r a
+
+mkApply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a
+mkApply (Result f) x h = h . f <$> x
+mkApply f (Result x) h = h . ($ x) <$> f
+mkApply (Errors e1) (Errors e2) _ = Errors (e1 <> e2)
+mkApply f x h = Apply f x h
+
+mkSelectFirst :: [SomeFormulaF b] -> P.PathsPrefixTree q f r -> (b -> a) -> FormulaF q f r a
+mkSelectFirst fs allE h = case foldMap check fs of
+ (First (Just x), _) -> Result (h x)
+ (First Nothing, x : xs) -> SelectFirst (x NE.:| xs) allE h
+ (First Nothing, []) -> Errors allE
+ where
+ check (SomeFormulaF (Result x)) = (First (Just x), mempty)
+ check (SomeFormulaF (Errors _)) = (mempty, mempty)
+ check (SomeFormulaF (SelectFirst xs _ h')) =
+ (mempty, NE.toList (fmap (fmap h') xs))
+ check x = (mempty, [x])
+
+data SomeFormulaF (a :: Type) where
+ SomeFormulaF :: FormulaF q f r a -> SomeFormulaF a
+
+anError :: AnItem q f r -> FormulaF q f r a
+anError e = Errors $ P.singleton e
+
+errors :: P.PathsPrefixTree q f r -> FormulaF q f r ()
+errors t
+ | P.null t = Result ()
+ | otherwise = Errors t
+
+variable :: VarRef -> FormulaF q f r ()
+variable v = Variable v ()
+
+instance Functor (FormulaF q f r) where
+ fmap f (Result x) = Result (f x)
+ fmap _ (Errors e) = Errors e
+ fmap f (Apply g x h) = Apply g x (f . h)
+ fmap f (SelectFirst xs e h) = SelectFirst xs e (f . h)
+ fmap f (Variable r x) = Variable r (f x)
+
+instance Functor SomeFormulaF where
+ fmap f (SomeFormulaF x) = SomeFormulaF (fmap f x)
+
+instance Applicative (FormulaF q f r) where
+ pure = Result
+ f <*> x = mkApply f x id
+
+eitherOf :: [FormulaF q' f' r' a] -> AnItem q f r -> FormulaF q f r a
+eitherOf fs allE = mkSelectFirst (map SomeFormulaF fs) (P.singleton allE) id
+
+calculate :: FormulaF q f r a -> Either (P.PathsPrefixTree q f r) a
+calculate (Result x) = Right x
+calculate (Errors e) = Left e
+calculate (Apply f x h) = case calculate f of
+ Left e1 -> case calculate x of
+ Left e2 -> Left (e1 <> e2)
+ Right _ -> Left e1
+ Right f' -> case calculate x of
+ Left e2 -> Left e2
+ Right x' -> Right (h (f' x'))
+calculate (SelectFirst xs e h) = go (NE.toList xs)
+ where
+ go (SomeFormulaF r : rs) = case calculate r of
+ Left _ -> go rs
+ Right x -> Right (h x)
+ go [] = Left e
+calculate (Variable i _) = error $ "Unknown variable " <> show i
+
+-- Approximate for now. Answers yes/no correctly, but the error lists aren't
+-- super accurate. TODO: improve
+maxFixpoint :: VarRef -> FormulaF q f r () -> FormulaF q f r ()
+maxFixpoint i = go
+ where
+ go :: FormulaF q f r a -> FormulaF q f r a
+ go (Result x) = Result x
+ go (Errors e) = Errors e
+ go (Apply f x h) = mkApply (go f) (go x) h
+ go (SelectFirst fs e h) = mkSelectFirst (NE.toList (fmap goSF fs)) e h
+ go (Variable j x) | i == j = Result x
+ go v@(Variable _ _) = v
+ goSF :: SomeFormulaF a -> SomeFormulaF a
+ goSF (SomeFormulaF x) = SomeFormulaF (go x)
+
+mapErrors :: (P.PathsPrefixTree q f r -> P.PathsPrefixTree q' f' r') -> FormulaF q f r a -> FormulaF q' f' r' a
+mapErrors _ (Result x) = Result x
+mapErrors m (Errors e) = Errors $ m e
+mapErrors m (Apply f x h) = mkApply (mapErrors m f) (mapErrors m x) h
+mapErrors m (SelectFirst fs e h) = mkSelectFirst (NE.toList fs) (m e) h
+mapErrors _ (Variable i x) = Variable i x
diff --git a/src/Data/OpenApi/Compare/Memo.hs b/src/Data/OpenApi/Compare/Memo.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Memo.hs
@@ -0,0 +1,164 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+-- | Utilities for effectfully memoizing other, more effectful functions.
+module Data.OpenApi.Compare.Memo
+ ( MonadMemo,
+ MemoState,
+ runMemo,
+ modifyMemoNonce,
+ KnotTier (..),
+ unknot,
+ memoWithKnot,
+ memoTaggedWithKnot,
+ )
+where
+
+import Control.Monad.State
+import Data.Dynamic
+import qualified Data.Map as M
+import Data.Tagged
+import qualified Data.TypeRepMap as T
+import Data.Void
+import Type.Reflection
+
+data Progress a = Finished a | Started | TyingKnot Dynamic
+
+data MemoMap a where
+ MemoMap :: !(M.Map k (Progress v)) -> MemoMap (k, v)
+
+data MemoState s = MemoState s (T.TypeRepMap MemoMap)
+
+-- | An effectful memoization monad.
+type MonadMemo s m = MonadState (MemoState s) m
+
+memoStateLookup ::
+ forall k v s.
+ (Typeable k, Typeable v, Ord k) =>
+ k ->
+ MemoState s ->
+ Maybe (Progress v)
+memoStateLookup k (MemoState _ t) = case T.lookup @(k, v) t of
+ Just (MemoMap m) -> M.lookup k m
+ Nothing -> Nothing
+
+memoStateInsert ::
+ forall k v s.
+ (Typeable k, Typeable v, Ord k) =>
+ k ->
+ Progress v ->
+ MemoState s ->
+ MemoState s
+memoStateInsert k x (MemoState s t) = MemoState s $ T.insert (MemoMap m'') t
+ where
+ m'' = M.insert k x m'
+ m' = case T.lookup @(k, v) t of
+ Just (MemoMap m) -> m
+ Nothing -> M.empty
+
+modifyMemoNonce :: MonadMemo s m => (s -> s) -> m s
+modifyMemoNonce f = do
+ MemoState s t <- get
+ put $ MemoState (f s) t
+ pure s
+
+-- | Run a memoized computation.
+runMemo :: Monad m => s -> StateT (MemoState s) m a -> m a
+runMemo s = (`evalStateT` MemoState s T.empty)
+
+-- | A description of how to effectfully tie knots in type @v@, using the @m@
+-- monad, and by sharing some @d@ data among the recursive instances.
+data KnotTier v d m = KnotTier
+ { -- | Create some data that will be connected to this knot
+ onKnotFound :: m d
+ , -- | This is what the knot will look like as a value
+ -- to the inner computations
+ onKnotUsed :: d -> m v
+ , -- | Once we're done and we're outside, tie the
+ -- knot using the datum
+ tieKnot :: d -> v -> m v
+ }
+
+unknot :: KnotTier v Void m
+unknot =
+ KnotTier
+ { onKnotFound = error "Recursion detected"
+ , onKnotUsed = absurd
+ , tieKnot = absurd
+ }
+
+-- | Run a potentially recursive computation. The provided key will be used to
+-- refer to the result of this computation. If during the computation, another
+-- attempt to run the computation with the same key is made, we run a
+-- tying-the-knot procedure.
+--
+-- If another attempt to run the computation with the same key is made
+-- *after we're done*, we will return the memoized value.
+memoWithKnot ::
+ forall k v d m s.
+ (Typeable k, Typeable v, Typeable d, Ord k, MonadMemo s m) =>
+ KnotTier v d m ->
+ -- | the computation to memoize
+ m v ->
+ -- | key for memoization
+ k ->
+ m v
+memoWithKnot tier f k =
+ memoStateLookup @k @v k <$> get >>= \case
+ Just (Finished v) -> pure v
+ Just Started -> do
+ d <- onKnotFound tier
+ modify $ memoStateInsert @k @v k (TyingKnot $ toDyn d)
+ onKnotUsed tier d
+ Just (TyingKnot dyn) -> case fromDynamic dyn of
+ Just d -> onKnotUsed tier d
+ Nothing ->
+ error $
+ "Type mismatch when examining the knot of "
+ <> show (typeRep @(k -> v))
+ <> ": expected "
+ <> show (typeRep @d)
+ <> ", got "
+ <> show (dynTypeRep dyn)
+ Nothing -> do
+ modify $ memoStateInsert @k @v k Started
+ v <- f
+ v' <-
+ memoStateLookup @k @v k <$> get >>= \case
+ Just Started -> pure v
+ Just (TyingKnot dyn) -> case fromDynamic dyn of
+ Just d -> tieKnot tier d v
+ Nothing ->
+ error $
+ "Type mismatch when tying the knot of "
+ <> show (typeRep @(k -> v))
+ <> ": expected "
+ <> show (typeRep @d)
+ <> ", got "
+ <> show (dynTypeRep dyn)
+ Just (Finished _) ->
+ error $
+ "Unexpected Finished when memoizing "
+ <> show (typeRep @(k -> v))
+ Nothing -> pure v
+ -- Normally this would be an error, but the underlying monad can refuse
+ -- to remember memoization state
+ modify $ memoStateInsert @k @v k (Finished v')
+ pure v'
+
+-- | Disambiguate memoized computations with an arbitrary tag.
+memoTaggedWithKnot ::
+ forall t k v d m s.
+ ( Typeable t
+ , Typeable k
+ , Typeable v
+ , Typeable d
+ , Ord k
+ , MonadMemo s m
+ ) =>
+ KnotTier v d m ->
+ m v ->
+ k ->
+ m v
+memoTaggedWithKnot tier f k =
+ withTypeable (typeRepKind $ typeRep @t) $
+ memoWithKnot tier f (Tagged @t k)
diff --git a/src/Data/OpenApi/Compare/Orphans.hs b/src/Data/OpenApi/Compare/Orphans.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Orphans.hs
@@ -0,0 +1,42 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Orphans () where
+
+import Control.Comonad.Env
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.OpenApi
+
+deriving newtype instance Ord Reference
+
+deriving stock instance Ord a => Ord (Referenced a)
+
+deriving stock instance Ord Schema
+
+deriving stock instance Ord AdditionalProperties
+
+deriving stock instance Ord Discriminator
+
+deriving stock instance Ord Xml
+
+deriving stock instance Ord OpenApiType
+
+deriving stock instance Ord Style
+
+deriving stock instance Ord OpenApiItems
+
+deriving stock instance Ord ParamLocation
+
+deriving stock instance Ord HttpSchemeType
+
+deriving stock instance Ord ApiKeyParams
+
+deriving stock instance Ord ApiKeyLocation
+
+instance (Ord k, Ord v) => Ord (IOHM.InsOrdHashMap k v) where
+ compare xs ys = compare (IOHM.toList xs) (IOHM.toList ys)
+
+deriving stock instance (Eq e, Eq (w a)) => Eq (EnvT e w a)
+
+deriving stock instance (Ord e, Ord (w a)) => Ord (EnvT e w a)
+
+deriving stock instance (Show e, Show (w a)) => Show (EnvT e w a)
diff --git a/src/Data/OpenApi/Compare/Paths.hs b/src/Data/OpenApi/Compare/Paths.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Paths.hs
@@ -0,0 +1,113 @@
+-- | Utilities for traversing heterogeneous trees. A heterogeneous tree is a
+-- collection of datatypes that "contain" eachother in some form of tree
+-- structure.
+module Data.OpenApi.Compare.Paths
+ ( NiceQuiver,
+ AdditionalQuiverConstraints,
+ Paths (..),
+ DiffPaths (..),
+ catDiffPaths,
+ AnItem (..),
+ step,
+
+ -- * Reexports
+ (>>>),
+ (<<<),
+ )
+where
+
+import Control.Category
+import Data.Kind
+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), 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
+-- are the sets of various multi-step paths between nodes. This is similar to a
+-- list, but indexed. The list is in reverse because in practice we append
+-- items at the end one at a time.
+data Paths (q :: k -> k -> Type) (a :: k) (b :: k) where
+ Root :: Paths q a a
+ Snoc :: NiceQuiver q b c => Paths q a b -> !(q b c) -> Paths q a c
+
+infixl 5 `Snoc`
+
+deriving stock instance Show (Paths q a b)
+
+step :: NiceQuiver q a b => q a b -> Paths q a b
+step s = Root `Snoc` s
+
+instance Category (Paths q) where
+ id = Root
+ Root . xs = xs
+ (Snoc ys y) . xs = Snoc (ys . xs) y
+
+typeRepRHS :: Typeable b => Paths q a b -> TypeRep b
+typeRepRHS _ = typeRep
+
+typeRepLHS :: Typeable b => Paths q a b -> TypeRep a
+typeRepLHS Root = typeRep
+typeRepLHS (Snoc xs _) = typeRepLHS xs
+
+instance TestEquality (Paths q a) where
+ testEquality Root Root = Just Refl
+ testEquality Root (Snoc ys _) = testEquality (typeRepLHS ys) typeRep
+ testEquality (Snoc xs _) Root = testEquality typeRep (typeRepLHS xs)
+ testEquality (Snoc _ _) (Snoc _ _) = testEquality typeRep typeRep
+
+instance Eq (Paths q a b) where
+ Root == Root = True
+ Snoc xs x == Snoc ys y
+ | Just Refl <- testEquality (typeRepRHS xs) (typeRepRHS ys) =
+ xs == ys && x == y
+ _ == _ = False
+
+instance Ord (Paths q a b) where
+ compare Root Root = EQ
+ compare Root (Snoc _ _) = LT
+ compare (Snoc _ _) Root = GT
+ compare (Snoc xs x) (Snoc ys y) =
+ case testEquality (typeRepRHS xs) (typeRepRHS ys) of
+ Just Refl -> compare xs ys <> compare x y
+ Nothing -> compare (someTypeRep xs) (someTypeRep ys)
+
+-- | Like a differece list, but indexed.
+newtype DiffPaths (q :: k -> k -> Type) (a :: k) (b :: k)
+ = DiffPaths (forall c. Paths q c a -> Paths q c b)
+
+catDiffPaths :: DiffPaths q a b -> DiffPaths q b c -> DiffPaths q a c
+catDiffPaths (DiffPaths f) (DiffPaths g) = DiffPaths (g . f)
+
+-- _DiffPaths :: Iso (DiffPaths q a b) (DiffPaths q c d) (Paths q a b) (Paths q c d)
+-- _DiffPaths = dimap (\(DiffPaths f) -> f Root) $
+-- fmap $ \xs -> DiffPaths (>>> xs)
+
+-- | An item related to some path relative to the root @r@.
+data AnItem (q :: k -> k -> Type) (f :: k -> Type) (r :: k) where
+ AnItem :: Ord (f a) => Paths q r a -> !(f a) -> AnItem q f r
+
+-- the Ord is yuck but we need it and it should be fine in monomorphic cases
+
+instance Eq (AnItem q f r) where
+ AnItem xs fx == AnItem ys fy
+ | Just Refl <- testEquality xs ys =
+ xs == ys && fx == fy
+ _ == _ = False
+
+instance Typeable r => Ord (AnItem q f r) where
+ compare (AnItem xs fx) (AnItem ys fy) =
+ case testEquality xs ys of
+ Just Refl -> compare xs ys <> compare fx fy
+ Nothing -> case xs of
+ Root -> case ys of
+ Root -> compare (someTypeRep xs) (someTypeRep ys)
+ Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
+ Snoc _ _ -> case ys of
+ Root -> compare (someTypeRep xs) (someTypeRep ys)
+ Snoc _ _ -> compare (someTypeRep xs) (someTypeRep ys)
diff --git a/src/Data/OpenApi/Compare/PathsPrefixTree.hs b/src/Data/OpenApi/Compare/PathsPrefixTree.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/PathsPrefixTree.hs
@@ -0,0 +1,276 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+
+module Data.OpenApi.Compare.PathsPrefixTree
+ ( PathsPrefixTree (PathsPrefixNode),
+ AStep (..),
+ empty,
+ singleton,
+ fromList,
+ null,
+ foldWith,
+ toList,
+ filter,
+ filterWithKey,
+ takeSubtree,
+ lookup,
+ embed,
+ size,
+ partition,
+ map,
+ )
+where
+
+import Control.Monad
+import Data.Aeson
+import Data.Foldable hiding (null, toList)
+import qualified Data.HashMap.Strict as HM
+import Data.Kind
+import qualified Data.Map as M
+import Data.Monoid
+import Data.OpenApi.Compare.Paths
+import qualified Data.Set as S
+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 Type.Reflection
+import Prelude hiding (filter, lookup, map, null)
+
+-- | A list of @AnItem r f@, but optimized into a prefix tree.
+data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPrefixTree
+ { rootItems :: !(ASet (f r))
+ , snocItems :: !(TRM.TypeRepMap (AStep q f r))
+ }
+ deriving stock (Show)
+
+map :: (forall x. f x -> f x) -> PathsPrefixTree q f r -> PathsPrefixTree q f r
+map f (PathsPrefixTree roots branches) =
+ PathsPrefixTree (mapASet f roots) (TRM.hoist (mapAStep f) branches)
+
+-- TODO: optimize
+partition :: (forall a. f a -> Bool) -> PathsPrefixTree q f r -> (PathsPrefixTree q f r, PathsPrefixTree q f r)
+partition f x = (filter f x, filter (not . f) x)
+
+filter :: (forall a. f a -> Bool) -> PathsPrefixTree q f r -> PathsPrefixTree q f r
+filter f (PathsPrefixTree roots branches) = PathsPrefixTree roots' branches'
+ where
+ roots' = filterASet f roots
+ branches' =
+ Exts.fromList
+ . fmap (\(TRM.WrapTypeable (AStep x)) -> TRM.WrapTypeable . AStep . M.mapMaybe (maybeNonEmpty . filter f) $ x)
+ . Exts.toList
+ $ branches
+
+ maybeNonEmpty = mfilter (not . null) . Just
+
+filterWithKey :: (forall a. Paths q r a -> f a -> Bool) -> PathsPrefixTree q f r -> PathsPrefixTree q f r
+filterWithKey = go Root
+ where
+ go :: Paths q r b -> (forall a. Paths q r a -> f a -> Bool) -> PathsPrefixTree q f b -> PathsPrefixTree q f b
+ go xs f (PathsPrefixTree roots branches) = PathsPrefixTree roots' branches'
+ where
+ roots' = filterASet (f xs) roots
+ branches' =
+ Exts.fromList
+ . fmap (\(TRM.WrapTypeable (AStep x)) -> TRM.WrapTypeable . AStep . M.mapMaybeWithKey (\k -> maybeNonEmpty . go (xs `Snoc` k) f) $ x)
+ . Exts.toList
+ $ branches
+
+ maybeNonEmpty = mfilter (not . null) . Just
+
+-- | The number of leaves.
+size :: PathsPrefixTree q f r -> Int
+size (PathsPrefixTree root branches) =
+ (S.size . toSet $ root)
+ + (sum . fmap (\(TRM.WrapTypeable (AStep x)) -> sum . fmap size . M.elems $ x) . Exts.toList $ branches)
+
+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 = PathsPrefixTree (fromSet s) (Exts.fromList steps)
+
+{-# COMPLETE PathsPrefixNode #-}
+
+instance (forall a. ToJSON (f a)) => ToJSON (PathsPrefixTree q f r) where
+ toJSON =
+ Object . getMergableObject
+ . foldWith (\t x -> MergableObject . traceObject t $ toJSON x)
+
+deriving stock instance Eq (PathsPrefixTree q f a)
+
+-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where
+-- the components are ordered by the @SomeTypeRep@ of the @a@.
+compareTRM ::
+ (forall a. Typeable a => Ord (f a)) =>
+ TRM.TypeRepMap f ->
+ TRM.TypeRepMap f ->
+ Ordering
+compareTRM s1 s2 =
+ foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys
+ where
+ (m1, m2) = (toMap s1, toMap s2)
+ mKeys = S.toAscList $ M.keysSet m1 `S.union` M.keysSet m2
+ compareMaybe _ Nothing Nothing = EQ
+ compareMaybe _ Nothing (Just _) = LT
+ compareMaybe _ (Just _) Nothing = GT
+ compareMaybe cmp (Just x) (Just y) = cmp x y
+ compareW ::
+ (forall a. Typeable a => Ord (f a)) =>
+ TRM.WrapTypeable f ->
+ TRM.WrapTypeable f ->
+ Ordering
+ compareW (TRM.WrapTypeable (x :: f a)) (TRM.WrapTypeable (y :: f b))
+ | Just Refl <- testEquality (typeRep @a) (typeRep @b) = compare x y
+ | otherwise = EQ -- unreachable
+ toMap s =
+ M.fromList
+ [(someTypeRep x, w) | w@(TRM.WrapTypeable x) <- Exts.toList s]
+
+instance Ord (PathsPrefixTree q f a) where
+ compare (PathsPrefixTree r1 s1) (PathsPrefixTree r2 s2) =
+ compare r1 r2 <> compareTRM s1 s2
+
+filterASet :: (a -> Bool) -> ASet a -> ASet a
+filterASet _ AnEmptySet = AnEmptySet
+filterASet f (ASet s) = fromSet $ S.filter f s
+
+data ASet (a :: Type) where
+ AnEmptySet :: ASet a
+ ASet :: Ord a => S.Set a -> ASet a
+
+mapASet :: (Ord a => Ord b) => (a -> b) -> ASet a -> ASet b
+mapASet _ AnEmptySet = AnEmptySet
+mapASet f (ASet s) = ASet $ S.map f s
+
+deriving stock instance Show a => Show (ASet a)
+
+toSet :: ASet a -> S.Set a
+toSet AnEmptySet = S.empty
+toSet (ASet s) = s
+
+fromSet :: Ord a => S.Set a -> ASet a
+fromSet s | S.null s = AnEmptySet
+fromSet s = ASet s
+
+instance ToJSON a => ToJSON (ASet a) where
+ toJSON = toJSON . toSet
+
+instance Semigroup (ASet a) where
+ AnEmptySet <> s = s
+ s <> AnEmptySet = s
+ ASet s1 <> ASet s2 = ASet $ S.union s1 s2
+
+deriving stock instance Eq (ASet a)
+
+deriving stock instance Ord (ASet a)
+
+-- type traceprefixset = traceprefixtree proxy
+
+instance Monoid (ASet a) where
+ mempty = AnEmptySet
+
+data AStep (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: k) where
+ AStep ::
+ NiceQuiver q r a =>
+ !(M.Map (q r a) (PathsPrefixTree q f a)) ->
+ AStep q f r a
+
+mapAStep :: (forall x. f x -> f x) -> AStep q f r a -> AStep q f r a
+mapAStep f (AStep m) = AStep $ M.map (map f) m
+
+deriving stock instance Eq (AStep q f r a)
+
+deriving stock instance Ord (AStep q f r a)
+
+singleton :: AnItem q f r -> PathsPrefixTree q f r
+singleton (AnItem ys v) = go ys $ PathsPrefixTree (ASet $ S.singleton v) TRM.empty
+ where
+ go :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
+ go Root !t = t
+ go (Snoc xs x) !t =
+ go xs $
+ PathsPrefixTree AnEmptySet $
+ TRM.one $
+ AStep $ M.singleton x t
+
+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
+ mempty = PathsPrefixTree mempty TRM.empty
+
+empty :: PathsPrefixTree q f r
+empty = mempty
+
+fromList :: [AnItem q f r] -> PathsPrefixTree q f r
+fromList = foldMap singleton
+
+null :: PathsPrefixTree q f r -> Bool
+null (PathsPrefixTree AnEmptySet s) = all (\(TRM.WrapTypeable (AStep x)) -> all null x) (Exts.toList s)
+null _ = False
+
+foldWith ::
+ forall q f m r.
+ Monoid m =>
+ (forall a. Ord (f a) => Paths q r a -> f a -> m) ->
+ PathsPrefixTree q f r ->
+ m
+foldWith k = goTPT Root
+ where
+ goTPT :: forall a. Paths q r a -> PathsPrefixTree q f a -> m
+ goTPT xs t = goASet xs (rootItems t) <> goTRM xs (snocItems t)
+ goASet :: forall a. Paths q r a -> ASet (f a) -> m
+ goASet _ AnEmptySet = mempty
+ goASet xs (ASet rs) = foldMap (k xs) rs
+ goTRM :: forall a. Paths q r a -> TRM.TypeRepMap (AStep q f a) -> m
+ goTRM xs s = foldMap (\(TRM.WrapTypeable f) -> goAStep xs f) $ Exts.toList s
+ goAStep :: forall a b. Paths q r a -> AStep q f a b -> m
+ goAStep xs (AStep m) =
+ M.foldrWithKey (\x t -> (goTPT (Snoc xs x) t <>)) mempty m
+
+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
+takeSubtree :: forall q f r a. Paths q r a -> PathsPrefixTree q f r -> PathsPrefixTree q f a
+takeSubtree Root t = t
+takeSubtree (Snoc xs x) t =
+ foldMap (\(AStep m) -> fold $ M.lookup x m) $
+ TRM.lookup @a $ snocItems $ takeSubtree xs t
+
+lookup :: Paths q r a -> PathsPrefixTree q f r -> S.Set (f a)
+lookup xs = toSet . rootItems . takeSubtree xs
+
+-- | Embed a subtree in a larger tree with given prefix
+embed :: Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
+embed Root t = t
+embed (Snoc xs x) t = embed xs $ PathsPrefixTree AnEmptySet $ TRM.one $ AStep $ M.singleton x t
+
+newtype MergableObject = MergableObject {getMergableObject :: Object}
+
+instance Semigroup MergableObject where
+ (MergableObject x) <> (MergableObject y) =
+ MergableObject $ HM.unionWith mergeValue x y
+ where
+ mergeValue :: Value -> Value -> Value
+ mergeValue (Object a) (Object b) =
+ Object . getMergableObject $ MergableObject a <> MergableObject b
+ mergeValue (Array a) (Array b) = Array $ a <> b
+ mergeValue (Array a) b = Array $ V.snoc a b
+ mergeValue a (Array b) = Array $ V.cons a b
+ mergeValue a b = toJSON [a, b]
+
+instance Monoid MergableObject where
+ mempty = MergableObject mempty
+
+traceObject :: Paths q r a -> Value -> Object
+traceObject Root (Object o) = o
+traceObject Root v = HM.singleton "root" v
+traceObject (root `Snoc` s) v =
+ traceObject root . Object $ HM.singleton (T.pack . show $ s) v
diff --git a/src/Data/OpenApi/Compare/References.hs b/src/Data/OpenApi/Compare/References.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/References.hs
@@ -0,0 +1,48 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.References
+ ( Step (..),
+ dereference,
+ Typeable,
+ )
+where
+
+import Data.HList
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.Maybe
+import Data.OpenApi
+import Data.OpenApi.Compare.Orphans ()
+import Data.OpenApi.Compare.Subtree
+
+instance Typeable a => Steppable (Referenced a) a where
+ data Step (Referenced a) a = InlineStep
+ deriving stock (Eq, Ord, Show)
+
+dereference ::
+ Typeable a =>
+ Traced (Definitions a) ->
+ Traced (Referenced a) ->
+ Traced a
+dereference defs x = case extract x of
+ Inline a ->
+ traced (ask x >>> step InlineStep) a
+ Ref (Reference ref) ->
+ traced (ask defs >>> step (InsOrdHashMapKeyStep ref)) (fromJust $ IOHM.lookup ref $ extract defs)
+
+instance Subtree a => Subtree (Referenced a) where
+ type CheckEnv (Referenced a) = ProdCons (Traced (Definitions a)) ': CheckEnv a
+ type SubtreeLevel (Referenced a) = SubtreeLevel a
+
+ checkStructuralCompatibility (defs `HCons` env) pc' = do
+ let pc = do
+ x <- pc'
+ defs' <- defs
+ pure (dereference defs' x)
+ checkSubstructure env pc
+
+ checkSemanticCompatibility (defs `HCons` env) bhv pc' = do
+ let pc = do
+ x <- pc'
+ defs' <- defs
+ pure (dereference defs' x)
+ checkCompatibility bhv env pc
diff --git a/src/Data/OpenApi/Compare/Report.hs b/src/Data/OpenApi/Compare/Report.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Report.hs
@@ -0,0 +1,399 @@
+module Data.OpenApi.Compare.Report
+ ( generateReport,
+ CheckerOutput (..),
+ ReportInput (..),
+ segregateIssues,
+ ReportStatus (..),
+ Pandoc,
+ ReportConfig (..),
+ ReportTreeStyle (..),
+ ReportMode (..),
+ )
+where
+
+import Control.Monad.Free hiding (unfoldM)
+import Data.Aeson (ToJSON)
+import Data.Default
+import Data.Either
+import Data.Function
+import Data.Functor
+import Data.List.NonEmpty
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map as M
+import Data.Map.Ordered (OMap)
+import qualified Data.Map.Ordered as OM
+import Data.Maybe
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Paths
+import Data.OpenApi.Compare.PathsPrefixTree hiding (empty)
+import qualified Data.OpenApi.Compare.PathsPrefixTree as P hiding (empty)
+import Data.OpenApi.Compare.Report.Jet
+import Data.OpenApi.Compare.Subtree (invertIssueOrientationP)
+import Data.OpenApi.Compare.Validate.OpenApi
+import Data.OpenApi.Compare.Validate.Schema.Issues
+import Data.OpenApi.Compare.Validate.Schema.TypedJson
+import Data.OpenUnion
+import Data.OpenUnion.Extra
+import Data.Set
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.TypeRepMap hiding (empty)
+import Data.Typeable
+import Generic.Data
+import Text.Pandoc.Builder
+
+type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel
+
+data CheckerOutput = CheckerOutput
+ { forwardChanges :: Changes
+ , backwardChanges :: Changes
+ }
+ deriving stock (Generic)
+ deriving (Semigroup, Monoid) via (Generically CheckerOutput)
+ deriving anyclass (ToJSON)
+
+data ReportInput = ReportInput
+ { -- | forward 'CertainIssue', 'ProbablyIssue' and 'Comment'
+ breakingChanges :: Changes
+ , -- | backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'
+ nonBreakingChanges :: Changes
+ , -- | forward and backward 'Unsupported' (assumed to be the same anyway)
+ unsupportedChanges :: Changes
+ , -- | forward and backward 'SchemaInvalid' (assumed to be the same anyway)
+ schemaIssues :: Changes
+ }
+ deriving stock (Generic)
+ deriving (Semigroup, Monoid) via (Generically ReportInput)
+ deriving anyclass (ToJSON)
+
+segregateIssues :: CheckerOutput -> ReportInput
+segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} =
+ ReportInput
+ { breakingChanges = P.filter isBreaking fwd
+ , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck
+ , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck
+ , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck
+ }
+ where
+ isBreaking i = anIssueKind i `elem` [CertainIssue, ProbablyIssue, Comment]
+ isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool
+ isNonBreaking xs i = isBreaking i && all (\j -> not $ relatedAnIssues i j) (P.lookup xs fwd)
+ isUnsupported i = anIssueKind i == Unsupported
+ isSchemaIssue i = anIssueKind i == SchemaInvalid
+
+data ReportStatus
+ = BreakingChanges
+ | NoBreakingChanges
+ | -- | All changes that could be breaking are unsupported – we don't know if
+ -- there actually are any breaking changes.
+ OnlyUnsupportedChanges
+
+data ReportMode = OnlyErrors | All
+ deriving stock (Eq)
+
+data ReportConfig = ReportConfig
+ { treeStyle :: ReportTreeStyle
+ , reportMode :: ReportMode
+ }
+
+instance Default ReportConfig where
+ def =
+ ReportConfig
+ { treeStyle = HeadersTreeStyle
+ , reportMode = All
+ }
+
+data ReportTreeStyle = HeadersTreeStyle | FoldingBlockquotesTreeStyle
+
+twoRowTable :: [(Inlines, Inlines)] -> Blocks
+twoRowTable x = simpleTable (para . fst <$> x) [para . snd <$> x]
+
+generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)
+generateReport cfg inp =
+ let schemaIssuesPresent = not $ P.null $ schemaIssues inp
+ breakingChangesPresent = not $ P.null $ breakingChanges inp
+ nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp
+ unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp
+ nonBreakingChangesShown = case reportMode cfg of
+ All -> True
+ OnlyErrors -> False
+ builder = buildReport cfg
+ report =
+ header 1 "Summary"
+ <> twoRowTable
+ ( when'
+ schemaIssuesPresent
+ [
+ ( refOpt schemaIssuesPresent schemaIssuesId "‼️ Schema issues"
+ , show' $ P.size $ schemaIssues inp
+ )
+ ]
+ ++ [
+ ( refOpt breakingChangesPresent breakingChangesId "❌ Breaking changes"
+ , show' $ P.size $ breakingChanges inp
+ )
+ ]
+ ++ when'
+ nonBreakingChangesShown
+ [
+ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "⚠️ Non-breaking changes"
+ , show' $ P.size $ nonBreakingChanges inp
+ )
+ ]
+ ++ when'
+ unsupportedChangesPresent
+ [
+ ( refOpt unsupportedChangesPresent unsupportedChangesId "❓ Unsupported feature changes"
+ , show' $ P.size $ unsupportedChanges inp
+ )
+ ]
+ )
+ <> when'
+ schemaIssuesPresent
+ ( header 1 (anchor schemaIssuesId <> "‼️ Schema issues")
+ <> builder (showErrs $ schemaIssues inp)
+ )
+ <> when'
+ breakingChangesPresent
+ ( header 1 (anchor breakingChangesId <> "❌ Breaking changes")
+ <> builder (showErrs $ breakingChanges inp)
+ )
+ <> when'
+ (nonBreakingChangesPresent && nonBreakingChangesShown)
+ ( header 1 (anchor nonBreakingChangesId <> "⚠️ Non-breaking changes")
+ <> builder (showErrs $ nonBreakingChanges inp)
+ )
+ <> when'
+ unsupportedChangesPresent
+ ( header 1 (anchor unsupportedChangesId <> "❓ Unsupported feature changes")
+ <> builder (showErrs $ unsupportedChanges inp)
+ )
+ status =
+ if
+ | breakingChangesPresent -> BreakingChanges
+ | unsupportedChangesPresent -> OnlyUnsupportedChanges
+ | otherwise -> NoBreakingChanges
+ in (report, status)
+ where
+ anchor :: Text -> Inlines
+ anchor a = spanWith (a, [], []) mempty
+
+ refOpt :: Bool -> Text -> Inlines -> Inlines
+ refOpt False _ i = i
+ refOpt True a i = link ("#" <> a) "" i
+
+ breakingChangesId, nonBreakingChangesId, unsupportedChangesId, schemaIssuesId :: Text
+ breakingChangesId = "breaking-changes"
+ unsupportedChangesId = "unsupported-changes"
+ nonBreakingChangesId = "non-breaking-changes"
+ schemaIssuesId = "schema-issues"
+
+ when' :: Monoid m => Bool -> m -> m
+ when' True m = m
+ when' False _ = mempty
+
+showErrs :: forall a. Typeable a => P.PathsPrefixTree Behave AnIssue a -> Report
+showErrs x@(P.PathsPrefixNode currentIssues _) =
+ let -- Extract this pattern if more cases like this arise
+ ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])
+ , otherIssues :: Set (AnIssue a)
+ ) = case eqT @a @ 'APILevel of
+ Just Refl
+ | (S.toList -> p@((AnIssue ori _) : _), o) <-
+ S.partition
+ ( \((AnIssue _ u)) -> case u of
+ NoPathsMatched {} -> True
+ AllPathsFailed {} -> True
+ )
+ currentIssues ->
+ let p' = p <&> (\(AnIssue _ i) -> i)
+ in (Just (ori, p'), o)
+ _ -> (Nothing, currentIssues)
+ issues = singletonBody $ case S.toList otherIssues of
+ [AnIssue ori i] -> describeIssue ori i
+ ii -> orderedList $ ii <&> (\(AnIssue ori i) -> describeIssue ori i)
+ paths = case removedPaths of
+ Just (ori, ps) -> do
+ singletonHeader
+ ( case ori of
+ Forward -> "Removed paths"
+ Backward -> "Added paths"
+ )
+ $ singletonBody $
+ bulletList $
+ ps <&> \case
+ (NoPathsMatched p) -> para . code $ T.pack p
+ (AllPathsFailed p) -> para . code $ T.pack p
+ Nothing -> mempty
+ rest = unfoldFunctions x (observeJetShowErrs <$> jets) $ \(P.PathsPrefixNode _ subIssues) -> do
+ flip foldMap subIssues $ \(WrapTypeable (AStep m)) ->
+ flip foldMap (M.toList m) $ \(bhv, subErrors) ->
+ if P.null subErrors
+ then mempty
+ else singletonHeader (describeBehavior bhv) $ showErrs subErrors
+ in issues <> paths <> rest
+
+unfoldFunctions :: forall m a. (Monoid m, Eq a) => a -> [a -> (m, a)] -> (a -> m) -> m
+unfoldFunctions initA fs g = unfoldFunctions' initA fs
+ where
+ unfoldFunctions' :: a -> [a -> (m, a)] -> m
+ unfoldFunctions' a [] | a == initA = g a
+ unfoldFunctions' a [] = unfoldFunctions a fs g
+ unfoldFunctions' a (f : ff) =
+ let (m, a') = f a
+ in unfoldFunctions' a' ff <> m
+
+jets :: [ReportJet' Behave (Maybe Inlines)]
+jets =
+ unwrapReportJetResult
+ <$> [ constructReportJet $
+ curry $ \case
+ (OfType Object, p@(InPartition _)) -> Just $ describeBehavior p :: Maybe Inlines
+ _ -> Nothing
+ , constructReportJet jsonPathJet
+ , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
+ strong (describeBehavior op) <> " " <> describeBehavior p :: Inlines
+ , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
+ "⬅️☁️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "➡️☁️ JSON Request" :: Inlines
+ ]
+ where
+ unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
+ unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."
+ unwrapReportJetResult (Free f) = f
+
+ jsonPathJet ::
+ NonEmpty
+ ( Union
+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
+ , Behave 'TypedSchemaLevel 'SchemaLevel
+ ]
+ ) ->
+ Inlines
+ jsonPathJet x = code $ "$" <> showParts (NE.toList x)
+ where
+ showParts ::
+ [ Union
+ '[ Behave 'SchemaLevel 'TypedSchemaLevel
+ , Behave 'TypedSchemaLevel 'SchemaLevel
+ ]
+ ] ->
+ Text
+ showParts [] = mempty
+ showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs
+ showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs
+ showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs
+ showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs
+ showParts (y : ys) =
+ ( (\(OfType t) -> "(" <> describeJSONType t <> ")")
+ @@> ( \case
+ InItems -> "[*]"
+ InItem i -> "[" <> T.pack (show i) <> "]"
+ InProperty p -> "." <> p
+ InAdditionalProperty -> ".*"
+ )
+ @@> typesExhausted
+ )
+ y
+ <> showParts ys
+
+observeJetShowErrs ::
+ ReportJet' Behave (Maybe Inlines) ->
+ P.PathsPrefixTree Behave AnIssue a ->
+ (Report, P.PathsPrefixTree Behave AnIssue a)
+observeJetShowErrs jet p = case observeJetShowErrs' jet p of
+ Just m -> m
+ Nothing -> (mempty, p)
+
+observeJetShowErrs' ::
+ forall a.
+ ReportJet' Behave (Maybe Inlines) ->
+ P.PathsPrefixTree Behave AnIssue a ->
+ Maybe (Report, P.PathsPrefixTree Behave AnIssue a)
+observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
+ let results =
+ subIssues >>= \(WrapTypeable (AStep m)) ->
+ M.toList m <&> \(bhv, subErrs) ->
+ maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $
+ jet @_ @_ @[] bhv
+ & mapMaybe
+ ( \case
+ Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
+ Pure (Just h) ->
+ if P.null subErrs
+ then Just mempty
+ else Just (singletonHeader h (showErrs subErrs), mempty)
+ Pure Nothing -> Nothing
+ )
+ in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
+ if any isRight results
+ then
+ Just $
+ foldMap
+ ( \case
+ Left e -> (mempty, e)
+ Right m -> m
+ )
+ results
+ else Nothing
+
+data Report = Report {headers :: OMap Inlines Report, body :: Blocks}
+ deriving stock (Generic)
+
+instance Semigroup Report where
+ (Report headers1 b1) <> (Report headers2 b2) = Report (OM.unionWithL (const (<>)) headers1 headers2) (b1 <> b2)
+
+instance Monoid Report where
+ mempty = Report OM.empty mempty
+
+buildReport :: ReportConfig -> Report -> Blocks
+buildReport cfg = case treeStyle cfg of
+ HeadersTreeStyle -> headerStyleBuilder 2
+ FoldingBlockquotesTreeStyle -> foldingStyleBuilder
+ where
+ headerStyleBuilder :: HeaderLevel -> Report -> Blocks
+ headerStyleBuilder level rprt =
+ body rprt
+ <> foldOMapWithKey
+ (headers rprt)
+ ( \k v ->
+ header level k <> subBuilder v
+ )
+ where
+ subBuilder = headerStyleBuilder (level + 1)
+
+ foldingStyleBuilder :: Report -> Blocks
+ foldingStyleBuilder rprt =
+ body rprt
+ <> foldOMapWithKey
+ (headers rprt)
+ ( \k v ->
+ if (OM.size . headers $ rprt) < 2
+ then para k <> blockQuote (subBuilder v)
+ else
+ rawHtml ""
+ <> rawHtml ""
+ <> plain k
+ <> rawHtml "
"
+ <> blockQuote (subBuilder v)
+ <> rawHtml " "
+ )
+ where
+ subBuilder = foldingStyleBuilder
+
+ rawHtml = rawBlock "html"
+
+type HeaderLevel = Int
+
+singletonHeader :: Inlines -> Report -> Report
+singletonHeader i b = Report (OM.singleton (i, b)) mempty
+
+singletonBody :: Blocks -> Report
+singletonBody = Report OM.empty
+
+show' :: Show x => x -> Inlines
+show' = str . T.pack . show
+
+foldOMapWithKey :: Monoid m => OMap k v -> (k -> v -> m) -> m
+foldOMapWithKey m f = foldMap (uncurry f) $ OM.assocs m
diff --git a/src/Data/OpenApi/Compare/Report/Html/Template.hs b/src/Data/OpenApi/Compare/Report/Html/Template.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Report/Html/Template.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.OpenApi.Compare.Report.Html.Template
+ ( template,
+ )
+where
+
+import Control.Monad.Identity
+import Data.ByteString (ByteString)
+import Data.FileEmbed
+import Data.Text (Text)
+import qualified Data.Text.Encoding as T
+import Text.DocTemplates
+
+template :: Template Text
+template =
+ either error id . runIdentity . compileTemplate "" $
+ "\
+ \\
+ \\
+ \\
+ \\
+ \\
+ \\
+ \\
+ \\
+ \\
+ \\
+ \\
+ \\
+ \$body$\
+ \\
+ \\
+ \"
+
+awsmCss :: ByteString
+awsmCss = $(makeRelativeToProject "awsm-css/dist/awsm.min.css" >>= embedFile)
diff --git a/src/Data/OpenApi/Compare/Report/Jet.hs b/src/Data/OpenApi/Compare/Report/Jet.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Report/Jet.hs
@@ -0,0 +1,67 @@
+module Data.OpenApi.Compare.Report.Jet
+ ( ReportJet (..),
+ ReportJet',
+ ConstructReportJet (..),
+ ReportJetResult,
+ )
+where
+
+import Control.Applicative
+import Control.Monad.Free
+import Data.List.NonEmpty
+import qualified Data.List.NonEmpty as NE
+import Data.OpenUnion
+import Data.OpenUnion.Extra
+import Data.Typeable
+import Text.Pandoc.Builder
+
+-- | 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 term "jet" in this context was introduced in the Urbit project:
+-- https://urbit.org/docs/vere/jetting/
+--
+-- The pattern fits well for simplifying 'Behavior' tree paths.
+class ConstructReportJet x f where
+ constructReportJet :: x -> ReportJetResult f (Maybe Inlines)
+
+instance (ConstructReportJet b f, JetArg a) => ConstructReportJet (a -> b) f where
+ constructReportJet f = Free (fmap f <$> consumeJetArg @a) >>= constructReportJet
+
+instance ConstructReportJet (Maybe Inlines) f where
+ constructReportJet x = Pure x
+
+instance ConstructReportJet Inlines f where
+ constructReportJet x = Pure $ Just x
+
+class JetArg a where
+ consumeJetArg :: ReportJet' f a
+
+instance Typeable (f a b) => JetArg (f a b) where
+ consumeJetArg =
+ ReportJet $ \(x :: x) ->
+ case eqT @(f a b) @x of
+ Nothing -> empty
+ Just Refl -> pure $ Pure x
+
+instance TryLiftUnion xs => JetArg (Union xs) where
+ consumeJetArg = ReportJet $ fmap Pure . tryLiftUnion
+
+instance JetArg x => JetArg (NonEmpty x) where
+ consumeJetArg =
+ let (ReportJet f) = (consumeJetArg @x)
+ in ReportJet $ \a -> do
+ u <- f a
+ pure (u >>= \y -> Free $ fmap (NE.cons y) <$> consumeJetArg)
+ <|> pure (pure <$> u)
+
+type ReportJetResult f = Free (ReportJet f)
+
+-- Not a true 'Applicative'
+newtype ReportJet f x
+ = ReportJet (forall a b m. (Typeable (f a b), Alternative m, Monad m) => f a b -> m x)
+ deriving stock (Functor)
+
+type ReportJet' f a = ReportJet f (Free (ReportJet f) a)
diff --git a/src/Data/OpenApi/Compare/Run.hs b/src/Data/OpenApi/Compare/Run.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Run.hs
@@ -0,0 +1,31 @@
+module Data.OpenApi.Compare.Run
+ ( runChecker,
+ runReport,
+ module Data.OpenApi.Compare.Report,
+ )
+where
+
+import Data.HList
+import Data.OpenApi (OpenApi)
+import Data.OpenApi.Compare.Paths
+import Data.OpenApi.Compare.Report
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.OpenApi ()
+import Text.Pandoc.Builder
+
+runChecker :: (OpenApi, OpenApi) -> CheckerOutput
+runChecker (client, server) =
+ CheckerOutput
+ { forwardChanges = run client server
+ , backwardChanges = run server client
+ }
+ where
+ toPC p c =
+ ProdCons
+ { producer = traced (step ClientSchema) p
+ , consumer = traced (step ServerSchema) c
+ }
+ run p c = either id mempty . runCompatFormula . checkCompatibility Root HNil $ toPC p c
+
+runReport :: ReportConfig -> (OpenApi, OpenApi) -> (Blocks, ReportStatus)
+runReport cfg = generateReport cfg . segregateIssues . runChecker
diff --git a/src/Data/OpenApi/Compare/Subtree.hs b/src/Data/OpenApi/Compare/Subtree.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Subtree.hs
@@ -0,0 +1,364 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Subtree
+ ( Steppable (..),
+ Step (..),
+ TraceRoot,
+ Trace,
+ Traced,
+ Traced',
+ pattern Traced,
+ traced,
+ retraced,
+ stepTraced,
+ Subtree (..),
+ checkCompatibility,
+ checkSubstructure,
+ CompatM (..),
+ CompatFormula',
+ SemanticCompatFormula,
+ ProdCons (..),
+ orientProdCons,
+ swapProdCons,
+ runCompatFormula,
+ issueAt,
+ anItem,
+ anIssue,
+ invertIssueOrientation,
+ invertIssueOrientationP,
+ embedFormula,
+ anyOfAt,
+ clarifyIssue,
+ structuralIssue,
+
+ -- * Structural helpers
+ structuralMaybe,
+ structuralMaybeWith,
+ structuralEq,
+ iohmStructural,
+ iohmStructuralWith,
+ structuralList,
+
+ -- * Reexports
+ (>>>),
+ (<<<),
+ extract,
+ ask,
+ local,
+ step,
+ Typeable,
+ )
+where
+
+import Control.Comonad.Env
+import Control.Monad.Identity
+import Control.Monad.State
+import Data.Foldable
+import Data.Functor.Compose
+import Data.HList
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.Hashable
+import Data.Kind
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Formula
+import Data.OpenApi.Compare.Memo
+import Data.OpenApi.Compare.Paths
+import qualified Data.OpenApi.Compare.PathsPrefixTree as P
+import qualified Data.Set as S
+import Data.Typeable
+
+class
+ (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
+ data Step a b :: Type
+
+data TraceRoot
+
+instance Steppable TraceRoot OpenApi where
+ data Step TraceRoot OpenApi
+ = ClientSchema
+ | ServerSchema
+ deriving stock (Eq, Ord, Show)
+
+type Trace = Paths Step TraceRoot
+
+type instance AdditionalQuiverConstraints Step _ _ = ()
+
+type Traced' a b = Env (Trace a) b
+
+type Traced a = Traced' a a
+
+pattern Traced :: Trace a -> b -> Traced' a b
+pattern Traced t x = EnvT t (Identity x)
+
+{-# COMPLETE Traced #-}
+
+traced :: Trace a -> a -> Traced a
+traced = env
+
+retraced :: (Trace a -> Trace a') -> Traced' a b -> Traced' a' b
+retraced f (Traced a b) = Traced (f a) b
+
+stepTraced :: Steppable a a' => Step a a' -> Traced' a b -> Traced' a' b
+stepTraced s = retraced (>>> step s)
+
+data ProdCons a = ProdCons
+ { producer :: a
+ , consumer :: a
+ }
+ deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+orientProdCons :: Orientation -> ProdCons x -> ProdCons x
+orientProdCons Forward x = x
+orientProdCons Backward (ProdCons p c) = ProdCons c p
+
+swapProdCons ::
+ SwapEnvRoles xs =>
+ (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a) ->
+ (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)
+swapProdCons f e (ProdCons p c) =
+ invertIssueOrientation $
+ f (swapEnvRoles e) (ProdCons c p)
+{-# INLINE swapProdCons #-}
+
+type family IsProdCons (x :: Type) :: Bool where
+ IsProdCons (ProdCons _) = 'True
+ IsProdCons _ = 'False
+
+type SwapEnvElementRoles x = SwapEnvElementRoles' x (IsProdCons x)
+
+class IsProdCons x ~ f => SwapEnvElementRoles' (x :: Type) f where
+ swapEnvElementRoles :: x -> x
+
+instance SwapEnvElementRoles' (ProdCons x) 'True where
+ swapEnvElementRoles (ProdCons p c) = ProdCons c p
+
+instance IsProdCons x ~ 'False => SwapEnvElementRoles' x 'False where
+ swapEnvElementRoles = id
+
+class SwapEnvRoles xs where
+ swapEnvRoles :: HList xs -> HList xs
+
+instance SwapEnvRoles '[] where
+ swapEnvRoles = id
+
+instance (SwapEnvElementRoles x, SwapEnvRoles xs) => SwapEnvRoles (x ': xs) where
+ swapEnvRoles (HCons x xs) = HCons (swapEnvElementRoles x) (swapEnvRoles xs)
+
+instance Applicative ProdCons where
+ pure x = ProdCons x x
+ ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)
+
+newtype CompatM a = CompatM
+ { unCompatM ::
+ StateT (MemoState VarRef) Identity a
+ }
+ deriving newtype
+ ( Functor
+ , Applicative
+ , Monad
+ , MonadState (MemoState VarRef)
+ )
+
+type CompatFormula' q f r = Compose CompatM (FormulaF q f r)
+
+type SemanticCompatFormula = CompatFormula' Behave AnIssue 'APILevel
+
+type StructuralCompatFormula = CompatFormula' VoidQuiver Proxy ()
+
+data VoidQuiver a b
+
+deriving stock instance Eq (VoidQuiver a b)
+
+type instance AdditionalQuiverConstraints VoidQuiver _ _ = ()
+
+deriving stock instance Ord (VoidQuiver a b)
+
+deriving stock instance Show (VoidQuiver a b)
+
+class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where
+ type CheckEnv t :: [Type]
+ type SubtreeLevel t :: BehaviorLevel
+
+ checkStructuralCompatibility ::
+ HList (CheckEnv t) ->
+ ProdCons (Traced t) ->
+ StructuralCompatFormula ()
+
+ checkSemanticCompatibility ::
+ HList (CheckEnv t) ->
+ Behavior (SubtreeLevel t) ->
+ ProdCons (Traced t) ->
+ SemanticCompatFormula ()
+
+{-# WARNING checkStructuralCompatibility "You should not be calling this directly. Use 'checkSubstructure'" #-}
+
+{-# WARNING checkSemanticCompatibility "You should not be calling this directly. Use 'checkCompatibility'" #-}
+
+checkCompatibility ::
+ forall t xs.
+ (ReassembleHList xs (CheckEnv t), Subtree t) =>
+ Behavior (SubtreeLevel t) ->
+ HList xs ->
+ ProdCons (Traced t) ->
+ SemanticCompatFormula ()
+checkCompatibility bhv e = memo bhv SemanticMemoKey $ \pc ->
+ case runCompatFormula $ checkSubstructure e pc of
+ Left _ -> checkSemanticCompatibility (reassemble e) bhv pc
+ Right () -> pure ()
+{-# INLINE checkCompatibility #-}
+
+checkSubstructure ::
+ (ReassembleHList xs (CheckEnv t), Subtree t) =>
+ HList xs ->
+ ProdCons (Traced t) ->
+ StructuralCompatFormula ()
+checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility (reassemble e)
+{-# INLINE checkSubstructure #-}
+
+structuralMaybe ::
+ (Subtree a, ReassembleHList xs (CheckEnv a)) =>
+ HList xs ->
+ ProdCons (Maybe (Traced a)) ->
+ StructuralCompatFormula ()
+structuralMaybe e = structuralMaybeWith (checkSubstructure e)
+{-# INLINE structuralMaybe #-}
+
+structuralMaybeWith ::
+ (ProdCons a -> StructuralCompatFormula ()) ->
+ ProdCons (Maybe a) ->
+ StructuralCompatFormula ()
+structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b
+structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()
+structuralMaybeWith _ _ = structuralIssue
+{-# INLINE structuralMaybeWith #-}
+
+structuralList ::
+ (Subtree a, ReassembleHList xs (CheckEnv a)) =>
+ HList xs ->
+ ProdCons [Traced a] ->
+ StructuralCompatFormula ()
+structuralList _ (ProdCons [] []) = pure ()
+structuralList e (ProdCons (a : aa) (b : bb)) = do
+ checkSubstructure e $ ProdCons a b
+ structuralList e $ ProdCons aa bb
+ pure ()
+structuralList _ _ = structuralIssue
+{-# INLINE structuralList #-}
+
+structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula ()
+structuralEq (ProdCons a b) = if extract a == extract b then pure () else structuralIssue
+{-# INLINE structuralEq #-}
+
+iohmStructural ::
+ (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k) =>
+ HList xs ->
+ ProdCons (Traced (IOHM.InsOrdHashMap k v)) ->
+ StructuralCompatFormula ()
+iohmStructural e =
+ iohmStructuralWith (\k -> checkSubstructure (k `HCons` e))
+{-# INLINE iohmStructural #-}
+
+instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMap k v) v where
+ data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k
+ deriving stock (Eq, Ord, Show)
+
+iohmStructuralWith ::
+ (Ord k, Hashable k, Typeable k, Typeable v, Show k) =>
+ (k -> ProdCons (Traced v) -> StructuralCompatFormula ()) ->
+ ProdCons (Traced (IOHM.InsOrdHashMap k v)) ->
+ StructuralCompatFormula ()
+iohmStructuralWith f pc = do
+ let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys . extract <$> pc
+ if pEKeys == cEKeys
+ then
+ for_
+ pEKeys
+ ( \eKey ->
+ f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc
+ )
+ else structuralIssue
+{-# INLINE iohmStructuralWith #-}
+
+runCompatFormula ::
+ CompatFormula' q f r a ->
+ Either (P.PathsPrefixTree q f r) a
+runCompatFormula (Compose f) =
+ calculate . runIdentity . runMemo 0 . unCompatM $ f
+{-# INLINE runCompatFormula #-}
+
+embedFormula :: Paths q r l -> CompatFormula' q f l a -> CompatFormula' q f r a
+embedFormula bhv (Compose x) = Compose $ mapErrors (P.embed bhv) <$> x
+
+issueAt :: Issuable l => Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
+issueAt xs issue = Compose $ pure $ anError $ AnItem xs $ anIssue issue
+{-# INLINE issueAt #-}
+
+anIssue :: Issuable l => Issue l -> AnIssue l
+anIssue = AnIssue Forward
+{-# INLINE anIssue #-}
+
+anItem :: AnItem q AnIssue r -> CompatFormula' q AnIssue r a
+anItem = Compose . pure . anError
+{-# INLINE anItem #-}
+
+invertIssueOrientation :: CompatFormula' q AnIssue r a -> CompatFormula' q AnIssue r a
+invertIssueOrientation (Compose x) =
+ Compose $ mapErrors invertIssueOrientationP <$> x
+
+invertIssueOrientationP :: P.PathsPrefixTree q AnIssue r -> P.PathsPrefixTree q AnIssue r
+invertIssueOrientationP = P.map (\(AnIssue ori i) -> AnIssue (toggleOrientation ori) i)
+
+structuralIssue :: StructuralCompatFormula a
+structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy
+
+anyOfAt ::
+ Issuable l =>
+ Paths q r l ->
+ Issue l ->
+ [CompatFormula' q AnIssue r a] ->
+ CompatFormula' q AnIssue r a
+anyOfAt _ _ [x] = x
+anyOfAt xs issue fs =
+ Compose $ (`eitherOf` AnItem xs (anIssue issue)) <$> traverse getCompose fs
+
+-- | If the given formula contains any issues, add another issue on top. Otherwise succeed.
+clarifyIssue ::
+ AnItem q AnIssue r ->
+ CompatFormula' q AnIssue r a ->
+ CompatFormula' q AnIssue r a
+clarifyIssue item f =
+ Compose ((`eitherOf` item) <$> pure <$> getCompose f) *> f
+
+fixpointKnot ::
+ MonadState (MemoState VarRef) m =>
+ KnotTier (FormulaF q f r ()) VarRef m
+fixpointKnot =
+ KnotTier
+ { onKnotFound = modifyMemoNonce succ
+ , onKnotUsed = \i -> pure $ variable i
+ , tieKnot = \i x -> pure $ maxFixpoint i x
+ }
+
+memo ::
+ (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a) =>
+ Paths q r l ->
+ MemoKey ->
+ (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.takeSubtree bhv) formula
+ )
+ (k, ask <$> pc)
+ pure $ mapErrors (P.embed bhv) formula'
+
+data MemoKey = SemanticMemoKey | StructuralMemoKey
+ deriving stock (Eq, Ord)
diff --git a/src/Data/OpenApi/Compare/Validate/Header.hs b/src/Data/OpenApi/Compare/Validate/Header.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Header.hs
@@ -0,0 +1,66 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.Header
+ (
+ )
+where
+
+import Data.Foldable
+import Data.Functor
+import Data.Maybe
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.References ()
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Schema ()
+import Text.Pandoc.Builder
+
+instance Subtree Header where
+ type SubtreeLevel Header = 'HeaderLevel
+ type CheckEnv Header = '[ProdCons (Traced (Definitions Schema))]
+ checkStructuralCompatibility env pc = do
+ structuralEq $ fmap _headerRequired <$> pc
+ structuralEq $ fmap _headerAllowEmptyValue <$> pc
+ structuralEq $ fmap _headerExplode <$> pc
+ structuralMaybe env $ tracedSchema <$> pc
+ pure ()
+ checkSemanticCompatibility env beh (ProdCons p c) = do
+ if (fromMaybe False $ _headerRequired $ extract c) && not (fromMaybe False $ _headerRequired $ extract p)
+ then issueAt beh RequiredHeaderMissing
+ else pure ()
+ if not (fromMaybe False $ _headerAllowEmptyValue $ extract c) && (fromMaybe False $ _headerAllowEmptyValue $ extract p)
+ then issueAt beh NonEmptyHeaderRequired
+ else pure ()
+ for_ (tracedSchema c) $ \consRef ->
+ case tracedSchema p of
+ Nothing -> issueAt beh HeaderSchemaRequired
+ Just prodRef -> checkCompatibility (beh >>> step InSchema) env (ProdCons prodRef consRef)
+ pure ()
+
+instance Steppable Header (Referenced Schema) where
+ data Step Header (Referenced Schema) = HeaderSchema
+ deriving stock (Eq, Ord, Show)
+
+tracedSchema :: Traced Header -> Maybe (Traced (Referenced Schema))
+tracedSchema hdr = _headerSchema (extract hdr) <&> traced (ask hdr >>> step HeaderSchema)
+
+instance Issuable 'HeaderLevel where
+ data Issue 'HeaderLevel
+ = RequiredHeaderMissing
+ | NonEmptyHeaderRequired
+ | HeaderSchemaRequired
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ HeaderSchemaRequired -> ProbablyIssue -- catch-all schema?
+ _ -> CertainIssue
+ describeIssue Forward RequiredHeaderMissing = para "Header has become required."
+ describeIssue Backward RequiredHeaderMissing = para "Header is no longer required."
+ describeIssue Forward NonEmptyHeaderRequired = para "The header does not allow empty values anymore."
+ describeIssue Backward NonEmptyHeaderRequired = para "The header now allows empty values."
+ 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)
+ describeBehavior InSchema = "JSON Schema"
diff --git a/src/Data/OpenApi/Compare/Validate/Link.hs b/src/Data/OpenApi/Compare/Validate/Link.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Link.hs
@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.Link () where
+
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Subtree
+import Text.Pandoc.Builder
+
+instance Subtree Link where
+ type SubtreeLevel Link = 'LinkLevel
+ type CheckEnv Link = '[]
+ checkStructuralCompatibility _ _ = structuralIssue
+ checkSemanticCompatibility _ bhv _ = issueAt bhv LinksUnsupported
+
+instance Issuable 'LinkLevel where
+ data Issue 'LinkLevel
+ = LinksUnsupported
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ LinksUnsupported -> Unsupported
+ describeIssue _ LinksUnsupported = para "CompaREST does not currently support Link Objects."
diff --git a/src/Data/OpenApi/Compare/Validate/MediaTypeObject.hs b/src/Data/OpenApi/Compare/Validate/MediaTypeObject.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/MediaTypeObject.hs
@@ -0,0 +1,169 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.MediaTypeObject
+ ( Issue (..),
+ Behave (..),
+ )
+where
+
+import Data.Foldable as F
+import Data.Functor
+import Data.HList
+import Data.HashMap.Strict.InsOrd as IOHM
+import Data.Map.Strict as M
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Header ()
+import Data.OpenApi.Compare.Validate.Products
+import Data.OpenApi.Compare.Validate.Schema ()
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.HTTP.Media (MediaType, mainType, subType)
+import Text.Pandoc.Builder
+
+tracedSchema :: Traced MediaTypeObject -> Maybe (Traced (Referenced Schema))
+tracedSchema mto = _mediaTypeObjectSchema (extract mto) <&> traced (ask mto >>> step MediaTypeSchema)
+
+-- FIXME: This should be done through 'MediaTypeEncodingMapping'
+tracedEncoding :: Traced MediaTypeObject -> InsOrdHashMap Text (Traced Encoding)
+tracedEncoding mto =
+ IOHM.mapWithKey (\k -> traced (ask mto >>> step (MediaTypeParamEncoding k))) $
+ _mediaTypeObjectEncoding $ extract mto
+
+instance Issuable 'PayloadLevel where
+ data Issue 'PayloadLevel
+ = MediaTypeSchemaRequired
+ | MediaEncodingMissing Text
+ | EncodingNotSupported
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ EncodingNotSupported -> Unsupported
+ _ -> CertainIssue
+
+ describeIssue _ MediaTypeSchemaRequired = para "Media type expected, but was not specified."
+ describeIssue Forward (MediaEncodingMissing enc) = para $ "Media encoding " <> str enc <> " has been removed."
+ describeIssue Backward (MediaEncodingMissing enc) = para $ "Media encoding " <> str enc <> " added."
+ describeIssue _ EncodingNotSupported = para "CompaREST does not currently support media encodings other than JSON."
+
+instance Behavable 'PayloadLevel 'SchemaLevel where
+ data Behave 'PayloadLevel 'SchemaLevel
+ = PayloadSchema
+ deriving stock (Eq, Ord, Show)
+ describeBehavior PayloadSchema = "JSON Schema"
+
+instance Subtree MediaTypeObject where
+ type SubtreeLevel MediaTypeObject = 'PayloadLevel
+ type
+ CheckEnv MediaTypeObject =
+ '[ MediaType
+ , ProdCons (Traced (Definitions Schema))
+ , ProdCons (Traced (Definitions Header))
+ ]
+ checkStructuralCompatibility env pc = do
+ structuralMaybe env $ tracedSchema <$> pc
+ structuralEq $ fmap _mediaTypeObjectExample <$> pc
+ iohmStructural env $ stepTraced MediaTypeEncodingMapping . fmap _mediaTypeObjectEncoding <$> pc
+ pure ()
+ checkSemanticCompatibility env beh prodCons@(ProdCons p c) = do
+ if
+ | "multipart" == mainType mediaType -> checkEncoding
+ | "application" == mainType mediaType
+ && "x-www-form-urlencoded" == subType mediaType ->
+ checkEncoding
+ | otherwise -> pure ()
+ -- If consumer requires schema then producer must produce compatible
+ -- request
+ for_ (tracedSchema c) $ \consRef ->
+ case tracedSchema p of
+ Nothing -> issueAt beh MediaTypeSchemaRequired
+ Just prodRef ->
+ checkCompatibility (beh >>> step PayloadSchema) env $
+ ProdCons prodRef consRef
+ pure ()
+ where
+ mediaType = getH @MediaType env
+ checkEncoding =
+ let -- Parameters of the media type are product-like entities
+ getEncoding mt =
+ M.fromList $
+ (IOHM.toList $ tracedEncoding mt) <&> \(k, enc) ->
+ ( k
+ , ProductLike
+ { productValue = enc
+ , required = True
+ }
+ )
+ encProdCons = getEncoding <$> prodCons
+ in checkProducts
+ beh
+ MediaEncodingMissing
+ (const $ checkCompatibility beh env)
+ encProdCons
+
+instance Subtree Encoding where
+ type SubtreeLevel Encoding = 'PayloadLevel
+ type
+ CheckEnv Encoding =
+ '[ ProdCons (Traced (Definitions Header))
+ , ProdCons (Traced (Definitions Schema))
+ ]
+ checkStructuralCompatibility env pc = do
+ structuralEq $ fmap _encodingContentType <$> pc
+ iohmStructural env $ stepTraced EncodingHeaderStep . fmap _encodingHeaders <$> pc
+ structuralEq $ fmap _encodingStyle <$> pc
+ structuralEq $ fmap _encodingExplode <$> pc
+ structuralEq $ fmap _encodingAllowReserved <$> pc
+ pure ()
+
+ -- FIXME: Support only JSON body for now. Then Encoding is checked only for
+ -- multipart/form-url-encoded
+ -- #54
+ checkSemanticCompatibility _env beh _pc =
+ issueAt beh EncodingNotSupported
+
+instance Steppable MediaTypeObject (Referenced Schema) where
+ data Step MediaTypeObject (Referenced Schema) = MediaTypeSchema
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable MediaTypeObject (Definitions Encoding) where
+ data Step MediaTypeObject (Definitions Encoding) = MediaTypeEncodingMapping
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable MediaTypeObject Encoding where
+ data Step MediaTypeObject Encoding = MediaTypeParamEncoding Text
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable Encoding (Definitions (Referenced Header)) where
+ data Step Encoding (Definitions (Referenced Header)) = EncodingHeaderStep
+ deriving stock (Eq, Ord, Show)
+
+instance Behavable 'OperationLevel 'ResponseLevel where
+ data Behave 'OperationLevel 'ResponseLevel
+ = WithStatusCode HttpStatusCode
+ deriving stock (Eq, Ord, Show)
+ describeBehavior (WithStatusCode c) = "Response code " <> (fromString . show $ c)
+
+instance Issuable 'OperationLevel where
+ data Issue 'OperationLevel
+ = ConsumerDoesntHaveResponseCode HttpStatusCode
+ | ParamNotMatched Text
+ | PathFragmentNotMatched Int
+ | NoRequestBody
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ _ -> CertainIssue
+ describeIssue Forward (ConsumerDoesntHaveResponseCode c) =
+ para $ "Response code " <> (str . T.pack . show $ c) <> " has been removed."
+ describeIssue Backward (ConsumerDoesntHaveResponseCode c) =
+ para $ "Response code " <> (str . T.pack . show $ c) <> " has been added."
+ describeIssue Forward (ParamNotMatched param) =
+ para $ "Parameter " <> code param <> " has become required."
+ describeIssue Backward (ParamNotMatched param) =
+ para $ "Parameter " <> code param <> " is no longer required."
+ 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 Forward NoRequestBody = para "Request body has been added."
+ describeIssue Backward NoRequestBody = para "Request body has been removed."
diff --git a/src/Data/OpenApi/Compare/Validate/OAuth2Flows.hs b/src/Data/OpenApi/Compare/Validate/OAuth2Flows.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/OAuth2Flows.hs
@@ -0,0 +1,170 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.OAuth2Flows
+ ( Step (..),
+ Issue (..),
+ Behave (..),
+ )
+where
+
+import Control.Monad
+import Data.Function
+import Data.Functor
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Orphans ()
+import Data.OpenApi.Compare.Subtree
+import Data.Proxy
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import Text.Pandoc.Builder
+
+instance Subtree OAuth2Flows where
+ type CheckEnv OAuth2Flows = '[]
+ type SubtreeLevel OAuth2Flows = 'SecuritySchemeLevel
+ checkStructuralCompatibility _ = structuralEq
+ checkSemanticCompatibility env bhv pc = do
+ let supportFlow ::
+ (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t) =>
+ Issue 'SecuritySchemeLevel ->
+ ProdCons (Maybe (Traced t)) ->
+ SemanticCompatFormula ()
+ supportFlow i x = case x of
+ -- producer will not attempt this flow
+ (ProdCons Nothing _) -> pure ()
+ -- producer can attempt a flow the consumer does not know about
+ (ProdCons (Just _) Nothing) -> issueAt bhv i
+ (ProdCons (Just p) (Just c)) ->
+ checkCompatibility bhv env $ ProdCons p c
+ getFlow ::
+ Typeable x =>
+ (OAuth2Flows -> Maybe (OAuth2Flow x)) ->
+ Traced OAuth2Flows ->
+ Maybe (Traced (OAuth2Flow x))
+ getFlow f (Traced t a) = Traced (t >>> step (OAuth2FlowsFlow Proxy)) <$> f a
+ supportFlow ConsumerDoesNotSupportImplicitFlow $ getFlow _oAuth2FlowsImplicit <$> pc
+ supportFlow ConsumerDoesNotSupportPasswordFlow $ getFlow _oAuth2FlowsPassword <$> pc
+ supportFlow ConsumerDoesNotSupportClientCridentialsFlow $ getFlow _oAuth2FlowsClientCredentials <$> pc
+ supportFlow ConsumerDoesNotSupportAuthorizationCodeFlow $ getFlow _oAuth2FlowsAuthorizationCode <$> pc
+ pure ()
+
+instance Typeable t => Steppable OAuth2Flows (OAuth2Flow t) where
+ data Step OAuth2Flows (OAuth2Flow t) = OAuth2FlowsFlow (Proxy t)
+ deriving stock (Eq, Ord, Show)
+
+instance (Typeable t, Subtree t, SubtreeLevel (OAuth2Flow t) ~ SubtreeLevel t) => Subtree (OAuth2Flow t) where
+ type CheckEnv (OAuth2Flow t) = CheckEnv t
+ type SubtreeLevel (OAuth2Flow t) = 'SecuritySchemeLevel
+ checkStructuralCompatibility = undefined
+ checkSemanticCompatibility env bhv prodCons@(ProdCons p c) = do
+ let ProdCons pScopes cScopes = S.fromList . IOHM.keys . _oAuth2Scopes . extract <$> prodCons
+ missingScopes = cScopes S.\\ pScopes
+ unless (S.null missingScopes) (issueAt bhv $ ScopesMissing missingScopes)
+ checkCompatibility bhv env $ retraced (>>> step (OAuth2FlowParamsStep Proxy)) . fmap _oAuth2Params <$> prodCons
+ unless (((==) `on` _oAath2RefreshUrl . extract) p c) $ issueAt bhv RefreshUrlsDontMatch
+ pure ()
+
+instance Typeable t => Steppable (OAuth2Flow t) t where
+ data Step (OAuth2Flow t) t = OAuth2FlowParamsStep (Proxy t)
+ deriving stock (Eq, Ord, Show)
+
+instance Subtree OAuth2ImplicitFlow where
+ type SubtreeLevel OAuth2ImplicitFlow = 'SecuritySchemeLevel
+ type CheckEnv OAuth2ImplicitFlow = '[]
+ checkStructuralCompatibility = undefined
+ checkSemanticCompatibility _ bhv (ProdCons p c) =
+ unless (extract p == extract c) $ issueAt bhv OAuth2ImplicitFlowNotEqual
+
+instance Subtree OAuth2PasswordFlow where
+ type SubtreeLevel OAuth2PasswordFlow = 'SecuritySchemeLevel
+ type CheckEnv OAuth2PasswordFlow = '[]
+ checkStructuralCompatibility = undefined
+ checkSemanticCompatibility _ bhv (ProdCons p c) =
+ unless (extract p == extract c) $ issueAt bhv OAuth2PasswordFlowNotEqual
+
+instance Subtree OAuth2ClientCredentialsFlow where
+ type SubtreeLevel OAuth2ClientCredentialsFlow = 'SecuritySchemeLevel
+ type CheckEnv OAuth2ClientCredentialsFlow = '[]
+ checkStructuralCompatibility = undefined
+ checkSemanticCompatibility _ bhv (ProdCons p c) =
+ unless (extract p == extract c) $ issueAt bhv OAuth2ClientCredentialsFlowNotEqual
+
+instance Subtree OAuth2AuthorizationCodeFlow where
+ type SubtreeLevel OAuth2AuthorizationCodeFlow = 'SecuritySchemeLevel
+ type CheckEnv OAuth2AuthorizationCodeFlow = '[]
+ checkStructuralCompatibility = undefined
+ checkSemanticCompatibility _ bhv (ProdCons p c) =
+ unless (extract p == extract c) $ issueAt bhv OAuth2AuthorizationCodeFlowNotEqual
+
+instance Issuable 'SecurityRequirementLevel where
+ data Issue 'SecurityRequirementLevel
+ = SecurityRequirementNotMet
+ | UndefinedSecurityScheme Text
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ SecurityRequirementNotMet -> CertainIssue
+ UndefinedSecurityScheme _ -> SchemaInvalid
+ describeIssue Forward SecurityRequirementNotMet = para "Security scheme has been removed."
+ describeIssue Backward SecurityRequirementNotMet = para "Security scheme was added."
+ describeIssue _ (UndefinedSecurityScheme k) = para $ "Security scheme " <> code k <> " is not defined."
+
+instance Issuable 'SecuritySchemeLevel where
+ data Issue 'SecuritySchemeLevel
+ = RefreshUrlsDontMatch
+ | HttpSchemeTypesDontMatch HttpSchemeType HttpSchemeType
+ | ApiKeyParamsDontMatch ApiKeyParams ApiKeyParams
+ | OpenIdConnectUrlsDontMatch URL URL
+ | CustomHttpSchemesDontMatch Text Text
+ | ConsumerDoesNotSupportImplicitFlow
+ | ConsumerDoesNotSupportPasswordFlow
+ | ConsumerDoesNotSupportClientCridentialsFlow
+ | ConsumerDoesNotSupportAuthorizationCodeFlow
+ | SecuritySchemeNotMatched
+ | OAuth2ImplicitFlowNotEqual
+ | OAuth2PasswordFlowNotEqual
+ | OAuth2ClientCredentialsFlowNotEqual
+ | OAuth2AuthorizationCodeFlowNotEqual
+ | ScopesMissing (Set Text)
+ | DifferentSecuritySchemes
+ | CanNotHaveScopes
+ | ScopeNotDefined Text
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ CanNotHaveScopes -> SchemaInvalid
+ ScopeNotDefined _ -> SchemaInvalid
+ _ -> CertainIssue
+ describeIssue _ RefreshUrlsDontMatch = para "Refresh URL changed."
+ describeIssue _ (HttpSchemeTypesDontMatch _ _) = para "HTTP scheme type changed."
+ describeIssue _ (ApiKeyParamsDontMatch _ _) = para "API Key parameters changed."
+ describeIssue _ (OpenIdConnectUrlsDontMatch _ _) = para "OpenID Connect URL changed."
+ describeIssue _ (CustomHttpSchemesDontMatch e a) =
+ para $ "Changed HTTP scheme from " <> code e <> " to " <> code a <> "."
+ describeIssue Forward ConsumerDoesNotSupportImplicitFlow = para "Implicit flow support has been removed."
+ describeIssue Backward ConsumerDoesNotSupportImplicitFlow = para "Implicit flow support has been added."
+ describeIssue Forward ConsumerDoesNotSupportPasswordFlow = para "Password flow support has been removed."
+ describeIssue Backward ConsumerDoesNotSupportPasswordFlow = para "Password flow support has been added."
+ describeIssue Forward ConsumerDoesNotSupportClientCridentialsFlow = para "Client Cridentials flow support has been removed."
+ describeIssue Backward ConsumerDoesNotSupportClientCridentialsFlow = para "Client Cridentials flow support has been added."
+ describeIssue Forward ConsumerDoesNotSupportAuthorizationCodeFlow = para "Authorization Code flow support has been removed."
+ describeIssue Backward ConsumerDoesNotSupportAuthorizationCodeFlow = para "Authorization Code flow support has been added."
+ describeIssue Forward SecuritySchemeNotMatched = para "Security scheme has been removed."
+ describeIssue Backward SecuritySchemeNotMatched = para "Security scheme has been added."
+ describeIssue _ OAuth2ImplicitFlowNotEqual = para "Implicit Flow changed."
+ describeIssue _ OAuth2PasswordFlowNotEqual = para "Password Flow changed."
+ describeIssue _ OAuth2ClientCredentialsFlowNotEqual = para "Client Cridentials Flow changed."
+ describeIssue _ OAuth2AuthorizationCodeFlowNotEqual = para "Authorization Code Flow changed."
+ describeIssue Forward (ScopesMissing ss) =
+ para "New scopes required:" <> bulletList (S.toList ss <&> codeBlock)
+ describeIssue Backward (ScopesMissing ss) =
+ para "Scopes no longer required:" <> 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)
+ describeBehavior (SecuritySchemeStep s) = text s
diff --git a/src/Data/OpenApi/Compare/Validate/OpenApi.hs b/src/Data/OpenApi/Compare/Validate/OpenApi.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/OpenApi.hs
@@ -0,0 +1,129 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+-- Does not compiles otherwise
+{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}
+
+module Data.OpenApi.Compare.Validate.OpenApi
+ ( Behave (..),
+ Issue (..),
+ )
+where
+
+import Data.HList
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Paths
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Operation
+
+tracedPaths :: Traced OpenApi -> Traced ProcessedPathItems
+tracedPaths oa =
+ traced
+ (ask oa >>> step OpenApiPathsStep)
+ (processPathItems . IOHM.toList . _openApiPaths . extract $ oa)
+
+tracedRequestBodies :: Traced OpenApi -> Traced (Definitions RequestBody)
+tracedRequestBodies oa =
+ traced
+ (ask oa >>> step ComponentsRequestBody)
+ (_componentsRequestBodies . _openApiComponents . extract $ oa)
+
+tracedParameters :: Traced OpenApi -> Traced (Definitions Param)
+tracedParameters oa =
+ traced
+ (ask oa >>> step ComponentsParam)
+ (_componentsParameters . _openApiComponents . extract $ oa)
+
+tracedSecuritySchemes :: Traced OpenApi -> Traced (Definitions SecurityScheme)
+tracedSecuritySchemes oa =
+ traced
+ (ask oa >>> step ComponentsSecurityScheme)
+ (_componentsSecuritySchemes . _openApiComponents . extract $ oa)
+
+tracedResponses :: Traced OpenApi -> Traced (Definitions Response)
+tracedResponses oa =
+ traced
+ (ask oa >>> step ComponentsResponse)
+ (_componentsResponses . _openApiComponents . extract $ oa)
+
+tracedHeaders :: Traced OpenApi -> Traced (Definitions Header)
+tracedHeaders oa =
+ traced
+ (ask oa >>> step ComponentsHeader)
+ (_componentsHeaders . _openApiComponents . extract $ oa)
+
+tracedSchemas :: Traced OpenApi -> Traced (Definitions Schema)
+tracedSchemas oa =
+ traced
+ (ask oa >>> step ComponentsSchema)
+ (_componentsSchemas . _openApiComponents . extract $ oa)
+
+tracedLinks :: Traced OpenApi -> Traced (Definitions Link)
+tracedLinks oa =
+ traced
+ (ask oa >>> step ComponentsLink)
+ (_componentsLinks . _openApiComponents . extract $ oa)
+
+tracedCallbacks :: Traced OpenApi -> Traced (Definitions Callback)
+tracedCallbacks (Traced t x) =
+ Traced
+ (t >>> step ComponentsCallbacks)
+ (_componentsCallbacks . _openApiComponents $ x)
+
+instance Subtree OpenApi where
+ type SubtreeLevel OpenApi = 'APILevel
+ type CheckEnv OpenApi = '[]
+
+ -- There is no real reason to do a proper implementation
+ checkStructuralCompatibility _ _ = structuralIssue
+ checkSemanticCompatibility _ beh prodCons = do
+ checkCompatibility @ProcessedPathItems
+ beh
+ ( (tracedRequestBodies <$> prodCons)
+ `HCons` (tracedParameters <$> prodCons)
+ `HCons` (tracedSecuritySchemes <$> prodCons)
+ `HCons` (tracedResponses <$> prodCons)
+ `HCons` (tracedHeaders <$> prodCons)
+ `HCons` (tracedSchemas <$> prodCons)
+ `HCons` (_openApiServers . extract <$> prodCons)
+ `HCons` (tracedLinks <$> prodCons)
+ `HCons` (tracedCallbacks <$> prodCons)
+ `HCons` HNil
+ )
+ (tracedPaths <$> prodCons)
+
+instance Steppable OpenApi ProcessedPathItems where
+ data Step OpenApi ProcessedPathItems = OpenApiPathsStep
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions RequestBody) where
+ data Step OpenApi (Definitions RequestBody) = ComponentsRequestBody
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Param) where
+ data Step OpenApi (Definitions Param) = ComponentsParam
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions SecurityScheme) where
+ data Step OpenApi (Definitions SecurityScheme) = ComponentsSecurityScheme
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Response) where
+ data Step OpenApi (Definitions Response) = ComponentsResponse
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Header) where
+ data Step OpenApi (Definitions Header) = ComponentsHeader
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Schema) where
+ data Step OpenApi (Definitions Schema) = ComponentsSchema
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Link) where
+ data Step OpenApi (Definitions Link) = ComponentsLink
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable OpenApi (Definitions Callback) where
+ data Step OpenApi (Definitions Callback) = ComponentsCallbacks
+ deriving stock (Eq, Ord, Show)
diff --git a/src/Data/OpenApi/Compare/Validate/Operation.hs b/src/Data/OpenApi/Compare/Validate/Operation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Operation.hs
@@ -0,0 +1,583 @@
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}
+
+module Data.OpenApi.Compare.Validate.Operation
+ ( -- * Operation
+ MatchedOperation (..),
+ OperationMethod (..),
+ pathItemMethod,
+
+ -- * ProcessedPathItem
+ ProcessedPathItem (..),
+ ProcessedPathItems (..),
+ processPathItems,
+ Step (..),
+ Behave (..),
+ Issue (..),
+ )
+where
+
+import Control.Arrow
+import Control.Comonad.Env
+import Control.Monad
+import Data.Foldable as F
+import Data.Functor
+import Data.HList
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import qualified Data.List as L
+import Data.Map.Strict as M
+import Data.Maybe
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.References
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.MediaTypeObject
+import Data.OpenApi.Compare.Validate.OAuth2Flows
+import Data.OpenApi.Compare.Validate.PathFragment
+import Data.OpenApi.Compare.Validate.Products
+import Data.OpenApi.Compare.Validate.RequestBody
+import Data.OpenApi.Compare.Validate.Responses
+import Data.OpenApi.Compare.Validate.SecurityRequirement ()
+import Data.OpenApi.Compare.Validate.Server ()
+import Data.OpenApi.Compare.Validate.Sums
+import Data.String
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.Pandoc.Builder
+
+data MatchedOperation = MatchedOperation
+ { operation :: !Operation
+ , -- | Params from the PathItem
+ pathParams :: ![Traced Param]
+ , -- | Path fragments traced from PathItem. Takes full list of
+ -- operation-specific parameters
+ getPathFragments :: !([Traced Param] -> [Traced PathFragmentParam])
+ }
+
+type ParamKey = (ParamLocation, Text)
+
+paramKey :: Param -> ParamKey
+paramKey param = (_paramIn param, _paramName param)
+
+tracedParameters :: Traced MatchedOperation -> [Traced (Referenced Param)]
+tracedParameters oper =
+ [ traced (ask oper >>> step (OperationParamsStep i)) x
+ | (i, x) <- zip [0 ..] $ _operationParameters . operation $ extract oper
+ ]
+
+tracedRequestBody :: Traced MatchedOperation -> Maybe (Traced (Referenced RequestBody))
+tracedRequestBody oper = _operationRequestBody (operation $ extract oper) <&> traced (ask oper >>> step OperationRequestBodyStep)
+
+tracedResponses :: Traced MatchedOperation -> Traced Responses
+tracedResponses oper =
+ traced (ask oper >>> step OperationResponsesStep) $
+ _operationResponses . operation $ extract oper
+
+tracedSecurity :: Traced MatchedOperation -> [(Int, Traced SecurityRequirement)]
+tracedSecurity oper =
+ [ (i, traced (ask oper >>> step (OperationSecurityRequirementStep i)) x)
+ | (i, x) <- zip [0 ..] $ _operationSecurity . operation $ extract oper
+ ]
+
+tracedCallbacks :: Traced MatchedOperation -> [(Text, Traced (Referenced Callback))]
+tracedCallbacks (Traced t oper) =
+ [ (k, Traced (t >>> step (OperationCallbackStep k)) v)
+ | (k, v) <- IOHM.toList . _operationCallbacks . operation $ oper
+ ]
+
+-- FIXME: #28
+getServers ::
+ -- | Servers from env
+ [Server] ->
+ MatchedOperation ->
+ [Server]
+getServers env oper =
+ case _operationServers . operation $ oper of
+ [] -> env
+ ss -> ss
+
+instance Behavable 'OperationLevel 'PathFragmentLevel where
+ data Behave 'OperationLevel 'PathFragmentLevel
+ = InParam Text
+ | InFragment (PathFragment Text)
+ deriving stock (Eq, Ord, Show)
+ describeBehavior (InParam p) = "Parameter " <> text p
+ describeBehavior (InFragment (StaticPath p)) = "Static fragment " <> code p
+ describeBehavior (InFragment (DynamicPath p)) = "Dynamic fragment " <> code p
+
+instance Behavable 'OperationLevel 'RequestLevel where
+ data Behave 'OperationLevel 'RequestLevel
+ = InRequest
+ deriving stock (Eq, Ord, Show)
+ describeBehavior InRequest = "Request"
+
+instance Behavable 'OperationLevel 'SecurityRequirementLevel where
+ data Behave 'OperationLevel 'SecurityRequirementLevel
+ = SecurityRequirementStep Int
+ deriving stock (Eq, Ord, Show)
+ describeBehavior (SecurityRequirementStep i) =
+ "Security requirement " <> (text . T.pack . show $ i)
+
+instance Subtree MatchedOperation where
+ type SubtreeLevel MatchedOperation = 'OperationLevel
+ type
+ CheckEnv MatchedOperation =
+ '[ ProdCons (Traced (Definitions Param))
+ , ProdCons (Traced (Definitions RequestBody))
+ , ProdCons (Traced (Definitions SecurityScheme))
+ , ProdCons (Traced (Definitions Response))
+ , ProdCons (Traced (Definitions Header))
+ , ProdCons (Traced (Definitions Schema))
+ , ProdCons [Server]
+ , ProdCons (Traced (Definitions Link))
+ , ProdCons (Traced (Definitions Callback))
+ ]
+ checkStructuralCompatibility env pc = do
+ let pParams :: ProdCons [Traced Param]
+ pParams = do
+ defs <- getH @(ProdCons (Traced (Definitions Param))) env
+ op' <- tracedParameters <$> pc
+ pp <- pathParams . extract <$> pc
+ pure $
+ let o = M.fromList $ do
+ param <- dereference defs <$> op'
+ let key = paramKey . extract $ param
+ pure (key, param)
+ p = M.fromList $ do
+ param <- pp
+ pure (paramKey . extract $ param, param)
+ in M.elems $ o <> p
+ structuralList env pParams
+ structuralMaybe env $ tracedRequestBody <$> pc
+ checkSubstructure env $ tracedResponses <$> pc
+ checkSubstructure env $ do
+ x <- pc
+ se <- getH @(ProdCons [Server]) env
+ pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))
+ structuralList env $ fmap snd . tracedSecurity <$> pc
+ -- TODO: Callbacks
+ pure ()
+ checkSemanticCompatibility env beh prodCons = do
+ checkParameters
+ checkRequestBodies
+ checkResponses
+ checkCallbacks
+ checkOperationSecurity
+ checkServers
+ pure ()
+ where
+ checkParameters = do
+ let -- Merged parameters got from Operation and PathItem in one
+ -- place. First element is path params, second is non-path params
+ tracedParams :: ProdCons ([Traced Param], [Traced Param])
+ tracedParams = getParams <$> paramDefs <*> prodCons
+ getParams defs mp =
+ let operationParamsMap :: Map ParamKey (Traced Param)
+ operationParamsMap = M.fromList $ do
+ paramRef <- tracedParameters mp
+ let param = dereference defs paramRef
+ key = paramKey . extract $ param
+ pure (key, param)
+ pathParamsMap :: Map ParamKey (Traced Param)
+ pathParamsMap = M.fromList $ do
+ param <- pathParams . extract $ mp
+ pure (paramKey . extract $ param, param)
+ params = M.elems $ M.union operationParamsMap pathParamsMap -- We prefer params from Operation
+ splitted =
+ L.partition
+ (\p -> (_paramIn . extract $ p) == ParamPath)
+ params
+ in splitted
+ checkNonPathParams $ snd <$> tracedParams
+ checkPathParams $ fst <$> tracedParams
+ pure ()
+ checkNonPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()
+ checkNonPathParams params = do
+ let elements = getEls <$> params
+ getEls params = M.fromList $ do
+ p <- params
+ let k = (_paramIn . extract $ p, _paramName . extract $ p)
+ v =
+ ProductLike
+ { productValue = p
+ , required = fromMaybe False . _paramRequired . extract $ p
+ }
+ pure (k, v)
+ check (_, name) param =
+ checkCompatibility @Param (beh >>> step (InParam name)) env param
+ checkProducts beh (ParamNotMatched . snd) check elements
+ checkPathParams :: ProdCons [Traced Param] -> SemanticCompatFormula ()
+ checkPathParams pathParams = do
+ let fragments :: ProdCons [Traced PathFragmentParam]
+ fragments = getFragments <$> pathParams <*> prodCons
+ getFragments params mop = getPathFragments (extract mop) params
+ -- Feed path parameters to the fragments getter
+ check _ frags@(ProdCons (Traced _ p) _) =
+ checkCompatibility @PathFragmentParam (beh >>> step (InFragment $ _paramName . extract <$> p)) env frags
+ elements =
+ fragments <&> \frags -> M.fromList $
+ zip [0 :: Int ..] $ do
+ frag <- frags
+ pure $
+ ProductLike
+ { productValue = frag
+ , required = True
+ }
+ checkProducts beh PathFragmentNotMatched check elements
+ checkRequestBodies = do
+ let check reqBody = checkCompatibility @RequestBody (beh >>> step InRequest) env reqBody
+ elements = getReqBody <$> bodyDefs <*> prodCons
+ getReqBody bodyDef mop = M.fromList $ do
+ bodyRef <- F.toList . tracedRequestBody $ mop
+ let body = dereference bodyDef bodyRef
+ -- Single element map
+ pure
+ ( ()
+ , ProductLike
+ { productValue = body
+ , required = fromMaybe False . _requestBodyRequired . extract $ body
+ }
+ )
+ checkProducts beh (const NoRequestBody) (const check) elements
+ checkResponses =
+ swapProdCons (checkCompatibility beh) env $ tracedResponses <$> prodCons
+ -- FIXME: #27
+ checkCallbacks = do
+ let ProdCons pCallbacks cCallbacks = tracedCallbacks <$> prodCons
+ for_ pCallbacks $ \(k, pCallback) -> do
+ let beh' = beh >>> step (OperationCallback k)
+ anyOfAt beh' CallbacksUnsupported $
+ cCallbacks <&> \(_, cCallback) -> do
+ swapProdCons (checkCompatibility beh') env $ ProdCons pCallback cCallback
+ pure ()
+ -- FIXME: #28
+ checkOperationSecurity = do
+ let ProdCons pSecs cSecs = tracedSecurity <$> prodCons
+ for_ pSecs $ \(i, pSec) -> do
+ let beh' = beh >>> step (SecurityRequirementStep i)
+ anyOfAt beh' SecurityRequirementNotMet $
+ cSecs <&> \(_, cSec) ->
+ checkCompatibility beh' env $ ProdCons pSec cSec
+ checkServers =
+ checkCompatibility beh env $ do
+ x <- prodCons
+ se <- getH @(ProdCons [Server]) env
+ pure $ Traced (ask x >>> step OperationServersStep) (getServers se (extract x))
+ bodyDefs = getH @(ProdCons (Traced (Definitions RequestBody))) env
+ paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
+
+data OperationMethod
+ = GetMethod
+ | PutMethod
+ | PostMethod
+ | DeleteMethod
+ | OptionsMethod
+ | HeadMethod
+ | PatchMethod
+ | TraceMethod
+ deriving stock (Eq, Ord, Show)
+
+pathItemMethod :: OperationMethod -> PathItem -> Maybe Operation
+pathItemMethod = \case
+ GetMethod -> _pathItemGet
+ PutMethod -> _pathItemPut
+ PostMethod -> _pathItemPost
+ DeleteMethod -> _pathItemDelete
+ OptionsMethod -> _pathItemOptions
+ HeadMethod -> _pathItemHead
+ PatchMethod -> _pathItemPatch
+ TraceMethod -> _pathItemTrace
+
+instance Steppable MatchedOperation (Referenced Param) where
+ data Step MatchedOperation (Referenced Param) = OperationParamsStep Int
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable MatchedOperation (Referenced RequestBody) where
+ data Step MatchedOperation (Referenced RequestBody) = OperationRequestBodyStep
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable MatchedOperation Responses where
+ data Step MatchedOperation Responses = OperationResponsesStep
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable MatchedOperation SecurityRequirement where
+ data Step MatchedOperation SecurityRequirement = OperationSecurityRequirementStep Int
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable MatchedOperation (Referenced Callback) where
+ data Step MatchedOperation (Referenced Callback) = OperationCallbackStep Text
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable MatchedOperation [Server] where
+ data Step MatchedOperation [Server]
+ = OperationServersStep
+ | EnvServerStep
+ deriving stock (Eq, Ord, Show)
+
+-- * ProcessedPathItems
+
+-- FIXME: There's probably a better name for this, but `PathItem` is already taken ;(
+data ProcessedPathItem = ProcessedPathItem
+ { path :: FilePath
+ , item :: PathItem
+ }
+ deriving stock (Eq, Show)
+
+processPathItems :: [(FilePath, PathItem)] -> ProcessedPathItems
+processPathItems = ProcessedPathItems . fmap (uncurry ProcessedPathItem)
+
+newtype ProcessedPathItems = ProcessedPathItems {unProcessedPathItems :: [ProcessedPathItem]}
+ deriving newtype (Eq, Show)
+
+instance Issuable 'APILevel where
+ data Issue 'APILevel
+ = NoPathsMatched FilePath
+ | AllPathsFailed FilePath
+ -- When several paths match given but all checks failed
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ _ -> CertainIssue
+ relatedIssues =
+ (==) `withClass` \case
+ NoPathsMatched fp -> Just fp
+ AllPathsFailed fp -> Just fp
+ describeIssue Forward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been removed."
+ describeIssue Backward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been added."
+ describeIssue Forward (AllPathsFailed p) = para $ "The path " <> (code . T.pack) p <> " has been removed."
+ describeIssue Backward (AllPathsFailed p) = para $ "The path " <> (code . T.pack) p <> " has been added."
+
+instance Behavable 'APILevel 'PathLevel where
+ data Behave 'APILevel 'PathLevel
+ = AtPath FilePath
+ deriving stock (Eq, Ord, Show)
+
+ describeBehavior (AtPath p) = str (T.pack p)
+
+instance Subtree ProcessedPathItems where
+ type SubtreeLevel ProcessedPathItems = 'APILevel
+ type
+ CheckEnv ProcessedPathItems =
+ '[ ProdCons (Traced (Definitions Param))
+ , ProdCons (Traced (Definitions RequestBody))
+ , ProdCons (Traced (Definitions SecurityScheme))
+ , ProdCons (Traced (Definitions Response))
+ , ProdCons (Traced (Definitions Header))
+ , ProdCons (Traced (Definitions Schema))
+ , ProdCons [Server]
+ , ProdCons (Traced (Definitions Link))
+ , ProdCons (Traced (Definitions Callback))
+ ]
+
+ -- No real way to check it at this level
+ checkStructuralCompatibility _ _ = structuralIssue
+ checkSemanticCompatibility env beh pc@(ProdCons p c) = do
+ -- Each path generated by producer must be handled by consumer with exactly
+ -- 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 beh' env (retraced <$> pc <*> match)
+ matches -> anyOfAt beh (AllPathsFailed prodPath) $ do
+ match <- matches
+ pure $ checkCompatibility beh' env (retraced <$> pc <*> match)
+ where
+ retraced pc mpi = traced (ask pc >>> step (MatchedPathStep $ matchedPath mpi)) mpi
+
+-- | Preliminary checks two paths for compatibility. Returns Nothing if two
+-- paths obviously do not match: static parts differ or count of path elements
+-- is not equal
+matchingPathItems :: ProdCons ProcessedPathItem -> Maybe (ProdCons MatchedPathItem)
+matchingPathItems prodCons = do
+ let frags = parsePath . path <$> prodCons
+ guard $ fragsMatch frags
+ let mkMatchedItems frag ppi =
+ MatchedPathItem
+ { pathItem = item ppi
+ , matchedPath = path ppi
+ , pathFragments = frag
+ }
+ return $ mkMatchedItems <$> frags <*> prodCons
+
+fragsMatch :: ProdCons [PathFragment Text] -> Bool
+fragsMatch (ProdCons p c) = maybe False and $ zipAllWith check p c
+ where
+ check (StaticPath s1) (StaticPath s2) = s1 == s2
+ check _ _ = True
+
+zipAllWith :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
+zipAllWith _ [] [] = Just []
+zipAllWith f (x : xs) (y : ys) = (f x y :) <$> zipAllWith f xs ys
+zipAllWith _ (_ : _) [] = Nothing
+zipAllWith _ [] (_ : _) = Nothing
+
+data MatchedPathItem = MatchedPathItem
+ { pathItem :: !PathItem
+ , matchedPath :: !FilePath
+ , -- | Pre-parsed path from PathItem
+ pathFragments :: ![PathFragment Text]
+ }
+ deriving stock (Eq)
+
+tracedMatchedPathItemParameters :: Traced MatchedPathItem -> [Traced (Referenced Param)]
+tracedMatchedPathItemParameters mpi =
+ [ traced (ask mpi >>> step (PathItemParam i)) x
+ | (i, x) <- L.zip [0 ..] $ _pathItemParameters . pathItem $ extract mpi
+ ]
+
+tracedFragments :: Traced MatchedPathItem -> [Env (Trace PathFragmentParam) (PathFragment Text)]
+tracedFragments mpi =
+ [ env (ask mpi >>> step (PathFragmentStep i)) x
+ | (i, x) <- L.zip [0 ..] $ pathFragments $ extract mpi
+ ]
+
+tracedMethod ::
+ OperationMethod ->
+ Traced MatchedPathItem ->
+ Maybe (Traced' MatchedOperation Operation)
+tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)
+
+instance Issuable 'PathLevel where
+ data Issue 'PathLevel
+ = OperationMissing OperationMethod
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ OperationMissing _ -> CertainIssue
+ describeIssue Forward (OperationMissing op) = para $ "Method " <> strong (showMethod op) <> " has been removed."
+ describeIssue Backward (OperationMissing op) = para $ "Method " <> strong (showMethod op) <> " has been added."
+
+instance Behavable 'PathLevel 'OperationLevel where
+ data Behave 'PathLevel 'OperationLevel
+ = InOperation OperationMethod
+ deriving stock (Eq, Ord, Show)
+
+ describeBehavior (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
+ CheckEnv MatchedPathItem =
+ '[ ProdCons (Traced (Definitions Param))
+ , ProdCons (Traced (Definitions RequestBody))
+ , ProdCons (Traced (Definitions SecurityScheme))
+ , ProdCons (Traced (Definitions Response))
+ , ProdCons (Traced (Definitions Header))
+ , ProdCons (Traced (Definitions Schema))
+ , ProdCons [Server]
+ , ProdCons (Traced (Definitions Link))
+ , ProdCons (Traced (Definitions Callback))
+ ]
+ checkStructuralCompatibility _ _ = structuralIssue
+ checkSemanticCompatibility env beh prodCons = do
+ let paramDefs = getH @(ProdCons (Traced (Definitions Param))) env
+ pathTracedParams = getPathParams <$> paramDefs <*> prodCons
+ getPathParams ::
+ Traced (Definitions Param) ->
+ Traced MatchedPathItem ->
+ [Traced Param]
+ getPathParams defs mpi = do
+ paramRef <- tracedMatchedPathItemParameters mpi
+ pure $ dereference defs paramRef
+ pathTracedFragments = mkPathFragments <$> prodCons
+ mkPathFragments mpi operationParams =
+ -- operationParams will be known on Operation check stage, so we give a
+ -- function, returning fragments
+ let paramsMap :: Map Text (Traced Param)
+ paramsMap = M.fromList $ do
+ tracedParam <- operationParams
+ let pname = _paramName . extract $ tracedParam
+ pure (pname, tracedParam)
+ convertFragment = \case
+ StaticPath t -> StaticPath t
+ DynamicPath pname ->
+ DynamicPath $
+ fromMaybe (error $ "Param not found " <> T.unpack pname) $
+ M.lookup pname paramsMap
+ in tracedFragments mpi <&> fmap convertFragment
+ operations = getOperations <$> pathTracedParams <*> pathTracedFragments <*> prodCons
+ getOperations pathParams getPathFragments mpi = M.fromList $ do
+ (name, getOp) <-
+ (id &&& tracedMethod)
+ <$> [GetMethod, PutMethod, PostMethod, DeleteMethod, OptionsMethod, HeadMethod, PatchMethod, DeleteMethod]
+ operation <- F.toList $ getOp mpi
+ -- Got only Justs here
+ let retraced = \op -> MatchedOperation {operation = op, pathParams, getPathFragments}
+ pure (name, retraced <$> operation)
+ check name pc = checkCompatibility @MatchedOperation (beh >>> step (InOperation name)) env pc
+ -- Operations are sum-like entities. Use step to operation as key because
+ -- why not
+ checkSums beh OperationMissing check operations
+
+instance Steppable ProcessedPathItems MatchedPathItem where
+ data Step ProcessedPathItems MatchedPathItem = MatchedPathStep FilePath
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable MatchedPathItem MatchedOperation where
+ data Step MatchedPathItem MatchedOperation = OperationMethodStep OperationMethod
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable MatchedPathItem (Referenced Param) where
+ data Step MatchedPathItem (Referenced Param) = PathItemParam Int
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable MatchedPathItem PathFragmentParam where
+ data Step MatchedPathItem PathFragmentParam = PathFragmentStep Int
+ deriving stock (Eq, Ord, Show)
+
+-- * Callbacks
+
+instance Subtree Callback where
+ type SubtreeLevel Callback = 'CallbackLevel
+ type
+ CheckEnv Callback =
+ '[ ProdCons (Traced (Definitions Param))
+ , ProdCons (Traced (Definitions RequestBody))
+ , ProdCons (Traced (Definitions SecurityScheme))
+ , ProdCons (Traced (Definitions Response))
+ , ProdCons (Traced (Definitions Header))
+ , ProdCons (Traced (Definitions Schema))
+ , ProdCons (Traced (Definitions Link))
+ , ProdCons [Server]
+ , ProdCons (Traced (Definitions Callback))
+ ]
+ checkStructuralCompatibility env pc =
+ checkSubstructure env $ tracedCallbackPathItems <$> pc
+ checkSemanticCompatibility _ bhv _ = issueAt bhv CallbacksUnsupported
+
+instance Issuable 'CallbackLevel where
+ data Issue 'CallbackLevel
+ = CallbacksUnsupported
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ CallbacksUnsupported -> Unsupported
+ describeIssue _ CallbacksUnsupported = para "CompaREST does not currently support callbacks."
+
+tracedCallbackPathItems :: Traced Callback -> Traced ProcessedPathItems
+tracedCallbackPathItems (Traced t (Callback x)) =
+ Traced (t >>> step CallbackPathsStep) (processPathItems . fmap (first T.unpack) . IOHM.toList $ x)
+
+instance Steppable Callback ProcessedPathItems where
+ data Step Callback ProcessedPathItems = CallbackPathsStep
+ deriving stock (Eq, Ord, Show)
+
+instance Behavable 'OperationLevel 'CallbackLevel where
+ data Behave 'OperationLevel 'CallbackLevel = OperationCallback Text
+ deriving stock (Eq, Ord, Show)
+
+ describeBehavior (OperationCallback key) = "Operation " <> code key
diff --git a/src/Data/OpenApi/Compare/Validate/Param.hs b/src/Data/OpenApi/Compare/Validate/Param.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Param.hs
@@ -0,0 +1,136 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Data.OpenApi.Compare.Validate.Param
+ ( Behave (..),
+ Issue (..),
+ )
+where
+
+import Control.Monad
+import Data.Functor
+import Data.Maybe
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Orphans ()
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Schema ()
+import Data.Text as T
+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
+data EncodingStyle = EncodingStyle
+ { style :: Style
+ , explode :: Bool
+ , -- | Nothing when @in@ parameter is not @query@
+ allowReserved :: Maybe Bool
+ }
+ deriving stock (Eq, Ord, Show)
+
+paramEncoding :: Param -> EncodingStyle
+paramEncoding p =
+ EncodingStyle
+ { style
+ , explode
+ , allowReserved
+ }
+ where
+ style = fromMaybe defaultStyle $ _paramStyle p
+ defaultStyle = case _paramIn p of
+ ParamQuery -> StyleForm
+ ParamPath -> StyleSimple
+ ParamHeader -> StyleSimple
+ ParamCookie -> StyleForm
+ explode = fromMaybe defaultExplode $ _paramExplode p
+ defaultExplode = case style of
+ StyleForm -> True
+ _ -> False
+ allowReserved = case _paramIn p of
+ ParamQuery -> Just $ fromMaybe False $ _paramAllowReserved p
+ _ -> Nothing
+
+tracedSchema :: Traced Param -> Maybe (Traced (Referenced Schema))
+tracedSchema par = _paramSchema (extract par) <&> traced (ask par >>> step ParamSchema)
+
+instance Issuable 'PathFragmentLevel where
+ data Issue 'PathFragmentLevel
+ = -- | Params have different names
+ ParamNameMismatch
+ | -- | Consumer requires non-empty param, but producer gives emptyable
+ ParamEmptinessIncompatible
+ | -- | Consumer requires mandatory parm, but producer optional
+ ParamRequired
+ | ParamPlaceIncompatible
+ | -- | Params encoded in different styles
+ ParamStyleMismatch
+ | -- | One of schemas not presented
+ ParamSchemaMismatch
+ | PathFragmentsDontMatch (ProdCons Text)
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ ParamSchemaMismatch -> ProbablyIssue -- the schema could be catch-all (?)
+ _ -> CertainIssue
+ describeIssue _ ParamNameMismatch = para "The path fragments don't match."
+ describeIssue Forward ParamEmptinessIncompatible = para "The parameter can no longer be empty."
+ describeIssue Backward ParamEmptinessIncompatible = para "The parameter can now be empty."
+ describeIssue Forward ParamRequired = para "Parameter has become required."
+ describeIssue Backward ParamRequired = para "Parameter is no longer 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 ori (PathFragmentsDontMatch (orientProdCons ori -> ProdCons e a)) =
+ para $ "Parameter changed from " <> code e <> " to " <> code a <> "."
+
+instance Behavable 'PathFragmentLevel 'SchemaLevel where
+ data Behave 'PathFragmentLevel 'SchemaLevel
+ = InParamSchema
+ deriving stock (Eq, Ord, Show)
+
+ describeBehavior InParamSchema = "JSON Schema"
+
+instance Subtree Param where
+ type SubtreeLevel Param = 'PathFragmentLevel
+ type CheckEnv Param = '[ProdCons (Traced (Definitions Schema))]
+ checkStructuralCompatibility env pc = do
+ structuralEq $ fmap _paramName <$> pc
+ structuralEq $ fmap _paramRequired <$> pc
+ structuralEq $ fmap _paramIn <$> pc
+ structuralEq $ fmap _paramAllowEmptyValue <$> pc
+ structuralEq $ fmap _paramAllowReserved <$> pc
+ structuralMaybe env $ tracedSchema <$> pc
+ structuralEq $ fmap _paramStyle <$> pc
+ structuralEq $ fmap _paramExplode <$> pc
+ pure ()
+ checkSemanticCompatibility env beh pc@(ProdCons p c) = do
+ when (_paramName (extract p) /= _paramName (extract c)) $
+ issueAt beh ParamNameMismatch
+ when
+ ( (fromMaybe False . _paramRequired . extract $ c)
+ && not (fromMaybe False . _paramRequired . extract $ p)
+ )
+ $ issueAt beh ParamRequired
+ case (_paramIn . extract $ p, _paramIn . extract $ c) of
+ (ParamQuery, ParamQuery) -> do
+ -- Emptiness is only for query params
+ when
+ ( (fromMaybe False . _paramAllowEmptyValue . extract $ p)
+ && not (fromMaybe False . _paramAllowEmptyValue . extract $ c)
+ )
+ $ issueAt beh ParamEmptinessIncompatible
+ (a, b) | a == b -> pure ()
+ _ -> issueAt beh ParamPlaceIncompatible
+ unless (paramEncoding (extract p) == paramEncoding (extract c)) $
+ issueAt beh ParamStyleMismatch
+ case tracedSchema <$> pc of
+ ProdCons (Just prodSchema) (Just consSchema) -> do
+ checkCompatibility (beh >>> step InParamSchema) env $ ProdCons prodSchema consSchema
+ ProdCons Nothing Nothing -> pure ()
+ ProdCons Nothing (Just _consSchema) -> issueAt beh ParamSchemaMismatch
+ ProdCons (Just _prodSchema) Nothing -> pure ()
+ -- If consumer doesn't care then why we should?
+ pure ()
+
+instance Steppable Param (Referenced Schema) where
+ data Step Param (Referenced Schema) = ParamSchema
+ deriving stock (Eq, Ord, Show)
diff --git a/src/Data/OpenApi/Compare/Validate/PathFragment.hs b/src/Data/OpenApi/Compare/Validate/PathFragment.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/PathFragment.hs
@@ -0,0 +1,78 @@
+module Data.OpenApi.Compare.Validate.PathFragment
+ ( parsePath,
+ PathFragment (..),
+ PathFragmentParam,
+ )
+where
+
+import qualified Data.Aeson as A
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Param
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.
+-- #23
+parsePath :: FilePath -> [PathFragment Text]
+parsePath = fmap partition . T.splitOn "/" . T.pack
+ where
+ partition :: Text -> PathFragment Text
+ partition t
+ | Just ('{', rest) <- T.uncons t
+ , Just (ref, '}') <- T.unsnoc rest =
+ DynamicPath ref
+ partition t = StaticPath t
+
+-- | Fragment parameterized by parameter. The dynamic part may be either
+-- reference to some parameter (in context of operation) or dereferenced
+-- parameter itself.
+data PathFragment param
+ = StaticPath Text
+ | DynamicPath param
+ deriving stock (Eq, Ord, Show, Functor)
+
+type PathFragmentParam = PathFragment (Traced Param)
+
+instance (Typeable param) => Steppable (PathFragment param) Param where
+ data Step (PathFragment param) Param = StaticPathParam Text
+ deriving stock (Eq, Ord, Show)
+
+tracedPathFragmentParam :: Traced PathFragmentParam -> Traced Param
+tracedPathFragmentParam pfp = case extract pfp of
+ StaticPath s ->
+ traced (ask pfp >>> step (StaticPathParam s)) $
+ mempty
+ { _paramRequired = Just True
+ , _paramIn = ParamPath
+ , _paramAllowEmptyValue = Just False
+ , _paramAllowReserved = Just False
+ , _paramSchema = Just $ Inline $ staticStringSchema s
+ }
+ DynamicPath p -> p
+
+staticStringSchema :: Text -> Schema
+staticStringSchema t =
+ mempty
+ { _schemaNullable = Just False
+ , _schemaType = Just OpenApiString
+ , _schemaEnum = Just [A.String t]
+ }
+
+instance Subtree PathFragmentParam where
+ type SubtreeLevel PathFragmentParam = 'PathFragmentLevel
+ type
+ CheckEnv PathFragmentParam =
+ '[ProdCons (Traced (Definitions Schema))]
+
+ -- Not much to compare at this level
+ checkStructuralCompatibility _ _ = structuralIssue
+
+ -- This case isn't strictly needed. It is here for optimization.
+ checkSemanticCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y)) =
+ if x == y
+ then pure ()
+ else issueAt beh (PathFragmentsDontMatch (ProdCons x y))
+ checkSemanticCompatibility env beh prodCons = do
+ checkCompatibility beh env (tracedPathFragmentParam <$> prodCons)
diff --git a/src/Data/OpenApi/Compare/Validate/Products.hs b/src/Data/OpenApi/Compare/Validate/Products.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Products.hs
@@ -0,0 +1,48 @@
+-- | Checks product-like entities. The key is some identificator for the product
+--element. Each element may be required or optional.
+--
+--One example of product is request parameters. There are optional and required
+--parameters. The client and server have possibly different set of
+--parameters. What we must check is if server requires some request parameter,
+--then this parameter must be presented by client and their schemas must match.
+--
+--So when we checking products we are checking from the server's (consumer)
+--perspective, ensuring that all parameters are provided by the client (producer)
+--and their schemas match.
+--
+--This module abstracts this logic for arbitrary elements
+module Data.OpenApi.Compare.Validate.Products
+ ( checkProducts,
+ ProductLike (..),
+ )
+where
+
+import Data.Foldable
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Paths
+import Data.OpenApi.Compare.Subtree
+
+-- | Some entity which is product-like
+data ProductLike a = ProductLike
+ { productValue :: a
+ , required :: Bool
+ }
+
+checkProducts ::
+ (Ord k, Issuable l) =>
+ Paths q r l ->
+ -- | No required element found
+ (k -> Issue l) ->
+ (k -> ProdCons t -> CompatFormula' q AnIssue r ()) ->
+ ProdCons (Map k (ProductLike t)) ->
+ CompatFormula' q AnIssue r ()
+checkProducts xs noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->
+ case M.lookup key p of
+ Nothing -> case required consElt of
+ True -> issueAt xs $ noElt key
+ False -> pure ()
+ Just prodElt -> do
+ let elts = ProdCons prodElt consElt
+ check key (productValue <$> elts)
diff --git a/src/Data/OpenApi/Compare/Validate/RequestBody.hs b/src/Data/OpenApi/Compare/Validate/RequestBody.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/RequestBody.hs
@@ -0,0 +1,79 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.RequestBody
+ ( Issue (..),
+ Behave (..),
+ )
+where
+
+import Data.HList
+import Data.HashMap.Strict.InsOrd as IOHM
+import Data.Map.Strict as M
+import Data.Maybe
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.MediaTypeObject
+import Data.OpenApi.Compare.Validate.Sums
+import qualified Data.Text as T
+import Network.HTTP.Media (MediaType)
+import Text.Pandoc.Builder
+
+-- TODO: Use RequestMediaTypeObjectMapping
+tracedContent :: Traced RequestBody -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
+tracedContent resp =
+ IOHM.mapWithKey (\k -> traced (ask resp >>> step (RequestMediaTypeObject k))) $
+ _requestBodyContent $ extract resp
+
+instance Issuable 'RequestLevel where
+ data Issue 'RequestLevel
+ = RequestBodyRequired
+ | RequestMediaTypeNotFound MediaType
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ _ -> CertainIssue
+ describeIssue Forward RequestBodyRequired =
+ para "Request body has become required."
+ describeIssue Backward RequestBodyRequired =
+ para "Request body is no longer required."
+ describeIssue Forward (RequestMediaTypeNotFound t) =
+ para $ "Media type " <> (code . T.pack . show $ t) <> " has been removed."
+ describeIssue Backward (RequestMediaTypeNotFound t) =
+ para $ "Media type " <> (code . T.pack . show $ t) <> " has been added."
+
+instance Behavable 'RequestLevel 'PayloadLevel where
+ data Behave 'RequestLevel 'PayloadLevel
+ = InPayload
+ deriving stock (Eq, Ord, Show)
+ describeBehavior InPayload = "Payload"
+
+instance Subtree RequestBody where
+ type SubtreeLevel RequestBody = 'RequestLevel
+ type
+ CheckEnv RequestBody =
+ '[ ProdCons (Traced (Definitions Schema))
+ , ProdCons (Traced (Definitions Header))
+ ]
+ checkStructuralCompatibility env pc = do
+ structuralEq $ fmap _requestBodyRequired <$> pc
+ iohmStructural env $
+ stepTraced RequestMediaTypeObjectMapping . fmap _requestBodyContent <$> pc
+ pure ()
+ checkSemanticCompatibility env beh prodCons@(ProdCons p c) =
+ if not (fromMaybe False . _requestBodyRequired . extract $ p)
+ && (fromMaybe False . _requestBodyRequired . extract $ c)
+ then issueAt beh RequestBodyRequired
+ else -- Media type object are sums-like entities.
+
+ let check mediaType pc = checkCompatibility @MediaTypeObject (beh >>> step InPayload) (HCons mediaType env) pc
+ sumElts = getSum <$> prodCons
+ getSum rb = M.fromList . IOHM.toList $ tracedContent rb
+ in checkSums beh RequestMediaTypeNotFound check sumElts
+
+instance Steppable RequestBody MediaTypeObject where
+ data Step RequestBody MediaTypeObject = RequestMediaTypeObject MediaType
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable RequestBody (IOHM.InsOrdHashMap MediaType MediaTypeObject) where
+ data Step RequestBody (IOHM.InsOrdHashMap MediaType MediaTypeObject) = RequestMediaTypeObjectMapping
+ deriving stock (Eq, Ord, Show)
diff --git a/src/Data/OpenApi/Compare/Validate/Responses.hs b/src/Data/OpenApi/Compare/Validate/Responses.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Responses.hs
@@ -0,0 +1,172 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Data.OpenApi.Compare.Validate.Responses
+ ( Behave (..),
+ )
+where
+
+import Data.HList
+import Data.HashMap.Strict.InsOrd as IOHM
+import Data.Map.Strict as M
+import Data.Maybe
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.References
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Header ()
+import Data.OpenApi.Compare.Validate.Link ()
+import Data.OpenApi.Compare.Validate.MediaTypeObject
+import Data.OpenApi.Compare.Validate.Products
+import Data.OpenApi.Compare.Validate.Schema ()
+import Data.OpenApi.Compare.Validate.Sums
+import qualified Data.Text as T
+import Network.HTTP.Media (MediaType)
+import Text.Pandoc.Builder
+
+tracedResponses :: Traced Responses -> IOHM.InsOrdHashMap HttpStatusCode (Traced (Referenced Response))
+tracedResponses resp =
+ IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseCodeStep k))) $
+ _responsesResponses $ extract resp
+
+instance Subtree Responses where
+ type SubtreeLevel Responses = 'OperationLevel
+ type
+ CheckEnv Responses =
+ '[ ProdCons (Traced (Definitions Response))
+ , ProdCons (Traced (Definitions Header))
+ , ProdCons (Traced (Definitions Schema))
+ , ProdCons (Traced (Definitions Link))
+ ]
+
+ checkStructuralCompatibility env pc = do
+ structuralMaybe env $ sequence . stepTraced ResponseDefaultStep . fmap _responsesDefault <$> pc
+ iohmStructural env $ stepTraced ResponsesStep . fmap _responsesResponses <$> pc
+ pure ()
+
+ -- Roles are already swapped. Producer is a server and consumer is a
+ -- client. Response codes are sum-like entity because we can answer with only
+ -- one element
+ checkSemanticCompatibility env beh prodCons = do
+ let defs = getH @(ProdCons (Traced (Definitions Response))) env
+ check code resps = checkCompatibility @Response (beh >>> step (WithStatusCode code)) env resps
+ elements = getEls <$> defs <*> prodCons
+ getEls respDef resps = M.fromList $ do
+ (code, respRef) <- IOHM.toList $ tracedResponses resps
+ pure (code, dereference respDef respRef)
+ checkSums beh ConsumerDoesntHaveResponseCode check elements
+
+tracedContent :: Traced Response -> IOHM.InsOrdHashMap MediaType (Traced MediaTypeObject)
+tracedContent resp =
+ IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseMediaObject k))) $
+ _responseContent $ extract resp
+
+tracedHeaders :: Traced Response -> IOHM.InsOrdHashMap HeaderName (Traced (Referenced Header))
+tracedHeaders resp =
+ IOHM.mapWithKey (\k -> traced (ask resp >>> step (ResponseHeader k))) $
+ _responseHeaders $ extract resp
+
+instance Issuable 'ResponseLevel where
+ data Issue 'ResponseLevel
+ = ConsumerDoesntHaveMediaType MediaType
+ | ProducerDoesntHaveResponseHeader HeaderName
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ _ -> CertainIssue
+ describeIssue Forward (ConsumerDoesntHaveMediaType t) =
+ para $ "Media type was removed: " <> (code . T.pack . show $ t) <> "."
+ describeIssue Backward (ConsumerDoesntHaveMediaType t) =
+ para $ "Media type was added: " <> (code . T.pack . show $ t) <> "."
+ describeIssue Forward (ProducerDoesntHaveResponseHeader h) =
+ para $ "New header was added " <> code h <> "."
+ describeIssue Backward (ProducerDoesntHaveResponseHeader h) =
+ para $ "Header was removed " <> code h <> "."
+
+instance Behavable 'ResponseLevel 'PayloadLevel where
+ data Behave 'ResponseLevel 'PayloadLevel
+ = ResponsePayload
+ deriving stock (Eq, Ord, Show)
+
+ describeBehavior ResponsePayload = "Payload"
+
+instance Behavable 'ResponseLevel 'HeaderLevel where
+ data Behave 'ResponseLevel 'HeaderLevel
+ = InHeader HeaderName
+ deriving stock (Eq, Ord, Show)
+
+ describeBehavior (InHeader name) = "Header " <> code name
+
+instance Subtree Response where
+ type SubtreeLevel Response = 'ResponseLevel
+ type
+ CheckEnv Response =
+ '[ ProdCons (Traced (Definitions Header))
+ , ProdCons (Traced (Definitions Schema))
+ , ProdCons (Traced (Definitions Link))
+ ]
+ checkStructuralCompatibility env pc = do
+ iohmStructural env $ stepTraced ResponseMediaObjects . fmap _responseContent <$> pc
+ iohmStructural env $ stepTraced ResponseHeaders . fmap _responseHeaders <$> pc
+ iohmStructural env $ stepTraced ResponseLinks . fmap _responseLinks <$> pc
+ pure ()
+ checkSemanticCompatibility env beh prodCons = do
+ -- Roles are already swapped. Producer is a server and consumer is a client
+ checkMediaTypes
+ checkHeaders
+ pure ()
+ where
+ checkMediaTypes = do
+ -- Media types are sum-like entity
+ let check mediaType mtObj =
+ let mtEnv = HCons mediaType env
+ in checkCompatibility @MediaTypeObject (beh >>> step ResponsePayload) mtEnv mtObj
+ elements = getEls <$> prodCons
+ getEls resp = M.fromList . IOHM.toList $ tracedContent resp
+ checkSums beh ConsumerDoesntHaveMediaType check elements
+
+ checkHeaders = do
+ -- Headers are product-like entities
+ let check name hdrs = checkCompatibility @Header (beh >>> step (InHeader name)) env hdrs
+ elements = getEls <$> headerDefs <*> prodCons
+ getEls headerDef resp = M.fromList $ do
+ (hname, headerRef) <- IOHM.toList $ tracedHeaders resp
+ let header = dereference headerDef headerRef
+ pure
+ ( hname
+ , ProductLike
+ { productValue = header
+ , required = fromMaybe False . _headerRequired . extract $ header
+ }
+ )
+ checkProducts beh ProducerDoesntHaveResponseHeader check elements
+ headerDefs = getH @(ProdCons (Traced (Definitions Header))) env
+
+instance Steppable Responses (Referenced Response) where
+ data Step Responses (Referenced Response)
+ = ResponseCodeStep HttpStatusCode
+ | ResponseDefaultStep
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable Response MediaTypeObject where
+ data Step Response MediaTypeObject = ResponseMediaObject MediaType
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable Response (IOHM.InsOrdHashMap MediaType MediaTypeObject) where
+ data Step Response (IOHM.InsOrdHashMap MediaType MediaTypeObject) = ResponseMediaObjects
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable Response (Definitions (Referenced Header)) where
+ data Step Response (Definitions (Referenced Header)) = ResponseHeaders
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable Response (Definitions (Referenced Link)) where
+ data Step Response (Definitions (Referenced Link)) = ResponseLinks
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable Response (Referenced Header) where
+ data Step Response (Referenced Header) = ResponseHeader HeaderName
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable Responses (IOHM.InsOrdHashMap HttpStatusCode (Referenced Response)) where
+ data Step Responses (IOHM.InsOrdHashMap HttpStatusCode (Referenced Response)) = ResponsesStep
+ deriving stock (Eq, Ord, Show)
diff --git a/src/Data/OpenApi/Compare/Validate/Schema.hs b/src/Data/OpenApi/Compare/Validate/Schema.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Schema.hs
@@ -0,0 +1,398 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.Schema
+ (
+ )
+where
+
+import Control.Monad.Writer
+import qualified Data.Aeson as A
+import Data.Coerce
+import Data.Foldable (for_, toList)
+import Data.Functor
+import Data.HList
+import Data.List (genericIndex, genericLength, group)
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map as M
+import Data.Maybe
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Paths
+import qualified Data.OpenApi.Compare.PathsPrefixTree as P
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Schema.DNF
+import Data.OpenApi.Compare.Validate.Schema.Issues
+import Data.OpenApi.Compare.Validate.Schema.JsonFormula
+import Data.OpenApi.Compare.Validate.Schema.Partition
+import Data.OpenApi.Compare.Validate.Schema.Process
+import Data.OpenApi.Compare.Validate.Schema.Traced
+import Data.OpenApi.Compare.Validate.Schema.TypedJson
+import Data.Ord
+import Data.Ratio
+import Data.Semigroup
+import qualified Data.Set as S
+import Data.Text (Text)
+
+checkFormulas ::
+ (ReassembleHList xs (CheckEnv (Referenced Schema))) =>
+ HList xs ->
+ Behavior 'SchemaLevel ->
+ ProdCons (Trace Schema) ->
+ ProdCons (Traced (Definitions Schema)) ->
+ ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel) ->
+ SemanticCompatFormula ()
+checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =
+ case P.toList ep ++ P.toList ec of
+ issues@(_ : _) -> for_ issues $ embedFormula beh . anItem
+ [] -> do
+ -- We have the following isomorphisms:
+ -- (A ⊂ X ∩ Y) = (A ⊂ X) /\ (A ⊂ Y)
+ -- (A ⊂ ⊤) = 1
+ -- (X ∪ Y ⊂ B) = (X ⊂ B) /\ (Y ⊂ B)
+ -- (∅ ⊂ B) = 1
+ -- The remaining cases are, notably, not isomorphisms:
+ -- 1) (A ⊂ X ∪ Y) <= (A ⊂ X) \/ (A ⊂ Y)
+ -- 2) (A ⊂ ∅) <= 0
+ -- 3) (X ∩ Y ⊂ B) <= (X ⊂ B) \/ (Y ⊂ B)
+ -- 4) (⊤ ⊂ B) <= 0
+ -- Therefore we have the implications with (∃ and ∀ being the N-ary
+ -- versions of \/ and /\ respectively):
+ -- (⋃_i ⋂_j A[i,j]) ⊂ (⋃_k ⋂_l B[k,l])
+ -- <= ∃k ∀l ∀i, (⋂_j A[i,j]) ⊂ B[k,l]
+ -- = ∀i ∃k ∀l, (⋂_j A[i,j]) ⊂ B[k,l]
+ -- with the caveat that the the set over which k ranges is nonempty.
+ -- (because 2) is not an isomorphism), and that this is a sufficient
+ -- but not necessary condition (because 1) is not an isomorphism).
+ -- Our disjunction loses information, so it makes sense to nest it as
+ -- deeply as possible, hence we choose the latter representation.
+ --
+ -- We delegate the verification of (⋂_j A[j]) ⊂ B to a separate heuristic
+ -- function, with the understanding that ∃j, A[j] ⊂ B is a sufficient,
+ -- but not necessary condition (because of 3) and 4)).
+ --
+ -- If k ranges over an empty set, we have the isomorphism:
+ -- (⋃_i ⋂_j A[i,j]) ⊂ ∅ = ∀i, (⋂_j A[i,j]) ⊂ ∅
+ -- where we again delegate (⋂_j A[j]) ⊂ ∅ to a heuristic, though here the
+ -- shortcut of ∃j, A[j] ⊂ ∅ hardly helps.
+ --
+ -- Disjunctions tend to erase informative error messages, so we may want
+ -- to avoid them. This can be formally done as follows: if we can
+ -- partition the universal set into a disjoint union of some parts:
+ -- ⊤ = ⊔_α P[α]
+ -- such that the conjuncts in our disjunctive normal form are subordinate
+ -- to the partition:
+ -- ∀i ∃α, (⋂_j A[i,j]) ⊂ P[α]
+ -- ∀k ∃α, (⋂_l B[k,l]) ⊂ P[α]
+ -- then we can partition the sets over which i and k range into partitions
+ -- I[α] and K[α], and then in each "bucket" verify the inclusion in the
+ -- aforementioned way:
+ -- ∀α, (⋃_i∈I[α] ⋂_j A[i,j]) ⊂ (⋃_k∈K[α] ⋂_l B[k,l])
+ -- = ∀α ∀i∈I[α] ∃k∈K[α] ∀l, (⋂_j A[i,j]) ⊂ B[k,l]
+ -- We already somewhat do this by partitioning JSON into types, but we can
+ -- additionally partition e.g. "enum" fields or existence of particular
+ -- properties. This works especially well if we manage to ensure K[α] are
+ -- 1-element sets.
+ --
+ -- Since the set:
+ -- (⋃_i∈I[α] ⋂_j A[i,j]) = (⋃_i ⋂_j A[i,j]) ∩ P[α]
+ -- does not actually appear in the source schema, we need to construct it
+ -- ourselves and come up with a name for it.
+ let typesRestricted = not (anyBottomTypes fp) && anyBottomTypes fc
+ -- Specifically handle the case when a schema's type has been
+ -- restricted from "all" to specific types: if all types were allowed
+ -- in the producer and not all types are allowed in the consumer, it's
+ -- usually easier to say what's left than what's removed
+ when typesRestricted $ issueAt beh $ TypesRestricted $ nonBottomTypes fc
+ forType_ $ \tyName ty -> do
+ let beh' = beh >>> step (OfType tyName)
+ case (getJsonFormula $ ty fp, getJsonFormula $ ty fc) of
+ (DNF pss, BottomDNF) -> unless typesRestricted $ do
+ -- don't repeat the TypesRestricted issue
+ for_ pss $ \(Disjunct ps) -> checkContradiction beh' Nothing ps
+ (DNF pss, SingleDisjunct (Disjunct cs)) -> for_ pss $ \(Disjunct ps) -> do
+ for_ cs $ checkImplication env beh' trs ps -- avoid disjunction if there's only one conjunct
+ (TopDNF, DNF css) ->
+ -- producer is "open" (allows any value), but consumer has restrictions.
+ -- In this case we want to show which restrictions were added. (instead
+ -- of showing an empty list restrictions that couldn't be satisfied.)
+ for_ css $ \(Disjunct cs) -> for_ cs $ checkImplication env beh' trs S.empty
+ (pss', css') -> for_ (tryPartition defs $ ProdCons (JsonFormula pss') (JsonFormula css')) $ \case
+ (mPart, ProdCons pf cf) -> do
+ let beh'' = foldr ((<<<) . step . InPartition) beh' mPart
+ case (getJsonFormula pf, getJsonFormula cf) of
+ (DNF pss, BottomDNF) -> for_ pss $ \(Disjunct ps) -> checkContradiction beh' mPart ps
+ (DNF pss, SingleDisjunct (Disjunct cs)) -> for_ pss $ \(Disjunct ps) -> do
+ for_ cs $ checkImplication env beh'' trs ps
+ -- unlucky:
+ (DNF pss, DNF css) -> for_ pss $ \(Disjunct ps) -> do
+ anyOfAt
+ beh'
+ (issueFromDisjunct Nothing ps)
+ [for_ cs $ checkImplication env beh' trs ps | Disjunct cs <- S.toList css]
+ pure ()
+ where
+ anyBottomTypes f = getAny $
+ foldType $ \_ ty -> case getJsonFormula $ ty f of
+ BottomDNF -> Any True
+ _ -> mempty
+ nonBottomTypes f = foldType $ \tyName ty -> case getJsonFormula $ ty f of
+ BottomDNF -> mempty
+ _ -> [tyName]
+ issueFromDisjunct :: Typeable t => Maybe Partition -> S.Set (Condition t) -> Issue 'TypedSchemaLevel
+ issueFromDisjunct _ ps
+ | Just e <- findExactly ps
+ , all (satisfiesTyped e) ps =
+ EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?
+ issueFromDisjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> S.toList ps
+
+checkContradiction ::
+ Behavior 'TypedSchemaLevel ->
+ Maybe Partition ->
+ S.Set (Condition t) ->
+ SemanticCompatFormula ()
+checkContradiction beh mPart _ = issueAt beh $ maybe TypeBecomesEmpty PartitionBecomesEmpty mPart -- TODO #70
+
+checkImplication ::
+ (ReassembleHList xs (CheckEnv (Referenced Schema))) =>
+ HList xs ->
+ Behavior 'TypedSchemaLevel ->
+ ProdCons (Trace Schema) -> -- the traces of the root schemas used in this comparison
+ S.Set (Condition t) ->
+ Condition t ->
+ SemanticCompatFormula ()
+checkImplication env beh trs prods cons = case findExactly prods of
+ Just e
+ | all (satisfiesTyped e) prods ->
+ if satisfiesTyped e cons
+ then pure ()
+ else issueAt beh (EnumDoesntSatisfy $ untypeValue e)
+ | otherwise -> pure () -- vacuously true
+ Nothing -> case cons of
+ -- the above code didn't catch it, so there's no Exactly condition on the lhs
+ Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)
+ Maximum m -> foldCheck min m NoMatchingMaximum MatchingMaximumWeak $ \case
+ Maximum m' -> Just m'
+ _ -> Nothing
+ Minimum m -> foldCheck max m (NoMatchingMinimum . coerce) (MatchingMinimumWeak . coerce) $ \case
+ Minimum m' -> Just m'
+ _ -> Nothing
+ MultipleOf m -> foldCheck lcmScientific m NoMatchingMultipleOf MatchingMultipleOfWeak $ \case
+ MultipleOf m' -> Just m'
+ _ -> Nothing
+ NumberFormat f -> case flip any prods $ \case
+ NumberFormat f' -> f == f'
+ _ -> False of
+ True -> pure ()
+ False -> issueAt beh (NoMatchingFormat f)
+ MaxLength m -> foldCheck min m NoMatchingMaxLength MatchingMaxLengthWeak $ \case
+ MaxLength m' -> Just m'
+ _ -> Nothing
+ MinLength m -> foldCheck max m NoMatchingMinLength MatchingMinLengthWeak $ \case
+ MinLength m' -> Just m'
+ _ -> Nothing
+ Pattern p -> case flip any prods $ \case
+ Pattern p' -> p == p'
+ _ -> False of
+ True -> pure ()
+ False -> issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32
+ StringFormat f -> case flip any prods $ \case
+ StringFormat f' -> f == f'
+ _ -> False of
+ True -> pure ()
+ False -> issueAt beh (NoMatchingFormat f)
+ Items _ cons' -> case foldSome (<>) prods $ \case
+ Items _ rs -> Just (Just (rs NE.:| []), mempty)
+ TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))
+ _ -> Nothing of
+ Just (mItems, Just pfs)
+ | not $ allSame (length <$> pfs) -> pure () -- vacuously
+ | let plen = genericLength (NE.head pfs) ->
+ clarifyIssue (AnItem beh (anIssue TupleToArray)) $
+ for_ [0 .. plen - 1] $ \i -> do
+ let prod' = tracedConjunct $ case mItems of
+ Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'
+ Nothing -> (`genericIndex` i) <$> pfs
+ checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'
+ Just (Just prods', Nothing) -> do
+ let prod' = tracedConjunct prods'
+ checkCompatibility (beh >>> step InItems) env $ ProdCons prod' cons'
+ _ -> clarifyIssue (AnItem beh (anIssue NoMatchingItems)) $ do
+ checkCompatibility (beh >>> step InItems) env $ ProdCons prodTopSchema cons'
+ TupleItems (map snd -> fs) -> case foldSome (<>) prods $ \case
+ TupleItems (map snd -> fs') -> Just (Just $ fs' NE.:| [], Just . Max $ genericLength fs', Just . Min $ genericLength fs', mempty)
+ MinItems m' -> Just (mempty, Just . Max $ m', mempty, mempty)
+ MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)
+ Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))
+ _ -> Nothing of
+ -- if the length constraints in the producer are contradictory:
+ Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()
+ -- We have an explicit tuple items clause...
+ Just (Just pfs, Just (Max plen), _, _)
+ | plen /= genericLength fs -> -- ...of wrong length
+ issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})
+ | otherwise ->
+ for_ [0 .. plen - 1] $ \i -> do
+ checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct $ (`genericIndex` i) <$> pfs) (fs `genericIndex` i)
+ -- We have a fixed length array in the producer...
+ Just (Nothing, Just (Max plen), Just (Min plen'), mProd)
+ | plen == plen' ->
+ clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of
+ _
+ | plen /= genericLength fs -> -- ...of wrong length
+ issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})
+ Just rs -> for_ [0 .. plen - 1] $ \i -> do
+ checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct rs) (fs `genericIndex` i)
+ -- ...and no "items" schema
+ Nothing -> clarifyIssue (AnItem beh (anIssue NoMatchingTupleItems)) $ do
+ for_ [0 .. plen - 1] $ \i -> do
+ checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prodTopSchema (fs `genericIndex` i)
+ _ -> issueAt beh NoMatchingTupleItems
+ MaxItems m -> foldCheck min m NoMatchingMaxItems MatchingMaxItemsWeak $ \case
+ MaxItems m' -> Just m'
+ TupleItems fs -> Just $ toInteger $ length fs
+ _ -> Nothing
+ MinItems m -> foldCheck max m NoMatchingMinItems MatchingMinItemsWeak $ \case
+ MinItems m' -> Just m'
+ TupleItems fs -> Just $ toInteger $ length fs
+ _ -> Nothing
+ UniqueItems -> case flip any prods $ \case
+ UniqueItems -> True
+ MaxItems 1 -> True
+ TupleItems fs | length fs == 1 -> True
+ _ -> False of
+ True -> pure ()
+ False -> issueAt beh NoMatchingUniqueItems
+ Properties props _ madd -> case foldSome (<>) prods $ \case
+ Properties props' _ madd' -> Just $ (props', madd') NE.:| []
+ _ -> Nothing of
+ Just pm ->
+ anyOfAt beh NoMatchingProperties $ -- TODO: could first "concat" the lists
+ NE.toList pm <&> \(props', madd') -> do
+ for_ (S.fromList $ M.keys props <> M.keys props') $ \k -> do
+ let beh' = beh >>> step (InProperty k)
+ go sch sch' = checkCompatibility beh' env (ProdCons sch sch')
+ case (maybe False propRequired $ M.lookup k props', maybe False propRequired $ M.lookup k props) of
+ -- producer does not require field, but consumer does (can fail)
+ (False, True) -> issueAt beh' PropertyNowRequired
+ _ -> pure ()
+ case (M.lookup k props', madd', M.lookup k props, madd) of
+ -- (producer, additional producer, consumer, additional consumer)
+ (Nothing, Nothing, _, _) -> pure () -- vacuously: the producer asserts that this field cannot exist,
+ -- and the consumer either doesn't require it, or it does and we've already raised an error about it.
+ (_, _, Nothing, Nothing) -> issueAt beh' UnexpectedProperty
+ (Just p', _, Just p, _) -> go (propRefSchema p') (propRefSchema p)
+ (Nothing, Just add', Just p, _) ->
+ clarifyIssue (AnItem beh' (anIssue AdditionalToProperty)) $
+ go add' (propRefSchema p)
+ (Just p', _, Nothing, Just add) ->
+ clarifyIssue (AnItem beh' (anIssue PropertyToAdditional)) $
+ go (propRefSchema p') add
+ (Nothing, Just _, Nothing, Just _) -> pure ()
+ pure ()
+ case (madd', madd) of
+ (Nothing, _) -> pure () -- vacuously
+ (_, Nothing) -> issueAt beh NoAdditionalProperties
+ (Just add', Just add) -> checkCompatibility (beh >>> step InAdditionalProperty) env (ProdCons add' add)
+ pure ()
+ Nothing -> issueAt beh NoMatchingProperties
+ MaxProperties m -> foldCheck min m NoMatchingMaxProperties MatchingMaxPropertiesWeak $ \case
+ MaxProperties m' -> Just m'
+ _ -> Nothing
+ MinProperties m -> foldCheck max m NoMatchingMinProperties MatchingMinPropertiesWeak $ \case
+ MinProperties m' -> Just m'
+ _ -> Nothing
+ where
+ lcmScientific (toRational -> a) (toRational -> b) =
+ fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
+
+ foldCheck ::
+ Eq a =>
+ (a -> a -> a) ->
+ a ->
+ (a -> Issue 'TypedSchemaLevel) ->
+ (ProdCons a -> Issue 'TypedSchemaLevel) ->
+ (forall t. Condition t -> Maybe a) ->
+ SemanticCompatFormula ()
+ foldCheck f m missing weak extr = case foldSome f prods extr of
+ Just m'
+ | f m' m == m' -> pure ()
+ | otherwise -> issueAt beh (weak ProdCons {producer = m', consumer = m})
+ Nothing -> issueAt beh (missing m)
+
+ prodTopSchema = traced (producer trs >>> step ImplicitTopSchema) $ Inline mempty
+
+allSame :: (Foldable f, Eq a) => f a -> Bool
+allSame xs = case group (toList xs) of
+ [] -> True
+ [_] -> True
+ _ -> False
+
+foldSome :: (b -> b -> b) -> S.Set a -> (a -> Maybe b) -> Maybe b
+foldSome combine xs extr =
+ fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr . S.toList $ xs
+
+findExactly :: S.Set (Condition t) -> Maybe (TypedValue t)
+findExactly xs = foldSome const xs $ \case
+ Exactly x -> Just x
+ _ -> Nothing
+
+instance Subtree Schema where
+ type SubtreeLevel Schema = 'SchemaLevel
+ type CheckEnv Schema = '[ProdCons (Traced (Definitions Schema))]
+ checkStructuralCompatibility env pc = do
+ structuralEq $ fmap _schemaRequired <$> pc
+ structuralEq $ fmap _schemaNullable <$> pc
+ structuralMaybeWith (structuralList env) $ tracedAllOf <$> pc
+ structuralMaybeWith (structuralList env) $ tracedOneOf <$> pc
+ structuralMaybe env $ sequence . stepTraced NotStep . fmap _schemaNot <$> pc
+ structuralMaybeWith (structuralList env) $ tracedAnyOf <$> pc
+ iohmStructural env $ stepTraced PropertiesStep . fmap _schemaProperties <$> pc
+ structuralMaybeWith structuralAdditionalProperties $ tracedAdditionalProperties <$> pc
+ structuralMaybeWith structuralDiscriminator $ tracedDiscriminator <$> pc
+ structuralEq $ fmap _schemaReadOnly <$> pc
+ structuralEq $ fmap _schemaWriteOnly <$> pc
+ structuralEq $ fmap _schemaXml <$> pc
+ structuralEq $ fmap _schemaMaxProperties <$> pc
+ structuralEq $ fmap _schemaMinProperties <$> pc
+ structuralEq $ fmap _schemaDefault <$> pc
+ structuralEq $ fmap _schemaType <$> pc
+ structuralEq $ fmap _schemaFormat <$> pc
+ structuralMaybeWith structuralItems $ tracedItems <$> pc
+ structuralEq $ fmap _schemaMaximum <$> pc
+ structuralEq $ fmap _schemaExclusiveMaximum <$> pc
+ structuralEq $ fmap _schemaMinimum <$> pc
+ structuralEq $ fmap _schemaExclusiveMinimum <$> pc
+ structuralEq $ fmap _schemaMaxLength <$> pc
+ structuralEq $ fmap _schemaMinLength <$> pc
+ structuralEq $ fmap _schemaPattern <$> pc
+ structuralEq $ fmap _schemaMaxItems <$> pc
+ structuralEq $ fmap _schemaMinItems <$> pc
+ structuralEq $ fmap _schemaUniqueItems <$> pc
+ structuralEq $ fmap _schemaEnum <$> pc
+ structuralEq $ fmap _schemaMultipleOf <$> pc
+ pure ()
+ where
+ structuralAdditionalProperties
+ (ProdCons (Left x) (Left y)) = unless (x == y) structuralIssue
+ structuralAdditionalProperties
+ (ProdCons (Right x) (Right y)) =
+ checkSubstructure env $ ProdCons x y
+ structuralAdditionalProperties _ = structuralIssue
+ structuralDiscriminator pc' = do
+ structuralEq $ fmap _discriminatorPropertyName <$> pc'
+ iohmStructural env $
+ stepTraced DiscriminatorMapping . fmap (fmap parseDiscriminatorValue . _discriminatorMapping) <$> pc'
+ pure ()
+ structuralItems (ProdCons (Left a) (Left b)) =
+ checkSubstructure env $ ProdCons a b
+ structuralItems (ProdCons (Right a) (Right b)) =
+ structuralList env $ ProdCons a b
+ structuralItems _ = structuralIssue
+ checkSemanticCompatibility env beh schs = do
+ let defs = getH env
+ checkFormulas env beh (ask <$> schs) defs $ schemaToFormula <$> defs <*> schs
+
+parseDiscriminatorValue :: Text -> Referenced Schema
+parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of
+ A.Success x -> x
+ A.Error _ -> Ref $ Reference v
diff --git a/src/Data/OpenApi/Compare/Validate/Schema/DNF.hs b/src/Data/OpenApi/Compare/Validate/Schema/DNF.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Schema/DNF.hs
@@ -0,0 +1,101 @@
+module Data.OpenApi.Compare.Validate.Schema.DNF
+ ( DNF (..),
+ Disjunct (..),
+ pattern SingleDisjunct,
+ pattern TopDNF,
+ pattern BottomDNF,
+ pattern LiteralDNF,
+ foldDNF,
+ forDNF,
+ )
+where
+
+import Algebra.Lattice
+import Control.Applicative
+import Data.Foldable
+import qualified Data.Set as S
+
+-- | A boolean formula (without "not") represented as a Disjunctive Normal Form:
+-- the formula is a disjunction of a set of clauses, each of which is a
+-- conjunction of a set of some elementary formulas.
+-- Invariant: no two disjuncts imply eachother
+newtype DNF a = DNF (S.Set (Disjunct a))
+ deriving stock (Eq, Ord, Show)
+
+-- A disjunct is a thing that is to be disjuncted. Itself it is a conjunction of some literals.
+newtype Disjunct a = Disjunct (S.Set a)
+ deriving stock (Eq, Ord, Show)
+
+disjImplies :: Ord a => Disjunct a -> Disjunct a -> Bool
+disjImplies (Disjunct xs) (Disjunct ys) = ys `S.isSubsetOf` xs
+
+disjConjunction :: Ord a => Disjunct a -> Disjunct a -> Disjunct a
+disjConjunction (Disjunct xs) (Disjunct ys) = Disjunct $ xs `S.union` ys
+
+disjAdd :: Ord a => DNF a -> Disjunct a -> DNF a
+disjAdd (DNF yss) xs
+ | any (xs `disjImplies`) yss = DNF yss
+ | otherwise = DNF $ S.insert xs $ S.filter (not . (`disjImplies` xs)) yss
+
+instance Ord a => Lattice (DNF a) where
+ xss \/ DNF yss = S.foldl' disjAdd xss yss
+ DNF xss /\ DNF yss =
+ foldl' disjAdd bottom $
+ liftA2 disjConjunction (S.toList xss) (S.toList yss)
+
+pattern BottomDNF :: DNF a
+pattern BottomDNF <-
+ DNF (S.null -> True)
+ where
+ BottomDNF = DNF S.empty
+
+isSingleton :: S.Set a -> Maybe a
+isSingleton s
+ | S.size s == 1 = S.lookupMin s
+ | otherwise = Nothing
+
+pattern SingleDisjunct :: Ord a => Disjunct a -> DNF a
+pattern SingleDisjunct xs <-
+ DNF (isSingleton -> Just xs)
+ where
+ SingleDisjunct xs = DNF $ S.singleton xs
+
+pattern TopDNF :: DNF a
+pattern TopDNF <-
+ DNF (isSingleton -> Just (Disjunct (S.null -> True)))
+ where
+ TopDNF = DNF $ S.singleton $ Disjunct S.empty
+
+pattern LiteralDNF :: Ord a => a -> DNF a
+pattern LiteralDNF x <-
+ SingleDisjunct (Disjunct (isSingleton -> Just x))
+ where
+ LiteralDNF x = SingleDisjunct $ Disjunct $ S.singleton x
+
+instance Ord a => BoundedJoinSemiLattice (DNF a) where
+ bottom = BottomDNF
+
+instance Ord a => BoundedMeetSemiLattice (DNF a) where
+ top = TopDNF
+
+foldDisjunct :: BoundedMeetSemiLattice l => (a -> l) -> Disjunct a -> l
+foldDisjunct f (Disjunct xs) = S.foldl' (\y l -> y /\ f l) top xs
+
+foldDNF :: BoundedLattice l => (a -> l) -> DNF a -> l
+foldDNF f (DNF xss) = S.foldl' (\y xs -> y \/ foldDisjunct f xs) bottom xss
+
+newtype LiftA f a = LiftA {getLiftA :: f a}
+ deriving newtype (Functor, Applicative)
+
+instance (Lattice a, Applicative f) => Lattice (LiftA f a) where
+ (/\) = liftA2 (/\)
+ (\/) = liftA2 (\/)
+
+instance (BoundedJoinSemiLattice a, Applicative f) => BoundedJoinSemiLattice (LiftA f a) where
+ bottom = pure bottom
+
+instance (BoundedMeetSemiLattice a, Applicative f) => BoundedMeetSemiLattice (LiftA f a) where
+ top = pure top
+
+forDNF :: (BoundedLattice l, Applicative f) => (a -> f l) -> DNF a -> f l
+forDNF f = getLiftA . foldDNF (LiftA . f)
diff --git a/src/Data/OpenApi/Compare/Validate/Schema/Issues.hs b/src/Data/OpenApi/Compare/Validate/Schema/Issues.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Schema/Issues.hs
@@ -0,0 +1,321 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.Schema.Issues
+ ( Issue (..),
+ Behave (..),
+ )
+where
+
+import qualified Data.Aeson as A
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Schema.JsonFormula
+import Data.OpenApi.Compare.Validate.Schema.Partition
+import Data.OpenApi.Compare.Validate.Schema.TypedJson
+import Data.Scientific
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.Pandoc.Builder hiding (Format, Null)
+
+instance Issuable 'TypedSchemaLevel where
+ data Issue 'TypedSchemaLevel
+ = -- | 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 match 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
+ | -- | producer and consumer declare that an array must be a tuple of a fixed length, but the lengths don't match
+ TupleItemsLengthChanged (ProdCons Integer)
+ | -- | consumer declares that the array is a tuple, but the producer doesn't, the length constraints match, but there were issues with the components
+ ArrayToTuple
+ | -- | producer declares that the array is a tuple, but the consumer doesn't, and there were issues with the components
+ TupleToArray
+ | -- | consumer declares that the array is a tuple, but the producer doesn't, and there aren't sufficient length constraints
+ NoMatchingTupleItems
+ | -- | 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 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)
+ | -- | producer declares that the value must satisfy a disjunction of some conditions, but consumer's requirements couldn't be matched against any single one of them (TODO: split heuristic #71)
+ NoMatchingCondition (Maybe Partition) [SomeCondition]
+ | -- | consumer indicates that no values of this type are allowed, but we weren't able to conclude that in the producer (currently only immediate contradictions are checked, c.f. #70)
+ TypeBecomesEmpty
+ | -- | consumer indicates that no values in a particular partition are allowed, but we weren't able to conclude this in the producer
+ PartitionBecomesEmpty Partition
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ NoMatchingEnum _ -> ProbablyIssue
+ MatchingMaximumWeak _ -> ProbablyIssue -- interplay with MultipleOf could make this not an issue
+ MatchingMinimumWeak _ -> ProbablyIssue -- ditto
+ MatchingMultipleOfWeak _ -> ProbablyIssue -- ditto
+ NoMatchingFormat _ -> Unsupported
+ NoMatchingPattern _ -> Unsupported
+ ArrayToTuple -> Comment
+ TupleToArray -> Comment
+ NoMatchingProperties -> ProbablyIssue -- TODO: #109
+ TypeBecomesEmpty -> ProbablyIssue -- TODO: #70
+ PartitionBecomesEmpty _ -> ProbablyIssue -- ditto
+ _ -> CertainIssue
+ relatedIssues =
+ (==) `withClass` \case
+ EnumDoesntSatisfy v -> Just v
+ NoMatchingEnum v -> Just v
+ _ -> Nothing
+ `withClass` \case
+ NoMatchingMaximum _ -> Just ()
+ MatchingMaximumWeak _ -> Just ()
+ _ -> Nothing
+ `withClass` \case
+ NoMatchingMinimum _ -> Just ()
+ MatchingMinimumWeak _ -> Just ()
+ _ -> Nothing
+ `withClass` \case
+ NoMatchingMultipleOf _ -> Just ()
+ MatchingMultipleOfWeak _ -> Just ()
+ _ -> Nothing
+ `withClass` \case
+ NoMatchingMaxLength _ -> Just ()
+ MatchingMaxLengthWeak _ -> Just ()
+ _ -> Nothing
+ `withClass` \case
+ NoMatchingMinLength _ -> Just ()
+ MatchingMinLengthWeak _ -> Just ()
+ _ -> Nothing
+ `withClass` \case
+ NoMatchingItems -> Just ()
+ ArrayToTuple -> Just ()
+ TupleToArray -> Just ()
+ NoMatchingTupleItems -> Just ()
+ TupleItemsLengthChanged _ -> Just ()
+ _ -> Nothing
+ `withClass` \case
+ NoMatchingMaxItems _ -> Just ()
+ MatchingMaxItemsWeak _ -> Just ()
+ _ -> Nothing
+ `withClass` \case
+ NoMatchingMinItems _ -> Just ()
+ MatchingMinItemsWeak _ -> Just ()
+ _ -> Nothing
+ `withClass` \case
+ NoMatchingMaxProperties _ -> Just ()
+ MatchingMaxPropertiesWeak _ -> Just ()
+ _ -> Nothing
+ `withClass` \case
+ NoMatchingMinProperties _ -> Just ()
+ MatchingMinPropertiesWeak _ -> Just ()
+ _ -> Nothing
+ describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v
+ describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v
+ describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v
+ describeIssue Backward (NoMatchingEnum v) = para "The following enum value has been removed:" <> showJSONValue v
+ describeIssue Forward (NoMatchingMaximum b) = para $ "Upper bound has been added:" <> showBound b <> "."
+ describeIssue Backward (NoMatchingMaximum b) = para $ "Upper bound has been removed:" <> showBound b <> "."
+ describeIssue ori (MatchingMaximumWeak (orientProdCons ori -> ProdCons p c)) =
+ para $ "Upper bound changed from " <> showBound p <> " to " <> showBound c <> "."
+ describeIssue Forward (NoMatchingMinimum b) = para $ "Lower bound has been added: " <> showBound b <> "."
+ describeIssue Backward (NoMatchingMinimum b) = para $ "Lower bound has been removed: " <> showBound b <> "."
+ describeIssue ori (MatchingMinimumWeak (orientProdCons ori -> ProdCons p c)) =
+ para $ "Lower bound changed from " <> showBound p <> " to " <> showBound c <> "."
+ describeIssue Forward (NoMatchingMultipleOf n) = para $ "Value is now a multiple of " <> show' n <> "."
+ describeIssue Backward (NoMatchingMultipleOf n) = para $ "Value is no longer a multiple of " <> show' n <> "."
+ describeIssue ori (MatchingMultipleOfWeak (orientProdCons ori -> ProdCons p c)) =
+ para $ "Value changed from being a multiple of " <> show' p <> " to being a multiple of " <> show' c <> "."
+ describeIssue Forward (NoMatchingFormat f) = para $ "Format added: " <> code f <> "."
+ describeIssue Backward (NoMatchingFormat f) = para $ "Format removed: " <> code f <> "."
+ describeIssue Forward (NoMatchingMaxLength n) = para $ "Maximum length added: " <> show' n <> "."
+ describeIssue Backward (NoMatchingMaxLength n) = para $ "Maximum length removed: " <> show' n <> "."
+ describeIssue ori (MatchingMaxLengthWeak (orientProdCons ori -> ProdCons p c)) =
+ para $ "Maximum length of the string changed from " <> show' p <> " to " <> show' c <> "."
+ describeIssue Forward (NoMatchingMinLength n) = para $ "Minimum length of the string added: " <> show' n <> "."
+ describeIssue Backward (NoMatchingMinLength n) = para $ "Minimum length of the string removed: " <> show' n <> "."
+ describeIssue ori (MatchingMinLengthWeak (orientProdCons ori -> ProdCons p c)) =
+ para $ "Minimum length of the string changed from " <> show' p <> " to " <> show' c <> "."
+ describeIssue Forward (NoMatchingPattern p) = para "Pattern (regular expression) added: " <> codeBlock p
+ describeIssue Backward (NoMatchingPattern p) = para "Pattern (regular expression) removed: " <> codeBlock p
+ describeIssue Forward NoMatchingItems = para "Array item schema has been added."
+ describeIssue Backward NoMatchingItems = para "Array item schema has been removed."
+ describeIssue ori (TupleItemsLengthChanged (orientProdCons ori -> ProdCons p c)) =
+ para $ "Tuple length changed from " <> show' p <> " to " <> show' c <> "."
+ describeIssue Forward ArrayToTuple = para "The array is now explicitly defined as a tuple."
+ describeIssue Backward ArrayToTuple = para "The array is no longer explicitly defined as a tuple."
+ describeIssue Forward TupleToArray = para "The array is no longer explicitly defined as a tuple."
+ describeIssue Backward TupleToArray = para "The array is now explicitly defined as a tuple."
+ describeIssue Forward NoMatchingTupleItems = para "The array is now explicitly defined as a tuple."
+ describeIssue Backward NoMatchingTupleItems = para "The array is no longer explicitly defined as a tuple."
+ describeIssue Forward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been added " <> show' n <> "."
+ describeIssue Backward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been removed " <> show' n <> "."
+ describeIssue ori (MatchingMaxItemsWeak (orientProdCons ori -> ProdCons p c)) =
+ para $ "Maximum length of the array changed from " <> show' p <> " to " <> show' c <> "."
+ describeIssue Forward (NoMatchingMinItems n) = para $ "Minimum length of the array added: " <> show' n <> "."
+ describeIssue Backward (NoMatchingMinItems n) = para $ "Minimum length of the array removed: " <> show' n <> "."
+ describeIssue ori (MatchingMinItemsWeak (orientProdCons ori -> ProdCons p c)) =
+ para $ "Minimum length of the array changed from " <> show' p <> " to " <> show' c <> "."
+ describeIssue Forward NoMatchingUniqueItems = para "Items are now required to be unique."
+ describeIssue Backward NoMatchingUniqueItems = para "Items are no longer required to be unique."
+ describeIssue Forward NoMatchingProperties = para "Property added."
+ describeIssue Backward NoMatchingProperties = para "Property removed."
+ describeIssue Forward NoAdditionalProperties = para "Additional properties have been removed."
+ describeIssue Backward NoAdditionalProperties = para "Additional properties have been added."
+ describeIssue Forward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been added: " <> show' n <> "."
+ describeIssue Backward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been removed: " <> show' n <> "."
+ describeIssue ori (MatchingMaxPropertiesWeak (orientProdCons ori -> ProdCons p c)) =
+ para $ "Maximum number of properties has changed from " <> show' p <> " to " <> show' c <> "."
+ describeIssue Forward (NoMatchingMinProperties n) = para $ "Minimum number of properties added: " <> show' n <> "."
+ describeIssue Backward (NoMatchingMinProperties n) = para $ "Minimum number of properties removed: " <> show' n <> "."
+ describeIssue ori (MatchingMinPropertiesWeak (orientProdCons ori -> ProdCons p c)) =
+ para $ "Minimum number of properties has changed from " <> show' p <> " to " <> show' c <> "."
+ describeIssue _ (NoMatchingCondition mPart conds) =
+ para
+ ( case mPart of
+ Nothing -> "Could not verify that the following conditions hold (please file a bug if you see this):"
+ Just locPart ->
+ "In cases where " <> showPartition locPart
+ <> " – could not verify that the following conditions hold (please file a bug if you see this):"
+ )
+ <> bulletList ((\(SomeCondition c) -> showCondition c) <$> conds)
+ describeIssue Forward TypeBecomesEmpty = para "The type has been removed."
+ describeIssue Backward TypeBecomesEmpty = para "The type has been added."
+ describeIssue Forward (PartitionBecomesEmpty part) = para $ "The case where " <> showPartition part <> " – has been removed."
+ describeIssue Backward (PartitionBecomesEmpty part) = para $ "The case where " <> showPartition part <> " – has been added."
+
+show' :: Show x => x -> Inlines
+show' = str . T.pack . show
+
+instance Issuable 'SchemaLevel where
+ data Issue 'SchemaLevel
+ = -- | Some (openapi-supported) feature that we do not support was encountered in the schema
+ NotSupported Text
+ | -- | We couldn't prove that the branches of a oneOf are disjoint, and we will treat it as an anyOf, meaning we don't check whether the overlaps are excluded in a compatible way
+ OneOfNotDisjoint
+ | -- | The schema is actually invalid
+ InvalidSchema Text
+ | -- | The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".
+ UnguardedRecursion
+ | -- | Producer doesn't place any restrictions on the types, but the consumer does. List what types remain available in the consumer.
+ TypesRestricted [JsonType]
+ | -- | in the producer this field used to be handled as part of "additionalProperties", and the consumer this is a specific "properties" entry. Only thrown when this change actually causes other issues
+ AdditionalToProperty
+ | -- | in the consumer this field used to be handled as part of "additionalProperties", and the producer this is a specific "properties" entry. Only thrown when this change actually causes other issues
+ PropertyToAdditional
+ | -- | consumer requires a property that is not required/allowed in the producer
+ PropertyNowRequired
+ | -- | producer allows a property that is not allowed in the consumer
+ UnexpectedProperty
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ NotSupported _ -> Unsupported
+ OneOfNotDisjoint -> Unsupported
+ InvalidSchema _ -> SchemaInvalid
+ UnguardedRecursion -> Unsupported
+ AdditionalToProperty -> Comment
+ PropertyToAdditional -> Comment
+ TypesRestricted _ -> ProbablyIssue -- TODO: #70
+ _ -> CertainIssue
+ relatedIssues =
+ (==) `withClass` \case
+ AdditionalToProperty -> Just ()
+ PropertyToAdditional -> Just ()
+ _ -> Nothing
+ `withClass` \case
+ PropertyNowRequired -> Just ()
+ UnexpectedProperty -> Just ()
+ _ -> Nothing
+ describeIssue _ (NotSupported i) =
+ para (emph "Encountered a feature that CompaREST does not support: " <> text i <> ".")
+ describeIssue _ OneOfNotDisjoint =
+ para $
+ "Could not deduce that " <> code "oneOf"
+ <> " cases don't overlap. Treating the "
+ <> code "oneOf"
+ <> " as an "
+ <> code "anyOf"
+ <> ". Reported errors might not be accurate."
+ describeIssue _ (InvalidSchema i) =
+ para (emph "The schema is invalid: " <> text i <> ".")
+ describeIssue _ UnguardedRecursion =
+ para "Encountered recursion that is too complex for CompaREST to untangle."
+ describeIssue Forward (TypesRestricted tys) = case tys of
+ [] -> para "No longer has any valid values." -- weird
+ _ -> para "Values are now limited to the following types: " <> bulletList (para . describeJSONType <$> tys)
+ describeIssue Backward (TypesRestricted tys) = case tys of
+ [] -> para "Any value of any type is now allowed." -- weird
+ _ -> para "Values are no longer limited to the following types: " <> bulletList (para . describeJSONType <$> tys)
+ describeIssue Forward AdditionalToProperty = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."
+ describeIssue Backward AdditionalToProperty = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."
+ describeIssue Forward PropertyToAdditional = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."
+ describeIssue Backward PropertyToAdditional = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."
+ describeIssue Forward PropertyNowRequired = para "The property has become required."
+ describeIssue Backward PropertyNowRequired = para "The property may not be present."
+ describeIssue Forward UnexpectedProperty = para "The property has been removed."
+ describeIssue Backward UnexpectedProperty = para "The property has been added."
+
+instance Behavable 'SchemaLevel 'TypedSchemaLevel where
+ data Behave 'SchemaLevel 'TypedSchemaLevel
+ = OfType JsonType
+ deriving stock (Eq, Ord, Show)
+
+ describeBehavior (OfType t) = describeJSONType t
+
+instance Behavable 'TypedSchemaLevel 'TypedSchemaLevel where
+ data Behave 'TypedSchemaLevel 'TypedSchemaLevel
+ = InPartition Partition
+ deriving stock (Eq, Ord, Show)
+
+ describeBehavior (InPartition partition) = "In cases where " <> showPartition partition
+
+instance Behavable 'TypedSchemaLevel 'SchemaLevel where
+ data Behave 'TypedSchemaLevel 'SchemaLevel
+ = InItems
+ | InItem Integer
+ | InProperty Text
+ | InAdditionalProperty
+ deriving stock (Eq, Ord, Show)
+
+ describeBehavior InItems = "Items"
+ describeBehavior (InItem i) = "Item " <> show' i
+ describeBehavior (InProperty p) = "Property " <> code p
+ describeBehavior InAdditionalProperty = "Additional properties"
diff --git a/src/Data/OpenApi/Compare/Validate/Schema/JsonFormula.hs b/src/Data/OpenApi/Compare/Validate/Schema/JsonFormula.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Schema/JsonFormula.hs
@@ -0,0 +1,236 @@
+module Data.OpenApi.Compare.Validate.Schema.JsonFormula
+ ( Bound (..),
+ showBound,
+ Property (..),
+ Condition (..),
+ showCondition,
+ satisfiesTyped,
+ checkStringFormat,
+ checkNumberFormat,
+ SomeCondition (..),
+ JsonFormula (..),
+ satisfiesFormula,
+ satisfies,
+ showJSONValue,
+ showJSONValueInline,
+ )
+where
+
+import Algebra.Lattice
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Foldable as F
+import Data.Functor
+import qualified Data.HashMap.Strict as HM
+import Data.Int
+import Data.Kind
+import qualified Data.Map as M
+import Data.Maybe
+import Data.OpenApi
+import Data.OpenApi.Compare.Orphans ()
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Schema.DNF
+import Data.OpenApi.Compare.Validate.Schema.TypedJson
+import Data.Ord
+import Data.Ratio
+import Data.Scientific
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.Typeable
+import Text.Pandoc.Builder hiding (Format, Null)
+import Text.Regex.Pcre2
+
+data Bound a = Exclusive !a | Inclusive !a
+ deriving stock (Eq, Show, Functor)
+
+-- | The order is lexicographical on @a * Bool@.
+instance Ord a => Ord (Bound a) where
+ Exclusive a `compare` Exclusive b = compare a b
+ Exclusive a `compare` Inclusive b = if a <= b then LT else GT
+ Inclusive a `compare` Exclusive b = if a < b then LT else GT
+ Inclusive a `compare` Inclusive b = compare a b
+
+showBound :: Show a => Bound a -> Inlines
+showBound (Inclusive x) = show' x <> " inclusive"
+showBound (Exclusive x) = show' x <> " exclusive"
+
+data Property = Property
+ { propRequired :: Bool
+ , propFormula :: ForeachType JsonFormula
+ , propRefSchema :: Traced (Referenced Schema)
+ }
+ deriving stock (Eq, Ord, Show)
+
+-- | A primitive structural condition for the "top level" of a JSON value (of a specific type)
+data Condition :: JsonType -> Type where
+ Exactly :: TypedValue t -> Condition t
+ Maximum :: !(Bound Scientific) -> Condition 'Number
+ Minimum ::
+ !(Down (Bound (Down Scientific))) ->
+ -- | this has the right Ord
+ Condition 'Number
+ MultipleOf :: !Scientific -> Condition 'Number
+ NumberFormat :: !Format -> Condition 'Number
+ MaxLength :: !Integer -> Condition 'String
+ MinLength :: !Integer -> Condition 'String
+ Pattern :: !Pattern -> Condition 'String
+ StringFormat :: !Format -> Condition 'String
+ Items ::
+ !(ForeachType JsonFormula) ->
+ !(Traced (Referenced Schema)) ->
+ Condition 'Array
+ TupleItems ::
+ ![(ForeachType JsonFormula, Traced (Referenced Schema))] ->
+ Condition 'Array
+ MaxItems :: !Integer -> Condition 'Array
+ MinItems :: !Integer -> Condition 'Array
+ UniqueItems :: Condition 'Array
+ Properties ::
+ !(M.Map Text Property) ->
+ -- | formula for additional properties
+ !(ForeachType JsonFormula) ->
+ -- | schema for additional properties, Nothing means bottom
+ !(Maybe (Traced (Referenced Schema))) ->
+ Condition 'Object
+ MaxProperties :: !Integer -> Condition 'Object
+ MinProperties :: !Integer -> Condition 'Object
+
+deriving stock instance Eq (Condition t)
+
+deriving stock instance Ord (Condition t)
+
+deriving stock instance Show (Condition t)
+
+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
+ (TupleItems is) -> para ("There should be " <> show' (length is) <> " items in the array:") <> bulletList (showForEachJsonFormula . fst <$> is)
+ (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 -> case getJsonFormula $ f i of
+ BottomDNF -> mempty
+ (DNF conds) ->
+ [ para (describeJSONType t)
+ <> bulletList
+ ( S.toList conds <&> \case
+ Disjunct (S.toList -> []) -> para "Empty"
+ Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond)
+ )
+ ]
+ )
+
+showJSONValue :: A.Value -> Blocks
+showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
+
+showJSONValueInline :: A.Value -> Inlines
+showJSONValueInline v = code (T.decodeUtf8 . BSL.toStrict . A.encode $ v)
+
+show' :: Show x => x -> Inlines
+show' = str . T.pack . show
+
+satisfiesTyped :: TypedValue t -> Condition t -> Bool
+satisfiesTyped e (Exactly e') = e == e'
+satisfiesTyped (TNumber n) (Maximum (Exclusive m)) = n < m
+satisfiesTyped (TNumber n) (Maximum (Inclusive m)) = n <= m
+satisfiesTyped (TNumber n) (Minimum (Down (Exclusive (Down m)))) = n > m
+satisfiesTyped (TNumber n) (Minimum (Down (Inclusive (Down m)))) = n >= m
+satisfiesTyped (TNumber n) (MultipleOf m) = denominator (toRational n / toRational m) == 1 -- TODO: could be better #36
+satisfiesTyped (TNumber n) (NumberFormat f) = checkNumberFormat f n
+satisfiesTyped (TString s) (MaxLength m) = fromIntegral (T.length s) <= m
+satisfiesTyped (TString s) (MinLength m) = fromIntegral (T.length s) >= m
+satisfiesTyped (TString s) (Pattern p) = isJust $ match p s -- TODO: regex stuff #32
+satisfiesTyped (TString s) (StringFormat f) = checkStringFormat f s
+satisfiesTyped (TArray a) (Items f _) = all (`satisfies` f) a
+satisfiesTyped (TArray a) (TupleItems fs) = length fs == F.length a && and (zipWith satisfies (F.toList a) (fst <$> fs))
+satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m
+satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m
+satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36
+satisfiesTyped (TObject o) (Properties props additional _) =
+ all (`HM.member` o) (M.keys (M.filter propRequired props))
+ && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)
+satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m
+satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m
+
+checkNumberFormat :: Format -> Scientific -> Bool
+checkNumberFormat "int32" (toRational -> n) =
+ denominator n == 1
+ && n >= toRational (minBound :: Int32)
+ && n <= toRational (maxBound :: Int32)
+checkNumberFormat "int64" (toRational -> n) =
+ denominator n == 1
+ && n >= toRational (minBound :: Int64)
+ && n <= toRational (maxBound :: Int64)
+checkNumberFormat "float" _n = True
+checkNumberFormat "double" _n = True
+checkNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f
+
+checkStringFormat :: Format -> Text -> Bool
+checkStringFormat "byte" _s = True -- TODO: regex stuff #32
+checkStringFormat "binary" _s = True
+checkStringFormat "date" _s = True
+checkStringFormat "date-time" _s = True
+checkStringFormat "password" _s = True
+checkStringFormat "uuid" _s = True
+checkStringFormat f _s = error $ "Invalid string format: " <> T.unpack f
+
+data SomeCondition where
+ SomeCondition :: Typeable t => Condition t -> SomeCondition
+
+instance Eq SomeCondition where
+ SomeCondition x == SomeCondition y = case cast x of
+ Just x' -> x' == y
+ Nothing -> False
+
+instance Ord SomeCondition where
+ compare (SomeCondition x) (SomeCondition y) = case cast x of
+ Just x' -> compare x' y
+ Nothing -> compare (typeRep x) (typeRep y)
+
+deriving stock instance Show SomeCondition
+
+newtype JsonFormula t = JsonFormula {getJsonFormula :: DNF (Condition t)}
+ deriving stock (Eq, Ord, Show)
+ deriving newtype (Lattice, BoundedJoinSemiLattice, BoundedMeetSemiLattice)
+
+satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool
+satisfiesFormula val = foldDNF (satisfiesTyped val) . getJsonFormula
+
+satisfies :: A.Value -> ForeachType JsonFormula -> Bool
+satisfies val p = case val of
+ A.Null -> satisfiesFormula TNull $ forNull p
+ A.Bool b -> satisfiesFormula (TBool b) $ forBoolean p
+ A.Number n -> satisfiesFormula (TNumber n) $ forNumber p
+ A.String s -> satisfiesFormula (TString s) $ forString p
+ A.Array a -> satisfiesFormula (TArray a) $ forArray p
+ A.Object o -> satisfiesFormula (TObject o) $ forObject p
diff --git a/src/Data/OpenApi/Compare/Validate/Schema/Partition.hs b/src/Data/OpenApi/Compare/Validate/Schema/Partition.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Schema/Partition.hs
@@ -0,0 +1,317 @@
+module Data.OpenApi.Compare.Validate.Schema.Partition
+ ( partitionSchema,
+ partitionRefSchema,
+ selectPartition,
+ runPartitionM,
+ tryPartition,
+ showPartition,
+ intersectSchema,
+ intersectRefSchema,
+ IntersectionResult (..),
+ runIntersectionM,
+ Partition,
+ )
+where
+
+import Algebra.Lattice
+import Algebra.Lattice.Lifted
+import Control.Applicative
+import Control.Monad.Reader hiding (ask)
+import qualified Control.Monad.Reader as R
+import Control.Monad.State
+import qualified Control.Monad.Trans.Reader as R (liftCatch)
+import qualified Control.Monad.Trans.Writer as W (liftCatch)
+import Control.Monad.Writer
+import qualified Data.Aeson as A
+import Data.Foldable
+import Data.Functor.Identity
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import Data.List (sortBy)
+import qualified Data.List as L
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map as M
+import Data.Maybe
+import Data.OpenApi
+import Data.OpenApi.Compare.Memo
+import Data.OpenApi.Compare.References
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Schema.DNF
+import Data.OpenApi.Compare.Validate.Schema.JsonFormula
+import Data.OpenApi.Compare.Validate.Schema.Traced
+import Data.OpenApi.Compare.Validate.Schema.TypedJson
+import Data.Ord
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.Pandoc.Builder hiding (Format, Null)
+
+data PartitionData
+ = DByEnumValue (DNF (S.Set A.Value))
+ | DByProperties (DNF (S.Set Text, S.Set Text)) -- optional, required
+ deriving stock (Eq, Ord, Show)
+
+conjPart :: PartitionData -> PartitionData -> Maybe PartitionData
+conjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss /\ yss
+conjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss /\ yss
+conjPart _ _ = Nothing
+
+disjPart :: PartitionData -> PartitionData -> Maybe PartitionData
+disjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss \/ yss
+disjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss \/ yss
+disjPart _ _ = Nothing
+
+newtype Partitions = Partitions (M.Map PartitionLocation (S.Set PartitionData))
+ deriving stock (Eq, Ord, Show)
+
+instance Lattice Partitions where
+ Partitions xss /\ Partitions yss = Partitions $ M.unionWith conj xss yss
+ where
+ conj xs ys = S.fromList . catMaybes $ liftA2 conjPart (S.toList xs) (S.toList ys)
+ Partitions xss \/ Partitions yss = Partitions $ M.intersectionWith disj xss yss
+ where
+ disj xs ys = S.fromList . catMaybes $ liftA2 disjPart (S.toList xs) (S.toList ys)
+
+instance BoundedMeetSemiLattice Partitions where
+ top = Partitions M.empty
+
+-- The lattice has no bottom, but we use 'Lifted' to adjoin a free bottom element
+
+type PartitionM = ReaderT (Traced (Definitions Schema)) (State (MemoState ()))
+
+ignoreKnot :: KnotTier (Lifted Partitions) () PartitionM
+ignoreKnot =
+ KnotTier
+ { onKnotFound = pure ()
+ , onKnotUsed = \_ -> pure bottom
+ , tieKnot = \_ -> pure
+ }
+
+singletonPart :: PartitionData -> Lifted Partitions
+singletonPart = Lift . Partitions . M.singleton PHere . S.singleton
+
+partitionSchema :: Traced Schema -> PartitionM (Lifted Partitions)
+partitionSchema sch = do
+ allClauses <- case tracedAllOf sch of
+ Nothing -> pure []
+ Just xs -> mapM partitionRefSchema xs
+
+ anyClause <- case tracedAnyOf sch of
+ Nothing -> pure top
+ Just xs -> joins <$> mapM partitionRefSchema xs
+
+ oneClause <- case tracedOneOf sch of
+ Nothing -> pure top
+ Just xs -> joins <$> mapM partitionRefSchema xs
+
+ byEnumClause <- case _schemaEnum $ extract sch of
+ Nothing -> pure top
+ Just xs ->
+ pure . singletonPart $
+ DByEnumValue $ LiteralDNF (S.fromList xs)
+
+ -- We can only partition by presence of a property if additional properties
+ -- are disallowed, and the property is not optional
+ let reqd = S.fromList $ _schemaRequired $ extract sch
+ byPropertiesClause <- case _schemaAdditionalProperties $ extract sch of
+ Just (AdditionalPropertiesAllowed False) -> do
+ let props = S.fromList . IOHM.keys . _schemaProperties $ extract sch
+ pure . singletonPart $
+ DByProperties $ LiteralDNF (props S.\\ reqd, props `S.intersection` reqd)
+ _ -> pure top
+
+ -- We can partition on something nested in a property only if the property is
+ -- required
+ let reqdProps = IOHM.filterWithKey (\k _ -> k `S.member` reqd) $ tracedProperties sch
+ inPropertiesClauses <- forM (IOHM.toList reqdProps) $ \(k, rs) -> do
+ f <- partitionRefSchema rs
+ pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f
+
+ pure $ meets $ allClauses <> [anyClause, oneClause, byEnumClause, byPropertiesClause] <> inPropertiesClauses
+
+partitionRefSchema :: Traced (Referenced Schema) -> PartitionM (Lifted Partitions)
+partitionRefSchema x = do
+ defs <- R.ask
+ memoWithKnot ignoreKnot (partitionSchema $ dereference defs x) (ask x)
+
+partitionCondition :: Condition t -> PartitionM (Lifted Partitions)
+partitionCondition = \case
+ Exactly x ->
+ pure . singletonPart $
+ DByEnumValue $ LiteralDNF (S.singleton $ untypeValue x)
+ Properties props _ madd -> do
+ let byProps = case madd of
+ Just _ -> top
+ Nothing ->
+ singletonPart $
+ DByProperties $
+ LiteralDNF
+ ( M.keysSet $ M.filter (not . propRequired) props
+ , M.keysSet $ M.filter propRequired props
+ )
+ inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do
+ f <- partitionRefSchema $ propRefSchema prop
+ pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f
+ pure $ byProps /\ meets inProps
+ _ -> pure top
+
+runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a
+runPartitionM defs = runIdentity . runMemo () . (`runReaderT` defs)
+
+partitionJsonFormulas ::
+ ProdCons (Traced (Definitions Schema)) ->
+ ProdCons (JsonFormula t) ->
+ Lifted Partitions
+partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart
+ where
+ pcPart = partitionFormula <$> defs <*> pc
+ partitionFormula def (JsonFormula xss) = runPartitionM def $ forDNF partitionCondition xss
+
+selectPartition :: Lifted Partitions -> Maybe (PartitionLocation, S.Set PartitionChoice)
+selectPartition Bottom = Nothing
+selectPartition (Lift (Partitions m)) =
+ go [(loc, part) | (loc, parts) <- sortBy (comparing $ locLength . fst) $ M.toList m, part <- S.toList parts]
+ where
+ locLength :: PartitionLocation -> Int
+ locLength = walk 0
+ where
+ walk !n PHere = n
+ walk !n (PInProperty _ l) = walk (n + 1) l
+ go [] = Nothing
+ -- Skip partitioning by property for now
+ go ((_, DByProperties _) : ps) = go ps
+ -- Don't partition by enum value at the root (this reports removed enum values as contradictions in their respective partitions)
+ go ((PHere, DByEnumValue _) : ps) = go ps
+ go ((loc, DByEnumValue (DNF xss)) : ps)
+ -- Check that no disjunction branches are unresticted
+ | Just enums <- traverse (\(Disjunct xs) -> fmap (foldr1 S.intersection) . NE.nonEmpty . S.toList $ xs) . S.toList $ xss =
+ -- TODO: improve
+ Just (loc, S.map (CByEnumValue . S.singleton) $ S.unions enums)
+ | otherwise = go ps
+
+-- This essentially has 3 cases:
+-- Nothing -- we have produced a bottom schema
+-- Just (False, _) -- there's been no change to the schema
+-- Just (True, x) -- x is a new schema
+type IntersectionM = ReaderT (Traced (Definitions Schema)) (WriterT Any Maybe)
+
+mBottom :: IntersectionM a
+mBottom = lift . lift $ Nothing
+
+catchBottom :: IntersectionM a -> IntersectionM a -> IntersectionM a
+catchBottom act handler = R.liftCatch (W.liftCatch (\a h -> a <|> h ())) act (\_ -> handler)
+
+mChange :: IntersectionM ()
+mChange = tell $ Any True
+
+data IntersectionResult a = Disjoint | Same a | New a
+ deriving stock (Eq, Ord, Show)
+
+runIntersectionM :: Traced (Definitions Schema) -> IntersectionM a -> IntersectionResult a
+runIntersectionM defs act = case runWriterT $ runReaderT act defs of
+ Nothing -> Disjoint
+ Just (x, Any False) -> Same x
+ Just (x, Any True) -> New x
+
+intersectSchema ::
+ PartitionLocation ->
+ PartitionChoice ->
+ Traced Schema ->
+ IntersectionM Schema
+intersectSchema loc part sch = do
+ allOf' <- forM (tracedAllOf sch) $ \rss ->
+ -- Assuming i ranges over a nonempty set (checked in processSchema)
+ -- (⋂_i A[i]) ∩ X = ⋂_i (A[i] ∩ X)
+ -- If any intersections are empty, the result is empty. If any intersections are a change, the result is a change.
+ traverse (intersectRefSchema loc part) rss
+ anyOf' <- forM (tracedAnyOf sch) $ \rss -> do
+ -- (⋃_i A[i]) ∩ X = ⋃_i (A[i] ∩ X)
+ -- Collect only the nonempty A[i] ∩ X, unless there are none, in which case the result is empty.
+ -- If any schema is empty, we remove it from the list which constitutes a change.
+ mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)
+ case catMaybes mSchemas of
+ [] -> mBottom
+ schs -> pure schs
+ oneOf' <- forM (tracedOneOf sch) $ \rss -> do
+ -- Same as anyOf'. By intersecting we're only making them more disjoint if anything.
+ mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)
+ case catMaybes mSchemas of
+ [] -> mBottom
+ schs -> pure schs
+ let sch' = (extract sch) {_schemaAllOf = allOf', _schemaAnyOf = anyOf', _schemaOneOf = oneOf'}
+ -- Now the local changes:
+ case loc of
+ PInProperty k loc' -> case IOHM.lookup k $ tracedProperties sch of
+ Nothing -> error $ "Partitioning via absent property: " <> T.unpack k
+ Just prop -> do
+ prop' <- intersectRefSchema loc' part prop
+ pure $ sch' {_schemaProperties = IOHM.adjust (const prop') k $ _schemaProperties sch'}
+ PHere -> case part of
+ CByEnumValue vals -> do
+ enum' <- case _schemaEnum sch' of
+ Nothing -> do
+ mChange
+ pure $ S.toList vals
+ Just xs -> do
+ when (any (`S.notMember` vals) xs) mChange
+ case filter (`S.member` vals) xs of
+ [] -> mBottom
+ xs' -> pure xs'
+ pure $ sch' {_schemaEnum = Just enum'}
+ CByProperties {} -> error "CByProperties not implemented"
+
+intersectRefSchema ::
+ PartitionLocation ->
+ PartitionChoice ->
+ Traced (Referenced Schema) ->
+ IntersectionM (Referenced Schema)
+intersectRefSchema loc part rs = do
+ defs <- R.ask
+ Inline <$> intersectSchema loc part (dereference defs rs)
+
+intersectCondition :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> Condition t -> DNF (Condition t)
+intersectCondition _defs PHere (CByEnumValue values) cond@(Exactly x) =
+ if untypeValue x `S.member` values then LiteralDNF cond else bottom
+intersectCondition defs (PInProperty k loc) part cond@(Properties props add madd) = case M.lookup k props of
+ Nothing -> LiteralDNF cond -- shouldn't happen
+ Just prop -> case runIntersectionM defs $ intersectRefSchema loc part $ propRefSchema prop of
+ New rs' ->
+ let trs' = traced (ask (propRefSchema prop) >>> step (Partitioned (loc, part))) rs'
+ in LiteralDNF $ Properties (M.insert k prop {propRefSchema = trs'} props) add madd
+ Same _ -> LiteralDNF cond
+ Disjoint -> bottom
+intersectCondition _defs _loc _part cond = LiteralDNF cond
+
+intersectFormula :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> JsonFormula t -> JsonFormula t
+intersectFormula defs loc part = JsonFormula . foldDNF (intersectCondition defs loc part) . getJsonFormula
+
+tryPartition :: ProdCons (Traced (Definitions Schema)) -> ProdCons (JsonFormula t) -> [(Maybe Partition, ProdCons (JsonFormula t))]
+tryPartition defs pc = case selectPartition $ partitionJsonFormulas defs pc of
+ Nothing -> [(Nothing, pc)]
+ Just (loc, parts) -> [(Just (loc, part), intersectFormula <$> defs <*> pure loc <*> pure part <*> pc) | part <- S.toList parts]
+
+showPartition :: Partition -> Inlines
+showPartition = \case
+ (partition, CByEnumValue (S.toList -> [v])) ->
+ renderPartitionLocation partition <> " is " <> showJSONValueInline v
+ (partition, CByEnumValue (S.toList -> vs)) ->
+ renderPartitionLocation partition <> " has values: "
+ <> (fold . L.intersperse ", " . fmap showJSONValueInline $ vs)
+ (partition, CByProperties (S.toList -> incl) (S.toList -> [])) ->
+ renderPartitionLocation partition <> " contains the properties: " <> listCodes incl
+ (partition, CByProperties (S.toList -> []) (S.toList -> excl)) ->
+ renderPartitionLocation partition <> " does not contain the properties: " <> listCodes excl
+ (partition, CByProperties (S.toList -> incl) (S.toList -> excl)) ->
+ renderPartitionLocation partition
+ <> " contains the properties "
+ <> listCodes incl
+ <> " and does not contain the properties "
+ <> listCodes excl
+ where
+ listCodes :: [Text] -> Inlines
+ listCodes = fold . L.intersperse ", " . fmap code
+ renderPartitionLocation :: PartitionLocation -> Inlines
+ renderPartitionLocation p = code $ "$" <> renderPartitionLocation' p
+ where
+ renderPartitionLocation' :: PartitionLocation -> Text
+ renderPartitionLocation' PHere = mempty
+ renderPartitionLocation' (PInProperty prop rest) = "." <> prop <> renderPartitionLocation' rest
diff --git a/src/Data/OpenApi/Compare/Validate/Schema/Process.hs b/src/Data/OpenApi/Compare/Validate/Schema/Process.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Schema/Process.hs
@@ -0,0 +1,373 @@
+module Data.OpenApi.Compare.Validate.Schema.Process
+ ( schemaToFormula,
+ )
+where
+
+import Algebra.Lattice
+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 Data.Functor.Identity
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import qualified Data.Map as M
+import Data.Maybe
+import Data.OpenApi hiding (get)
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Memo
+import Data.OpenApi.Compare.Paths
+import qualified Data.OpenApi.Compare.PathsPrefixTree as P
+import Data.OpenApi.Compare.References
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.Schema.DNF
+import Data.OpenApi.Compare.Validate.Schema.Issues
+import Data.OpenApi.Compare.Validate.Schema.JsonFormula
+import Data.OpenApi.Compare.Validate.Schema.Partition
+import Data.OpenApi.Compare.Validate.Schema.Traced
+import Data.OpenApi.Compare.Validate.Schema.TypedJson
+import Data.Ord
+import qualified Data.Set as S
+
+-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.
+newtype Silent w a = Silent {runSilent :: a}
+ deriving stock (Functor)
+ deriving (Applicative, Monad) via Identity
+
+instance Monoid w => MonadWriter w (Silent w) where
+ tell _ = Silent ()
+ listen (Silent x) = Silent (x, mempty)
+ pass (Silent (x, _)) = Silent x
+
+type ProcessM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))
+
+type SilentM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Silent (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))
+
+-- Either ProcessM or SilentM
+type MonadProcess m =
+ ( MonadReader (Traced (Definitions Schema)) m
+ , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m
+ , MonadState (MemoState ()) m
+ )
+
+warn :: MonadProcess m => Issue 'SchemaLevel -> m ()
+warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue
+
+-- Perform a computation lazily, ignoring the warnings and discarding memoization/loop detection information.
+lazily :: MonadProcess m => SilentM a -> m a
+lazily m = do
+ defs <- R.ask
+ pure $ runSilent $ runReaderT (runMemo () m) defs
+
+warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m
+warnKnot =
+ KnotTier
+ { onKnotFound = warn UnguardedRecursion
+ , onKnotUsed = \_ -> pure bottom
+ , tieKnot = \_ -> pure
+ }
+
+processRefSchema ::
+ MonadProcess m =>
+ Traced (Referenced Schema) ->
+ m (ForeachType JsonFormula)
+processRefSchema x = do
+ defs <- R.ask
+ memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)
+
+-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition
+-- for every possible type of a JSON value. The conditions are independent, and
+-- are thus checked independently.
+processSchema ::
+ MonadProcess m =>
+ Traced Schema ->
+ m (ForeachType JsonFormula)
+processSchema sch@(extract -> Schema {..}) = do
+ let singletonFormula :: Condition t -> JsonFormula t
+ singletonFormula = JsonFormula . LiteralDNF
+
+ allClauses <- case tracedAllOf sch of
+ Nothing -> pure []
+ Just [] -> [] <$ warn (InvalidSchema "no items in allOf")
+ Just xs -> mapM processRefSchema xs
+
+ anyClause <- case tracedAnyOf sch of
+ Nothing -> pure top
+ Just [] -> bottom <$ warn (InvalidSchema "no items in anyOf")
+ Just xs -> joins <$> mapM processRefSchema xs
+
+ oneClause <- case tracedOneOf sch of
+ Nothing -> pure top
+ Just [] -> bottom <$ warn (InvalidSchema "no items in oneOf")
+ Just xs -> do
+ checkOneOfDisjoint xs >>= \case
+ True -> pure ()
+ False -> warn OneOfNotDisjoint
+ joins <$> mapM processRefSchema xs
+
+ case _schemaNot of
+ Nothing -> pure ()
+ Just _ -> warn (NotSupported "not clause is unsupported")
+
+ let typeClause = case _schemaType of
+ Nothing -> top
+ Just OpenApiNull ->
+ bottom
+ { forNull = top
+ }
+ Just OpenApiBoolean ->
+ bottom
+ { forBoolean = top
+ }
+ Just OpenApiNumber ->
+ bottom
+ { forNumber = top
+ }
+ Just OpenApiInteger ->
+ bottom
+ { forNumber = singletonFormula $ MultipleOf 1
+ }
+ Just OpenApiString ->
+ bottom
+ { forString = top
+ }
+ Just OpenApiArray ->
+ bottom
+ { forArray = top
+ }
+ Just OpenApiObject ->
+ bottom
+ { forObject = top
+ }
+
+ let valueEnum A.Null =
+ bottom
+ { forNull = singletonFormula $ Exactly TNull
+ }
+ valueEnum (A.Bool b) =
+ bottom
+ { forBoolean = singletonFormula $ Exactly $ TBool b
+ }
+ valueEnum (A.Number n) =
+ bottom
+ { forNumber = singletonFormula $ Exactly $ TNumber n
+ }
+ valueEnum (A.String s) =
+ bottom
+ { forString = singletonFormula $ Exactly $ TString s
+ }
+ valueEnum (A.Array a) =
+ bottom
+ { forArray = singletonFormula $ Exactly $ TArray a
+ }
+ valueEnum (A.Object o) =
+ bottom
+ { forObject = singletonFormula $ Exactly $ TObject o
+ }
+ enumClause <- case _schemaEnum of
+ Nothing -> pure top
+ Just [] -> bottom <$ warn (InvalidSchema "no items in enum")
+ Just xs -> pure $ joins (valueEnum <$> xs)
+
+ let maximumClause = case _schemaMaximum of
+ Nothing -> top
+ Just n ->
+ top
+ { forNumber = singletonFormula $
+ Maximum $
+ case _schemaExclusiveMaximum of
+ Just True -> Exclusive n
+ _ -> Inclusive n
+ }
+
+ minimumClause = case _schemaMinimum of
+ Nothing -> top
+ Just n ->
+ top
+ { forNumber = singletonFormula $
+ Minimum $
+ Down $
+ case _schemaExclusiveMinimum of
+ Just True -> Exclusive $ Down n
+ _ -> Inclusive $ Down n
+ }
+
+ multipleOfClause = case _schemaMultipleOf of
+ Nothing -> top
+ Just n ->
+ top
+ { forNumber = singletonFormula $ MultipleOf n
+ }
+
+ formatClause <- case _schemaFormat of
+ Nothing -> pure top
+ Just f
+ | f `elem` ["int32", "int64", "float", "double"] ->
+ pure
+ top
+ { forNumber = singletonFormula $ NumberFormat f
+ }
+ Just f
+ | f `elem` ["byte", "binary", "date", "date-time", "password", "uuid"] ->
+ pure
+ top
+ { forString = singletonFormula $ StringFormat f
+ }
+ Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)
+
+ let maxLengthClause = case _schemaMaxLength of
+ Nothing -> top
+ Just n ->
+ top
+ { forString = singletonFormula $ MaxLength n
+ }
+
+ minLengthClause = case _schemaMinLength of
+ Nothing -> top
+ Just n ->
+ top
+ { forString = singletonFormula $ MinLength n
+ }
+
+ patternClause = case _schemaPattern of
+ Nothing -> top
+ Just p ->
+ top
+ { forString = singletonFormula $ Pattern p
+ }
+
+ itemsClause <- case tracedItems sch of
+ Nothing -> pure top
+ Just (Left rs) -> do
+ f <- lazily $ processRefSchema rs
+ pure top {forArray = singletonFormula $ Items f rs}
+ Just (Right rss) -> do
+ fsrs <- forM rss $ \rs -> do
+ f <- lazily $ processRefSchema rs
+ pure (f, rs)
+ pure top {forArray = singletonFormula $ TupleItems fsrs}
+
+ let maxItemsClause = case _schemaMaxItems of
+ Nothing -> top
+ Just n ->
+ top
+ { forArray = singletonFormula $ MaxItems n
+ }
+
+ minItemsClause = case _schemaMinItems of
+ Nothing -> top
+ Just n ->
+ top
+ { forArray = singletonFormula $ MinItems n
+ }
+
+ uniqueItemsClause = case _schemaUniqueItems of
+ Just True ->
+ top
+ { forArray = singletonFormula UniqueItems
+ }
+ _ -> top
+
+ (addProps, addPropSchema) <- case tracedAdditionalProperties sch of
+ Just (Right rs) -> (,Just rs) <$> lazily (processRefSchema rs)
+ Just (Left False) -> pure (bottom, Nothing)
+ _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)
+ propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do
+ (f, psch) <- case IOHM.lookup k $ tracedProperties sch of
+ Just rs -> (,rs) <$> lazily (processRefSchema rs)
+ Nothing ->
+ let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty
+ in -- The mempty here is incorrect, but if addPropSchema was Nothing, then
+ -- addProps is bottom, and k is in _schemaRequired. We handle this situation
+ -- below and short-circuit the entire Properties condition to bottom
+ pure (addProps, fromMaybe fakeSchema addPropSchema)
+ pure (k, Property (k `elem` _schemaRequired) f psch)
+ let allBottom f = getAll $
+ foldType $ \_ ty -> case getJsonFormula $ ty f of
+ BottomDNF -> All True
+ _ -> All False
+ allTop f = getAll $
+ foldType $ \_ ty -> case getJsonFormula $ ty f of
+ TopDNF -> All True
+ _ -> All False
+ -- remove optional fields whose schemata match that of additional props
+ propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList
+ propertiesClause
+ | any (\p -> propRequired p && allBottom (propFormula p)) propMap =
+ bottom -- if any required field has unsatisfiable schema
+ | M.null propMap
+ , allTop addProps =
+ top -- if all fields are optional and have trivial schemata
+ | otherwise =
+ top
+ { forObject = singletonFormula $ Properties propMap addProps addPropSchema
+ }
+
+ maxPropertiesClause = case _schemaMaxProperties of
+ Nothing -> top
+ Just n ->
+ top
+ { forObject = singletonFormula $ MaxProperties n
+ }
+
+ minPropertiesClause = case _schemaMinProperties of
+ Nothing -> top
+ Just n ->
+ top
+ { forObject = singletonFormula $ MinProperties n
+ }
+
+ nullableClause
+ | Just True <- _schemaNullable =
+ bottom
+ { forNull = singletonFormula $ Exactly TNull
+ }
+ | otherwise = bottom
+
+ pure $
+ nullableClause
+ \/ meets
+ ( allClauses
+ <> [ anyClause
+ , oneClause
+ , typeClause
+ , enumClause
+ , maximumClause
+ , minimumClause
+ , multipleOfClause
+ , formatClause
+ , maxLengthClause
+ , minLengthClause
+ , patternClause
+ , itemsClause
+ , maxItemsClause
+ , minItemsClause
+ , uniqueItemsClause
+ , propertiesClause
+ , maxPropertiesClause
+ , minPropertiesClause
+ ]
+ )
+
+{- TODO: ReadOnly/WriteOnly #68 -}
+
+checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool
+checkOneOfDisjoint schs = do
+ defs <- R.ask
+ pure $ case selectPartition $ joins $ runPartitionM defs $ traverse partitionRefSchema schs of
+ Nothing -> False
+ Just (loc, parts) ->
+ let intersects part sch = case runIntersectionM defs $ intersectRefSchema loc part sch of
+ Disjoint -> False
+ _ -> True
+ in all (\part -> 1 >= length (filter (intersects part) schs)) parts
+ where
+
+runProcessM :: Traced (Definitions Schema) -> ProcessM a -> (a, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
+runProcessM defs = runWriter . (`runReaderT` defs) . runMemo ()
+
+schemaToFormula ::
+ Traced (Definitions Schema) ->
+ Traced Schema ->
+ (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)
+schemaToFormula defs rs = runProcessM defs $ processSchema rs
diff --git a/src/Data/OpenApi/Compare/Validate/Schema/Traced.hs b/src/Data/OpenApi/Compare/Validate/Schema/Traced.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Schema/Traced.hs
@@ -0,0 +1,115 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.Schema.Traced
+ ( Step (..),
+ tracedAllOf,
+ tracedAnyOf,
+ tracedOneOf,
+ tracedItems,
+ tracedAdditionalProperties,
+ tracedDiscriminator,
+ tracedProperties,
+ tracedConjunct,
+ PartitionLocation (..),
+ PartitionChoice (..),
+ Partition,
+ )
+where
+
+import qualified Data.Aeson as A
+import Data.Functor
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import qualified Data.List.NonEmpty as NE
+import Data.OpenApi
+import Data.OpenApi.Compare.Subtree
+import qualified Data.Set as S
+import Data.Text (Text)
+
+data PartitionChoice
+ = CByEnumValue (S.Set A.Value)
+ | CByProperties (S.Set Text) (S.Set Text) -- included, excluded
+ deriving stock (Eq, Ord, Show)
+
+data PartitionLocation
+ = PHere
+ | PInProperty Text PartitionLocation
+ deriving stock (Eq, Ord, Show)
+
+type Partition = (PartitionLocation, PartitionChoice)
+
+instance Steppable Schema (Referenced Schema) where
+ data Step Schema (Referenced Schema)
+ = AllOfStep Int
+ | OneOfStep Int
+ | AnyOfStep Int
+ | ItemsObjectStep
+ | ItemsArrayStep Int
+ | AdditionalPropertiesStep
+ | NotStep
+ | ImplicitTopSchema
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable (Referenced Schema) (Referenced Schema) where
+ data Step (Referenced Schema) (Referenced Schema)
+ = -- | Invariant (for better memoization only): the "tail" of the trace is
+ -- the "least" of the traces of the conjuncted schemata
+ ConjunctedWith (NE.NonEmpty (Trace (Referenced Schema)))
+ | Partitioned Partition
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable Schema (Definitions (Referenced Schema)) where
+ data Step Schema (Definitions (Referenced Schema)) = PropertiesStep
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable Schema Discriminator where
+ data Step Schema Discriminator = DiscriminatorStep
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable Discriminator (Definitions (Referenced Schema)) where
+ data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping
+ deriving stock (Eq, Ord, Show)
+
+tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
+tracedAllOf sch =
+ _schemaAllOf (extract sch) <&> \xs ->
+ [traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0 ..] xs]
+
+tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
+tracedAnyOf sch =
+ _schemaAnyOf (extract sch) <&> \xs ->
+ [traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0 ..] xs]
+
+tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]
+tracedOneOf sch =
+ _schemaOneOf (extract sch) <&> \xs ->
+ [traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0 ..] xs]
+
+tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])
+tracedItems sch =
+ _schemaItems (extract sch) <&> \case
+ OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x
+ OpenApiItemsArray xs ->
+ Right
+ [traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0 ..] xs]
+
+tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))
+tracedAdditionalProperties sch =
+ _schemaAdditionalProperties (extract sch) <&> \case
+ AdditionalPropertiesAllowed b -> Left b
+ AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x
+
+tracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)
+tracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator
+
+tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))
+tracedProperties sch =
+ IOHM.mapWithKey
+ (\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))
+ (_schemaProperties $ extract sch)
+
+tracedConjunct :: NE.NonEmpty (Traced (Referenced Schema)) -> Traced (Referenced Schema)
+tracedConjunct refSchemas = case NE.sortWith ask refSchemas of
+ (rs NE.:| []) -> rs
+ (rs1 NE.:| rs2 : rss) ->
+ traced (ask rs1 >>> step (ConjunctedWith $ ask <$> rs2 NE.:| rss)) $
+ Inline mempty {_schemaAllOf = Just $ extract <$> rs1 : rs2 : rss}
diff --git a/src/Data/OpenApi/Compare/Validate/Schema/TypedJson.hs b/src/Data/OpenApi/Compare/Validate/Schema/TypedJson.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Schema/TypedJson.hs
@@ -0,0 +1,120 @@
+module Data.OpenApi.Compare.Validate.Schema.TypedJson
+ ( JsonType (..),
+ describeJSONType,
+ TypedValue (..),
+ untypeValue,
+ ForeachType (..),
+ foldType,
+ forType_,
+ )
+where
+
+import Algebra.Lattice
+import qualified Data.Aeson as A
+import Data.Kind
+import Data.Monoid
+import Data.Scientific
+import Data.String
+import Data.Text (Text)
+import Data.Typeable
+
+-- | Type of a JSON value
+data JsonType
+ = Null
+ | Boolean
+ | Number
+ | String
+ | Array
+ | Object
+ deriving stock (Eq, Ord, Show)
+
+describeJSONType :: IsString s => JsonType -> s
+describeJSONType = \case
+ Null -> "Null"
+ Boolean -> "Boolean"
+ Number -> "Number"
+ String -> "String"
+ Array -> "Array"
+ Object -> "Object"
+
+-- | A 'A.Value' whose type we know
+data TypedValue :: JsonType -> Type where
+ TNull :: TypedValue 'Null
+ TBool :: !Bool -> TypedValue 'Boolean
+ TNumber :: !Scientific -> TypedValue 'Number
+ TString :: !Text -> TypedValue 'String
+ TArray :: !A.Array -> TypedValue 'Array
+ TObject :: !A.Object -> TypedValue 'Object
+
+deriving stock instance Eq (TypedValue t)
+
+deriving stock instance Ord (TypedValue t)
+
+deriving stock instance Show (TypedValue t)
+
+untypeValue :: TypedValue t -> A.Value
+untypeValue TNull = A.Null
+untypeValue (TBool b) = A.Bool b
+untypeValue (TNumber n) = A.Number n
+untypeValue (TString s) = A.String s
+untypeValue (TArray a) = A.Array a
+untypeValue (TObject o) = A.Object o
+
+data ForeachType (f :: JsonType -> Type) = ForeachType
+ { forNull :: f 'Null
+ , forBoolean :: f 'Boolean
+ , forNumber :: f 'Number
+ , forString :: f 'String
+ , forArray :: f 'Array
+ , forObject :: f 'Object
+ }
+
+deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)
+
+deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)
+
+deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)
+
+foldType :: Monoid m => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m) -> m
+foldType k =
+ k Null forNull
+ <> k Boolean forBoolean
+ <> k Number forNumber
+ <> k String forString
+ <> k Array forArray
+ <> k Object forObject
+
+forType_ :: Applicative m => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ()) -> m ()
+forType_ k = getAp $ foldType (\ty proj -> Ap $ k ty proj)
+
+broadcastType :: (forall x. Typeable x => f x) -> ForeachType f
+broadcastType k =
+ ForeachType
+ { forNull = k
+ , forBoolean = k
+ , forNumber = k
+ , forString = k
+ , forArray = k
+ , forObject = k
+ }
+
+zipType :: (forall x. Typeable x => f x -> g x -> h x) -> ForeachType f -> ForeachType g -> ForeachType h
+zipType k f1 f2 =
+ ForeachType
+ { forNull = k (forNull f1) (forNull f2)
+ , forBoolean = k (forBoolean f1) (forBoolean f2)
+ , forNumber = k (forNumber f1) (forNumber f2)
+ , forString = k (forString f1) (forString f2)
+ , forArray = k (forArray f1) (forArray f2)
+ , forObject = k (forObject f1) (forObject f2)
+ }
+
+instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where
+ (\/) = zipType (\/)
+ (/\) = zipType (/\)
+
+instance (forall x. BoundedJoinSemiLattice (f x)) => BoundedJoinSemiLattice (ForeachType f) where
+ bottom = broadcastType bottom
+
+instance (forall x. BoundedMeetSemiLattice (f x)) => BoundedMeetSemiLattice (ForeachType f) where
+ top = broadcastType top
diff --git a/src/Data/OpenApi/Compare/Validate/SecurityRequirement.hs b/src/Data/OpenApi/Compare/Validate/SecurityRequirement.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/SecurityRequirement.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.SecurityRequirement
+ ( Issue (..),
+ )
+where
+
+import Control.Comonad
+import Control.Monad
+import Control.Monad.Writer
+import Data.Bifunctor
+import Data.Either
+import Data.Foldable
+import Data.Functor
+import Data.HList
+import qualified Data.HashMap.Strict.InsOrd as IOHM
+import qualified Data.List.NonEmpty as NE
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.OAuth2Flows
+import Data.OpenApi.Compare.Validate.SecurityScheme ()
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import Data.Traversable
+
+instance Subtree SecurityRequirement where
+ type SubtreeLevel SecurityRequirement = 'SecurityRequirementLevel
+ type
+ CheckEnv SecurityRequirement =
+ '[ ProdCons (Traced (Definitions SecurityScheme))
+ ]
+ checkStructuralCompatibility env pc = do
+ let normalized = do
+ sec <- extract <$> pc
+ defs <- getH env
+ -- lookupScheme
+ pure $
+ for (IOHM.toList $ getSecurityRequirement sec) $ \(key, scopes) ->
+ (,scopes) <$> lookupScheme key defs
+ structuralMaybeWith
+ ( \pc' -> do
+ let ProdCons pScopes cScopes = fmap snd <$> pc'
+ unless (pScopes == cScopes) structuralIssue
+ structuralList env $ fmap fst <$> pc'
+ pure ()
+ )
+ normalized
+ pure ()
+ checkSemanticCompatibility env bhv' pc = do
+ let schemes = getH @(ProdCons (Traced (Definitions SecurityScheme))) env
+ ( ProdCons pErrs cErrs
+ , (ProdCons pSchemes cSchemes) ::
+ ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]
+ ) =
+ NE.unzip $
+ partitionEithers <$> do
+ req <- pc
+ scheme <- schemes
+ pure $
+ let -- [(key, scopes)]
+ pairs = IOHM.toList . getSecurityRequirement . extract $ req
+ in pairs <&> \(key, scopes) -> do
+ case lookupScheme key scheme of
+ Nothing -> Left $ UndefinedSecurityScheme key
+ Just x -> Right (bhv' >>> step (SecuritySchemeStep key), x, scopes)
+ lookSimilar :: SecurityScheme -> SecurityScheme -> Bool
+ lookSimilar x y = case (_securitySchemeType x, _securitySchemeType y) of
+ (SecuritySchemeOAuth2 {}, SecuritySchemeOAuth2 {}) -> True
+ (SecuritySchemeHttp {}, SecuritySchemeHttp {}) -> True
+ (SecuritySchemeApiKey {}, SecuritySchemeApiKey {}) -> True
+ (SecuritySchemeOpenIdConnect {}, SecuritySchemeOpenIdConnect {}) -> True
+ _ -> False
+ issueAt bhv' `traverse_` pErrs
+ issueAt bhv' `traverse_` cErrs
+ for_ pSchemes $ \(bhv, pScheme, pScopes) -> do
+ let lookPromising = filter (lookSimilar (extract pScheme) . extract . (\(_, x, _) -> x)) cSchemes
+ anyOfAt bhv SecuritySchemeNotMatched $
+ lookPromising <&> \(_, cScheme, cScopes) -> do
+ let untracedSchemes = join bimap (_securitySchemeType . extract) (pScheme, cScheme)
+ scopedFlow :: Set Text -> OAuth2Flow t -> Writer [Issue 'SecuritySchemeLevel] (OAuth2Flow t)
+ scopedFlow scopes x = do
+ let scopesMap = _oAuth2Scopes x
+ for_ scopes $ \scope -> unless (scope `IOHM.member` scopesMap) $ tell [ScopeNotDefined scope]
+ pure $ x {_oAuth2Scopes = IOHM.filterWithKey (\k _ -> k `S.member` scopes) scopesMap}
+ scopedSchemeType :: [Text] -> SecuritySchemeType -> Writer [Issue 'SecuritySchemeLevel] SecuritySchemeType
+ scopedSchemeType scopes (SecuritySchemeOAuth2 (OAuth2Flows a b c d)) =
+ fmap SecuritySchemeOAuth2 $ OAuth2Flows <$> flow a <*> flow b <*> flow c <*> flow d
+ where
+ flow :: Maybe (OAuth2Flow t) -> Writer [Issue 'SecuritySchemeLevel] (Maybe (OAuth2Flow t))
+ flow = traverse $ scopedFlow $ S.fromList scopes
+ scopedSchemeType _ x = pure x
+ scopedScheme scopes x = do
+ sType <- scopedSchemeType scopes $ _securitySchemeType x
+ pure $ x {_securitySchemeType = sType}
+ (pc', errs) = runWriter $ ProdCons <$> scopedScheme pScopes `traverse` pScheme <*> scopedScheme cScopes `traverse` cScheme
+ case untracedSchemes of
+ (SecuritySchemeOpenIdConnect _, SecuritySchemeOpenIdConnect _) -> do
+ let missingScopes = S.fromList cScopes S.\\ S.fromList pScopes
+ unless (S.null missingScopes) $ issueAt bhv (ScopesMissing missingScopes)
+ (SecuritySchemeOAuth2 {}, SecuritySchemeOAuth2 {}) -> pure ()
+ _ -> unless (null pScopes && null cScopes) $ issueAt bhv CanNotHaveScopes
+ for_ errs $ issueAt bhv
+ checkCompatibility bhv env pc'
+ pure ()
+ pure ()
+
+lookupScheme :: Text -> Traced (Definitions SecurityScheme) -> Maybe (Traced SecurityScheme)
+lookupScheme k (Traced t m) = Traced (t >>> step (InsOrdHashMapKeyStep k)) <$> IOHM.lookup k m
diff --git a/src/Data/OpenApi/Compare/Validate/SecurityScheme.hs b/src/Data/OpenApi/Compare/Validate/SecurityScheme.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/SecurityScheme.hs
@@ -0,0 +1,43 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.SecurityScheme
+ (
+ )
+where
+
+import Control.Monad
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Orphans ()
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.OAuth2Flows
+
+instance Subtree SecurityScheme where
+ type CheckEnv SecurityScheme = '[]
+ type SubtreeLevel SecurityScheme = 'SecuritySchemeLevel
+ checkStructuralCompatibility _ pc = structuralEq $ tracedSecuritySchemaTypes <$> pc
+ checkSemanticCompatibility env bhv pcSecScheme = case tracedSecuritySchemaTypes <$> pcSecScheme of
+ (ProdCons (Traced _ (SecuritySchemeHttp pType)) (Traced _ (SecuritySchemeHttp cType))) -> case (pType, cType) of
+ (HttpSchemeBearer _, HttpSchemeBearer _) -> pure ()
+ (HttpSchemeBasic, HttpSchemeBasic) -> pure ()
+ (HttpSchemeCustom p, HttpSchemeCustom c) ->
+ unless (p == c) (issueAt bhv $ CustomHttpSchemesDontMatch p c)
+ _ -> issueAt bhv $ HttpSchemeTypesDontMatch pType cType
+ (ProdCons (Traced _ (SecuritySchemeApiKey pParams)) (Traced _ (SecuritySchemeApiKey cParams))) -> do
+ unless (pParams == cParams) (issueAt bhv $ ApiKeyParamsDontMatch pParams cParams)
+ (ProdCons (Traced pT (SecuritySchemeOAuth2 pFlows)) (Traced cT (SecuritySchemeOAuth2 cFlows))) -> do
+ checkCompatibility bhv env . fmap (stepTraced SecurityOAuthFlowsStep) $ ProdCons (Traced pT pFlows) (Traced cT cFlows)
+ (ProdCons (Traced _ (SecuritySchemeOpenIdConnect pUrl)) (Traced _ (SecuritySchemeOpenIdConnect cUrl))) -> do
+ unless (pUrl == cUrl) (issueAt bhv $ OpenIdConnectUrlsDontMatch pUrl cUrl)
+ _ -> issueAt bhv DifferentSecuritySchemes
+
+tracedSecuritySchemaTypes :: Traced SecurityScheme -> Traced SecuritySchemeType
+tracedSecuritySchemaTypes (Traced t x) = Traced (t >>> step SecuritySchemeTypeStep) (_securitySchemeType x)
+
+instance Steppable SecurityScheme SecuritySchemeType where
+ data Step SecurityScheme SecuritySchemeType = SecuritySchemeTypeStep
+ deriving stock (Eq, Ord, Show)
+
+instance Steppable SecuritySchemeType OAuth2Flows where
+ data Step SecuritySchemeType OAuth2Flows = SecurityOAuthFlowsStep
+ deriving stock (Eq, Ord, Show)
diff --git a/src/Data/OpenApi/Compare/Validate/Server.hs b/src/Data/OpenApi/Compare/Validate/Server.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Server.hs
@@ -0,0 +1,171 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.OpenApi.Compare.Validate.Server
+ ( Issue (..),
+ )
+where
+
+import Control.Applicative
+import Control.Arrow ((&&&))
+import Control.Comonad
+import Control.Monad
+import Data.Attoparsec.Text
+import Data.Either
+import Data.Foldable
+import Data.Function
+import Data.Functor
+import Data.HashMap.Strict.InsOrd as IOHM
+import qualified Data.HashSet.InsOrd as IOHM
+import qualified Data.HashSet.InsOrd as IOHS
+import Data.Maybe
+import Data.OpenApi
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Common
+import Data.OpenApi.Compare.Paths
+import Data.OpenApi.Compare.Subtree
+import Data.OpenApi.Compare.Validate.MediaTypeObject
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Traversable
+import Text.Pandoc.Builder
+import Prelude as P
+
+tracedParsedServerUrlParts ::
+ Server ->
+ Either (Issue 'ServerLevel) ProcessedServer
+tracedParsedServerUrlParts s =
+ let parsedUrl = parseServerUrl $ _serverUrl s
+ lookupVar var = case IOHM.lookup var (_serverVariables s) of
+ Nothing -> Left $ ServerVariableNotDefined var
+ Just x -> Right x
+ in (traverse @[] . traverse @ServerUrlPart) lookupVar parsedUrl
+
+instance Behavable 'OperationLevel 'ServerLevel where
+ data Behave 'OperationLevel 'ServerLevel
+ = InServer Text
+ deriving stock (Eq, Ord, Show)
+
+ describeBehavior (InServer n) = "Server " <> code n
+
+instance Subtree [Server] where
+ type SubtreeLevel [Server] = 'OperationLevel
+ type CheckEnv [Server] = '[]
+ checkStructuralCompatibility _ pc =
+ structuralEq $ fmap S.fromList . (fmap . fmap) reduceServer <$> pc
+ where
+ reducerServerVariable =
+ fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault
+ reduceServer =
+ _serverUrl &&& fmap reducerServerVariable . IOHM.toHashMap . _serverVariables
+ checkSemanticCompatibility env beh pcServer = do
+ let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =
+ pcServer
+ <&> partitionEithers
+ . fmap
+ ( \(Traced t s) ->
+ let bhv = beh >>> step (InServer $ _serverUrl s)
+ in case tracedParsedServerUrlParts s of
+ Left e -> Left $ issueAt bhv e
+ Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u)
+ )
+ . sequence
+ sequenceA_ pErrs
+ sequenceA_ cErrs
+ for_ pUrls $ \(bhv, pUrl) -> do
+ let potentiallyCompatible = P.filter ((staticCompatible `on` extract) pUrl) $ fmap snd cUrls
+ anyOfAt
+ bhv
+ ServerNotMatched
+ [ checkCompatibility bhv env (ProdCons pUrl cUrl)
+ | cUrl <- potentiallyCompatible
+ ]
+ pure ()
+
+type ProcessedServer = [ServerUrlPart ServerVariable]
+
+-- | Nothing means "open variable" – can have any value
+unifyPart :: ServerUrlPart ServerVariable -> Maybe (IOHS.InsOrdHashSet Text)
+unifyPart (ServerUrlVariable v) = _serverVariableEnum v
+unifyPart (ServerUrlConstant c) = Just $ IOHS.singleton c
+
+staticCompatiblePart :: ServerUrlPart x -> ServerUrlPart x -> Bool
+staticCompatiblePart (ServerUrlConstant x) (ServerUrlConstant y) = x == y
+staticCompatiblePart _ _ = True
+
+staticCompatible :: [ServerUrlPart x] -> [ServerUrlPart x] -> Bool
+staticCompatible a b = maybe False (all $ uncurry staticCompatiblePart) $ zipAll a b
+
+data ServerUrlPart var
+ = ServerUrlVariable var
+ | ServerUrlConstant Text
+ deriving stock (Eq, Show, Functor, Foldable, Traversable)
+
+-- | This is super rough. Things like @{a|b}c@ will not match @ac@.
+-- FIXME: #46
+--
+-- NOTE: syntax is defined vaguely in the spec.
+parseServerUrl :: Text -> [ServerUrlPart Text]
+-- There really is no way it can fail
+parseServerUrl = fromRight undefined . parseOnly (serverUrlParser <* endOfInput)
+ where
+ serverUrlParser :: Parser [ServerUrlPart Text]
+ serverUrlParser = many $ do
+ variableUrlParser <|> do
+ a <- anyChar
+ aa <- takeTill (== '{')
+ return (ServerUrlConstant $ T.cons a aa)
+
+ variableUrlParser :: Parser (ServerUrlPart Text)
+ variableUrlParser = do
+ char '{'
+ res <- takeTill (== '}')
+ char '}'
+ return $ ServerUrlVariable res
+
+instance Steppable [Server] ProcessedServer where
+ data Step [Server] ProcessedServer = ServerStep Text
+ deriving stock (Eq, Ord, Show)
+
+instance Issuable 'ServerLevel where
+ data Issue 'ServerLevel
+ = EnumValueNotConsumed Int Text
+ | ConsumerNotOpen Int
+ | ServerVariableNotDefined Text
+ | ServerNotMatched
+ deriving stock (Eq, Ord, Show)
+ issueKind = \case
+ ServerVariableNotDefined _ -> SchemaInvalid
+ _ -> CertainIssue
+ describeIssue Forward (EnumValueNotConsumed _ v) =
+ para $ "Enum value " <> code v <> " has been removed."
+ describeIssue Backward (EnumValueNotConsumed _ v) =
+ para $ "Enum value " <> code v <> " has been added."
+ describeIssue Forward (ConsumerNotOpen _) =
+ para $ "A variable has been changed from being open to being closed."
+ describeIssue Backward (ConsumerNotOpen _) =
+ para $ "A variable has been changed from being closed to being open."
+ describeIssue _ (ServerVariableNotDefined k) =
+ para $ "Variable " <> code k <> " is not defined."
+ describeIssue Forward ServerNotMatched = para $ "The server was removed."
+ describeIssue Backward ServerNotMatched = para $ "The server was added."
+
+instance Subtree ProcessedServer where
+ type SubtreeLevel ProcessedServer = 'ServerLevel
+ type CheckEnv ProcessedServer = '[]
+ checkStructuralCompatibility _ pc =
+ structuralEq $ (fmap . fmap . fmap . fmap) reducerServerVariable pc
+ where
+ reducerServerVariable =
+ fmap IOHM.toHashSet . _serverVariableEnum &&& _serverVariableDefault
+ checkSemanticCompatibility _ beh pc =
+ -- traversing here is fine because we have already filtered for length
+ for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of
+ (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt beh $ EnumValueNotConsumed i v)
+ -- Consumer can consume anything
+ (_, Nothing) -> pure ()
+ -- Producer can produce anythings, but consumer has a finite enum ;(
+ (Nothing, Just _) -> issueAt beh (ConsumerNotOpen i)
+ where
+ zipProdCons :: ProdCons [a] -> [(a, a)]
+ zipProdCons (ProdCons x y) = zip x y
diff --git a/src/Data/OpenApi/Compare/Validate/Sums.hs b/src/Data/OpenApi/Compare/Validate/Sums.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenApi/Compare/Validate/Sums.hs
@@ -0,0 +1,25 @@
+module Data.OpenApi.Compare.Validate.Sums
+ ( checkSums,
+ )
+where
+
+import Data.Foldable
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.OpenApi.Compare.Behavior
+import Data.OpenApi.Compare.Paths
+import Data.OpenApi.Compare.Subtree
+
+checkSums ::
+ (Ord k, Issuable l) =>
+ Paths q r l ->
+ (k -> Issue l) ->
+ (k -> ProdCons t -> CompatFormula' q AnIssue r ()) ->
+ ProdCons (Map k t) ->
+ CompatFormula' q AnIssue r ()
+checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->
+ case M.lookup key c of
+ Nothing -> issueAt xs $ noElt key
+ Just consElt ->
+ let sumElts = ProdCons prodElt consElt
+ in check key sumElts
diff --git a/src/Data/OpenUnion/Extra.hs b/src/Data/OpenUnion/Extra.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/OpenUnion/Extra.hs
@@ -0,0 +1,43 @@
+module Data.OpenUnion.Extra
+ ( (@@>),
+ TryLiftUnion (..),
+ pattern SingletonUnion,
+ )
+where
+
+import Control.Applicative
+import Data.Dynamic
+import Data.OpenUnion.Internal
+import Data.Typeable
+import TypeFun.Data.List hiding (Union)
+
+class TryLiftUnion xs where
+ tryLiftUnion :: (Alternative m, Typeable x) => x -> m (Union xs)
+
+instance TryLiftUnion '[] where
+ tryLiftUnion _ = empty
+
+instance
+ (Typeable y, SubList ys (y : ys), TryLiftUnion ys) =>
+ TryLiftUnion (y ': ys)
+ where
+ tryLiftUnion (x :: x) = case eqT @x @y of
+ Nothing -> reUnion <$> tryLiftUnion @ys x
+ Just Refl -> pure $ liftUnion x
+
+-- | Like '@>', but enforces a specific type list order.
+-- (Useful for deconstruction-directed type inference.)
+(@@>) :: Typeable a => (a -> b) -> (Union xs -> b) -> Union (a ': xs) -> b
+r @@> l = either l r . restrict'
+ where
+ restrict' :: Typeable a => Union (a ': aa) -> Either (Union aa) a
+ restrict' (Union d) = maybe (Left $ Union d) Right $ fromDynamic d
+{-# INLINE (@@>) #-}
+
+infixr 2 @@>
+
+pattern SingletonUnion :: (Typeable a, Elem a s) => a -> Union s
+pattern SingletonUnion x <-
+ ((\(Union y) -> fromDynamic y) -> Just x)
+ where
+ SingletonUnion x = liftUnion x
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,12 @@
+module Main (main) where
+
+import qualified Spec.Golden.TraceTree
+import Test.Tasty
+
+main :: IO ()
+main = defaultMain =<< tests
+
+tests :: IO TestTree
+tests = do
+ goldenReportTree <- Spec.Golden.TraceTree.tests
+ return . localOption (mkTimeout 5000000) $ goldenReportTree
diff --git a/test/Spec/Golden/Extra.hs b/test/Spec/Golden/Extra.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec/Golden/Extra.hs
@@ -0,0 +1,93 @@
+module Spec.Golden.Extra
+ ( getGoldenInputs,
+ getGoldenInputsUniform,
+ goldenInputsTree,
+ goldenInputsTreeUniform,
+ )
+where
+
+import Control.Lens
+import Control.Monad
+import qualified Data.ByteString.Lazy as BSL
+import System.Directory
+import System.FilePath
+import Test.Tasty
+import Test.Tasty.Golden
+
+data TestInput t
+ = TestInputNode TestName [TestInput t]
+ | TestInputLeaf TestName t FilePath
+ deriving stock (Functor)
+
+getGoldenInputs ::
+ (Each s t (FilePath, FilePath -> IO a) a) =>
+ TestName ->
+ FilePath ->
+ s ->
+ IO (TestInput t)
+getGoldenInputs name filepath inp = do
+ dirs' <- listDirectory filepath >>= filterM (doesDirectoryExist . (filepath ))
+ case dirs' of
+ -- A test
+ [] -> do
+ x <-
+ inp & each %%~ \(file, f) ->
+ f $ filepath file
+ return $ TestInputLeaf name x filepath
+ -- A test group
+ dirs ->
+ TestInputNode name
+ <$> forM dirs (\dir -> getGoldenInputs dir (filepath dir) inp)
+
+getGoldenInputsUniform ::
+ (Each t h (FilePath, FilePath -> IO a) a) =>
+ (Each s t FilePath (FilePath, FilePath -> IO a)) =>
+ TestName ->
+ (FilePath -> IO a) ->
+ FilePath ->
+ s ->
+ IO (TestInput h)
+getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)
+
+goldenInputsTree ::
+ (Each s t (FilePath, FilePath -> IO a) a) =>
+ TestName ->
+ -- | Root path
+ FilePath ->
+ -- | Name of golden file
+ FilePath ->
+ s ->
+ (t -> IO BSL.ByteString) ->
+ IO TestTree
+goldenInputsTree name filepath golden inp f = do
+ runTestInputTree golden f <$> getGoldenInputs name filepath inp
+
+runTestInputTree ::
+ 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) =
+ goldenVsStringDiff
+ name
+ (\ref new -> ["diff", "-u", ref, new])
+ (path golden)
+ (f t)
+
+goldenInputsTreeUniform ::
+ ( Each t h (FilePath, FilePath -> IO a) a
+ , Each s t FilePath (FilePath, FilePath -> IO a)
+ ) =>
+ String ->
+ -- | Root path
+ FilePath ->
+ -- | Name of golden file
+ FilePath ->
+ s ->
+ (FilePath -> IO a) ->
+ (h -> IO BSL.ByteString) ->
+ IO TestTree
+goldenInputsTreeUniform name filepath golden inp h =
+ goldenInputsTree name filepath golden (inp & each %~ (,h))
diff --git a/test/Spec/Golden/TraceTree.hs b/test/Spec/Golden/TraceTree.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec/Golden/TraceTree.hs
@@ -0,0 +1,46 @@
+module Spec.Golden.TraceTree
+ ( tests,
+ )
+where
+
+import Control.Category
+import Control.Exception
+import qualified Data.ByteString.Lazy as BSL
+import Data.Default
+import Data.OpenApi.Compare.Run
+import Data.OpenApi.Compare.Validate.OpenApi ()
+import Data.Text (Text)
+import qualified Data.Text.Encoding as T
+import qualified Data.Yaml as Yaml
+import Spec.Golden.Extra
+import Test.Tasty (TestTree, testGroup)
+import Text.Pandoc.Builder
+import Text.Pandoc.Class
+import Text.Pandoc.Options
+import Text.Pandoc.Writers
+import Prelude hiding (id, (.))
+
+tests :: IO TestTree
+tests = do
+ traceTreeTests <-
+ goldenInputsTreeUniform
+ "TraceTree"
+ "test/golden"
+ "trace-tree.yaml"
+ ("a.yaml", "b.yaml")
+ Yaml.decodeFileThrow
+ (pure . BSL.fromStrict . Yaml.encode . runChecker)
+
+ reportTests <-
+ goldenInputsTreeUniform
+ "Report"
+ "test/golden"
+ "report.md"
+ ("a.yaml", "b.yaml")
+ Yaml.decodeFileThrow
+ (runPandoc . writeMarkdown def {writerExtensions = githubMarkdownExtensions} . doc . fst . runReport def)
+
+ return $ testGroup "Golden tests" [traceTreeTests, reportTests]
+
+runPandoc :: PandocPure Text -> IO BSL.ByteString
+runPandoc = either throwIO (pure . BSL.fromStrict . T.encodeUtf8) . runPure
diff --git a/test/golden/common/bad-oneof-unchanged/a.yaml b/test/golden/common/bad-oneof-unchanged/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/bad-oneof-unchanged/a.yaml
@@ -0,0 +1,39 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ oneOf:
+ - type: object
+ required: ["tag", "prop_A"]
+ properties:
+ tag:
+ enum: ["A"]
+ prop_A:
+ type: string
+ - type: object
+ required: ["tag", "prop_B"]
+ properties:
+ tag:
+ enum: ["A"]
+ prop_B:
+ type: number
diff --git a/test/golden/common/bad-oneof-unchanged/b.yaml b/test/golden/common/bad-oneof-unchanged/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/bad-oneof-unchanged/b.yaml
@@ -0,0 +1,39 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ oneOf:
+ - type: object
+ required: ["tag", "prop_B"]
+ properties:
+ tag:
+ enum: ["A"]
+ prop_B:
+ type: number
+ - type: object
+ required: ["tag", "prop_A"]
+ properties:
+ tag:
+ enum: ["A"]
+ prop_A:
+ type: string
diff --git a/test/golden/common/bad-oneof-unchanged/report.md b/test/golden/common/bad-oneof-unchanged/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/bad-oneof-unchanged/report.md
@@ -0,0 +1,19 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |
+|---------------------|-------------------------|--------------------------------------------------------|
+| 0 | 0 | 2 |
+
+# ❓ Unsupported feature changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+Could not deduce that `oneOf` cases don't overlap. Treating the `oneOf`
+as an `anyOf`. Reported errors might not be accurate.
+
+### ⬅️☁️ JSON Response – 200
+
+Could not deduce that `oneOf` cases don't overlap. Treating the `oneOf`
+as an `anyOf`. Reported errors might not be accurate.
diff --git a/test/golden/common/bad-oneof-unchanged/trace-tree.yaml b/test/golden/common/bad-oneof-unchanged/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/bad-oneof-unchanged/trace-tree.yaml
@@ -0,0 +1,18 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema: OneOfNotDisjoint
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema: OneOfNotDisjoint
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema: OneOfNotDisjoint
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema: OneOfNotDisjoint
diff --git a/test/golden/common/enum-added/a.yaml b/test/golden/common/enum-added/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/enum-added/a.yaml
@@ -0,0 +1,25 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ enum: ["A", "B"]
diff --git a/test/golden/common/enum-added/b.yaml b/test/golden/common/enum-added/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/enum-added/b.yaml
@@ -0,0 +1,25 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ enum: ["A", "B", "C"]
diff --git a/test/golden/common/enum-added/report.md b/test/golden/common/enum-added/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/enum-added/report.md
@@ -0,0 +1,33 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 1 | 1 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(String)`
+
+The following enum value was added:
+
+``` json
+"C"
+```
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$(String)`
+
+The following enum value was added:
+
+``` json
+"C"
+```
diff --git a/test/golden/common/enum-added/trace-tree.yaml b/test/golden/common/enum-added/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/enum-added/trace-tree.yaml
@@ -0,0 +1,14 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType String: EnumDoesntSatisfy (String "C")
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType String: EnumDoesntSatisfy (String "C")
diff --git a/test/golden/common/enum-anyof/a.yaml b/test/golden/common/enum-anyof/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/enum-anyof/a.yaml
@@ -0,0 +1,29 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ anyOf:
+ - enum:
+ - "foo"
+ - enum:
+ - "bar"
diff --git a/test/golden/common/enum-anyof/b.yaml b/test/golden/common/enum-anyof/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/enum-anyof/b.yaml
@@ -0,0 +1,27 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ enum:
+ - "foo"
+ - "bar"
diff --git a/test/golden/common/enum-anyof/report.md b/test/golden/common/enum-anyof/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/enum-anyof/report.md
@@ -0,0 +1,5 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes |
+|---------------------|-------------------------|
+| 0 | 0 |
diff --git a/test/golden/common/enum-anyof/trace-tree.yaml b/test/golden/common/enum-anyof/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/enum-anyof/trace-tree.yaml
@@ -0,0 +1,2 @@
+forwardChanges: {}
+backwardChanges: {}
diff --git a/test/golden/common/id/a.yaml b/test/golden/common/id/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/id/a.yaml
@@ -0,0 +1,111 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /pets:
+ get:
+ summary: List all pets
+ operationId: listPets
+ tags:
+ - pets
+ parameters:
+ - name: limit
+ in: query
+ description: How many items to return at one time (max 100)
+ required: false
+ schema:
+ type: integer
+ format: int32
+ responses:
+ '200':
+ description: A paged array of pets
+ headers:
+ x-next:
+ description: A link to the next page of responses
+ schema:
+ type: string
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pets"
+ default:
+ description: unexpected error
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Error"
+ post:
+ summary: Create a pet
+ operationId: createPets
+ tags:
+ - pets
+ responses:
+ '201':
+ description: Null response
+ default:
+ description: unexpected error
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Error"
+ /pets/{petId}:
+ get:
+ summary: Info for a specific pet
+ operationId: showPetById
+ tags:
+ - pets
+ parameters:
+ - name: petId
+ in: path
+ required: true
+ description: The id of the pet to retrieve
+ schema:
+ type: string
+ responses:
+ '200':
+ description: Expected response to a valid request
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pet"
+ default:
+ description: unexpected error
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Error"
+components:
+ schemas:
+ Pet:
+ type: object
+ required:
+ - id
+ - name
+ properties:
+ id:
+ type: integer
+ format: int64
+ name:
+ type: string
+ tag:
+ type: string
+ Pets:
+ type: array
+ items:
+ $ref: "#/components/schemas/Pet"
+ Error:
+ type: object
+ required:
+ - code
+ - message
+ properties:
+ code:
+ type: integer
+ format: int32
+ message:
+ type: string
diff --git a/test/golden/common/id/b.yaml b/test/golden/common/id/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/id/b.yaml
@@ -0,0 +1,111 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /pets:
+ get:
+ summary: List all pets
+ operationId: listPets
+ tags:
+ - pets
+ parameters:
+ - name: limit
+ in: query
+ description: How many items to return at one time (max 100)
+ required: false
+ schema:
+ type: integer
+ format: int32
+ responses:
+ '200':
+ description: A paged array of pets
+ headers:
+ x-next:
+ description: A link to the next page of responses
+ schema:
+ type: string
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pets"
+ default:
+ description: unexpected error
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Error"
+ post:
+ summary: Create a pet
+ operationId: createPets
+ tags:
+ - pets
+ responses:
+ '201':
+ description: Null response
+ default:
+ description: unexpected error
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Error"
+ /pets/{petId}:
+ get:
+ summary: Info for a specific pet
+ operationId: showPetById
+ tags:
+ - pets
+ parameters:
+ - name: petId
+ in: path
+ required: true
+ description: The id of the pet to retrieve
+ schema:
+ type: string
+ responses:
+ '200':
+ description: Expected response to a valid request
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pet"
+ default:
+ description: unexpected error
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Error"
+components:
+ schemas:
+ Pet:
+ type: object
+ required:
+ - id
+ - name
+ properties:
+ id:
+ type: integer
+ format: int64
+ name:
+ type: string
+ tag:
+ type: string
+ Pets:
+ type: array
+ items:
+ $ref: "#/components/schemas/Pet"
+ Error:
+ type: object
+ required:
+ - code
+ - message
+ properties:
+ code:
+ type: integer
+ format: int32
+ message:
+ type: string
diff --git a/test/golden/common/id/report.md b/test/golden/common/id/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/id/report.md
@@ -0,0 +1,5 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes |
+|---------------------|-------------------------|
+| 0 | 0 |
diff --git a/test/golden/common/id/trace-tree.yaml b/test/golden/common/id/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/id/trace-tree.yaml
@@ -0,0 +1,2 @@
+forwardChanges: {}
+backwardChanges: {}
diff --git a/test/golden/common/json/recursive/a.yaml b/test/golden/common/json/recursive/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/json/recursive/a.yaml
@@ -0,0 +1,44 @@
+openapi: 3.0.0
+info:
+ title: ""
+ version: ""
+servers:
+- url: /
+paths:
+ /api/foo:
+ get:
+ responses:
+ 200:
+ description: ""
+ content:
+ application/json;charset=utf-8:
+ schema:
+ $ref: '#/components/schemas/Tree'
+components:
+ schemas:
+ Tree:
+ type: object
+ properties:
+ node:
+ required:
+ - children
+ type: object
+ properties:
+ children:
+ type: array
+ items:
+ $ref: '#/components/schemas/Tree'
+ leaf:
+ required:
+ - value
+ type: object
+ properties:
+ value:
+ $ref: '#/components/schemas/Item'
+ Item:
+ required:
+ - foo
+ type: object
+ properties:
+ foo:
+ type: string
diff --git a/test/golden/common/json/recursive/b.yaml b/test/golden/common/json/recursive/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/json/recursive/b.yaml
@@ -0,0 +1,44 @@
+openapi: 3.0.0
+info:
+ title: ""
+ version: ""
+servers:
+- url: /
+paths:
+ /api/foo:
+ get:
+ responses:
+ 200:
+ description: ""
+ content:
+ application/json;charset=utf-8:
+ schema:
+ $ref: '#/components/schemas/Tree'
+components:
+ schemas:
+ Tree:
+ type: object
+ properties:
+ node:
+ required:
+ - children
+ type: object
+ properties:
+ children:
+ type: array
+ items:
+ $ref: '#/components/schemas/Tree'
+ leaf:
+ required:
+ - value
+ type: object
+ properties:
+ value:
+ $ref: '#/components/schemas/Item'
+ Item:
+ required:
+ - foo
+ type: object
+ properties:
+ foo:
+ type: string
diff --git a/test/golden/common/json/recursive/report.md b/test/golden/common/json/recursive/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/json/recursive/report.md
@@ -0,0 +1,5 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes |
+|---------------------|-------------------------|
+| 0 | 0 |
diff --git a/test/golden/common/json/recursive/trace-tree.yaml b/test/golden/common/json/recursive/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/json/recursive/trace-tree.yaml
@@ -0,0 +1,2 @@
+forwardChanges: {}
+backwardChanges: {}
diff --git a/test/golden/common/maximum-lowered/a.yaml b/test/golden/common/maximum-lowered/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/maximum-lowered/a.yaml
@@ -0,0 +1,25 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ maximum: 3
diff --git a/test/golden/common/maximum-lowered/b.yaml b/test/golden/common/maximum-lowered/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/maximum-lowered/b.yaml
@@ -0,0 +1,25 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ maximum: 2
diff --git a/test/golden/common/maximum-lowered/report.md b/test/golden/common/maximum-lowered/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/maximum-lowered/report.md
@@ -0,0 +1,25 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 1 | 1 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$(Number)`
+
+Upper bound changed from 3.0 inclusive to 2.0 inclusive.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Number)`
+
+Upper bound changed from 3.0 inclusive to 2.0 inclusive.
diff --git a/test/golden/common/maximum-lowered/trace-tree.yaml b/test/golden/common/maximum-lowered/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/maximum-lowered/trace-tree.yaml
@@ -0,0 +1,16 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Number: MatchingMaximumWeak (ProdCons {producer = Inclusive 3.0,
+ consumer = Inclusive 2.0})
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Number: MatchingMaximumWeak (ProdCons {producer = Inclusive 3.0,
+ consumer = Inclusive 2.0})
diff --git a/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/a.yaml b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/a.yaml
@@ -0,0 +1,19 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ allowEmptyValue: true
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/b.yaml b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/b.yaml
@@ -0,0 +1,19 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ allowEmptyValue: false
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/report.md b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |
+|------------------------------------------|-------------------------|
+| 1 | 0 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### Parameter test1
+
+The parameter can no longer be empty.
diff --git a/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/trace-tree.yaml b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InParam "test1": ParamEmptinessIncompatible
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/a.yaml b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/a.yaml
@@ -0,0 +1,19 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ allowEmptyValue: false
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/b.yaml b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/b.yaml
@@ -0,0 +1,19 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ allowEmptyValue: true
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/report.md b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|---------------------|--------------------------------------------------|
+| 0 | 1 |
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### Parameter test1
+
+The parameter can now be empty.
diff --git a/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/trace-tree.yaml b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges: {}
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InParam "test1": ParamEmptinessIncompatible
diff --git a/test/golden/common/pathItem/operation/parameters/change/a.yaml b/test/golden/common/pathItem/operation/parameters/change/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/change/a.yaml
@@ -0,0 +1,20 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test
+ in: query
+ schema:
+ type: "string"
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/change/b.yaml b/test/golden/common/pathItem/operation/parameters/change/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/change/b.yaml
@@ -0,0 +1,20 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test
+ in: query
+ schema:
+ type: "number"
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/change/report.md b/test/golden/common/pathItem/operation/parameters/change/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/change/report.md
@@ -0,0 +1,29 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 1 | 1 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### Parameter test
+
+#### JSON Schema
+
+##### `$(String)`
+
+The type has been removed.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### Parameter test
+
+#### JSON Schema
+
+##### `$(Number)`
+
+The type has been added.
diff --git a/test/golden/common/pathItem/operation/parameters/change/trace-tree.yaml b/test/golden/common/pathItem/operation/parameters/change/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/change/trace-tree.yaml
@@ -0,0 +1,12 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InParam "test":
+ InParamSchema:
+ OfType String: TypeBecomesEmpty
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InParam "test":
+ InParamSchema:
+ OfType Number: TypeBecomesEmpty
diff --git a/test/golden/common/pathItem/operation/parameters/required/false/add/a.yaml b/test/golden/common/pathItem/operation/parameters/required/false/add/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/false/add/a.yaml
@@ -0,0 +1,18 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/false/add/b.yaml b/test/golden/common/pathItem/operation/parameters/required/false/add/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/false/add/b.yaml
@@ -0,0 +1,20 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ - name: test2
+ in: query
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/false/add/report.md b/test/golden/common/pathItem/operation/parameters/required/false/add/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/false/add/report.md
@@ -0,0 +1,5 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes |
+|---------------------|-------------------------|
+| 0 | 0 |
diff --git a/test/golden/common/pathItem/operation/parameters/required/false/add/trace-tree.yaml b/test/golden/common/pathItem/operation/parameters/required/false/add/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/false/add/trace-tree.yaml
@@ -0,0 +1,2 @@
+forwardChanges: {}
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/false/del/a.yaml b/test/golden/common/pathItem/operation/parameters/required/false/del/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/false/del/a.yaml
@@ -0,0 +1,20 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ - name: test2
+ in: query
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/false/del/b.yaml b/test/golden/common/pathItem/operation/parameters/required/false/del/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/false/del/b.yaml
@@ -0,0 +1,18 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/false/del/report.md b/test/golden/common/pathItem/operation/parameters/required/false/del/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/false/del/report.md
@@ -0,0 +1,5 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes |
+|---------------------|-------------------------|
+| 0 | 0 |
diff --git a/test/golden/common/pathItem/operation/parameters/required/false/del/trace-tree.yaml b/test/golden/common/pathItem/operation/parameters/required/false/del/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/false/del/trace-tree.yaml
@@ -0,0 +1,2 @@
+forwardChanges: {}
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/reset/a.yaml b/test/golden/common/pathItem/operation/parameters/required/reset/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/reset/a.yaml
@@ -0,0 +1,19 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ required: true
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/reset/b.yaml b/test/golden/common/pathItem/operation/parameters/required/reset/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/reset/b.yaml
@@ -0,0 +1,19 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ required: false
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/reset/report.md b/test/golden/common/pathItem/operation/parameters/required/reset/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/reset/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|---------------------|--------------------------------------------------|
+| 0 | 1 |
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### Parameter test1
+
+Parameter is no longer required.
diff --git a/test/golden/common/pathItem/operation/parameters/required/reset/trace-tree.yaml b/test/golden/common/pathItem/operation/parameters/required/reset/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/reset/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges: {}
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InParam "test1": ParamRequired
diff --git a/test/golden/common/pathItem/operation/parameters/required/set/a.yaml b/test/golden/common/pathItem/operation/parameters/required/set/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/set/a.yaml
@@ -0,0 +1,19 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ required: false
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/set/b.yaml b/test/golden/common/pathItem/operation/parameters/required/set/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/set/b.yaml
@@ -0,0 +1,19 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ required: true
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/set/report.md b/test/golden/common/pathItem/operation/parameters/required/set/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/set/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |
+|------------------------------------------|-------------------------|
+| 1 | 0 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### Parameter test1
+
+Parameter has become required.
diff --git a/test/golden/common/pathItem/operation/parameters/required/set/trace-tree.yaml b/test/golden/common/pathItem/operation/parameters/required/set/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/set/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InParam "test1": ParamRequired
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/true/add/a.yaml b/test/golden/common/pathItem/operation/parameters/required/true/add/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/true/add/a.yaml
@@ -0,0 +1,18 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/true/add/b.yaml b/test/golden/common/pathItem/operation/parameters/required/true/add/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/true/add/b.yaml
@@ -0,0 +1,21 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ - name: test2
+ in: query
+ required: true
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/true/add/report.md b/test/golden/common/pathItem/operation/parameters/required/true/add/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/true/add/report.md
@@ -0,0 +1,11 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |
+|------------------------------------------|-------------------------|
+| 1 | 0 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+Parameter `test2` has become required.
diff --git a/test/golden/common/pathItem/operation/parameters/required/true/add/trace-tree.yaml b/test/golden/common/pathItem/operation/parameters/required/true/add/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/true/add/trace-tree.yaml
@@ -0,0 +1,4 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod: ParamNotMatched "test2"
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/true/del/a.yaml b/test/golden/common/pathItem/operation/parameters/required/true/del/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/true/del/a.yaml
@@ -0,0 +1,21 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ - name: test2
+ in: query
+ required: true
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/true/del/b.yaml b/test/golden/common/pathItem/operation/parameters/required/true/del/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/true/del/b.yaml
@@ -0,0 +1,18 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ parameters:
+ - name: test1
+ in: query
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/parameters/required/true/del/report.md b/test/golden/common/pathItem/operation/parameters/required/true/del/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/true/del/report.md
@@ -0,0 +1,11 @@
+# Summary
+
+| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|---------------------|--------------------------------------------------|
+| 0 | 1 |
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+Parameter `test2` is no longer required.
diff --git a/test/golden/common/pathItem/operation/parameters/required/true/del/trace-tree.yaml b/test/golden/common/pathItem/operation/parameters/required/true/del/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/parameters/required/true/del/trace-tree.yaml
@@ -0,0 +1,4 @@
+forwardChanges: {}
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod: ParamNotMatched "test2"
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/a.yaml b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/a.yaml
@@ -0,0 +1,20 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/b.yaml b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/b.yaml
@@ -0,0 +1,23 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ "application/x-www-form-urlencoded":
+ schema:
+ type: "string"
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/report.md b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|---------------------|--------------------------------------------------|
+| 0 | 1 |
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### Request
+
+Media type `application/x-www-form-urlencoded` has been added.
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/trace-tree.yaml b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges: {}
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest: RequestMediaTypeNotFound application/x-www-form-urlencoded
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/a.yaml b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/a.yaml
@@ -0,0 +1,20 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/b.yaml b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/b.yaml
@@ -0,0 +1,20 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "number"
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md
@@ -0,0 +1,25 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 1 | 1 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$(String)`
+
+The type has been removed.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$(Number)`
+
+The type has been added.
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/trace-tree.yaml b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/trace-tree.yaml
@@ -0,0 +1,14 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType String: TypeBecomesEmpty
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Number: TypeBecomesEmpty
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/a.yaml b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/a.yaml
@@ -0,0 +1,23 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ "application/x-www-form-urlencoded":
+ schema:
+ type: "string"
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/b.yaml b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/b.yaml
@@ -0,0 +1,20 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/report.md b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |
+|------------------------------------------|-------------------------|
+| 1 | 0 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### Request
+
+Media type `application/x-www-form-urlencoded` has been removed.
diff --git a/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/trace-tree.yaml b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest: RequestMediaTypeNotFound application/x-www-form-urlencoded
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/required/reset/a.yaml b/test/golden/common/pathItem/operation/requestBody/required/reset/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/required/reset/a.yaml
@@ -0,0 +1,21 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: true
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/required/reset/b.yaml b/test/golden/common/pathItem/operation/requestBody/required/reset/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/required/reset/b.yaml
@@ -0,0 +1,21 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/required/reset/report.md b/test/golden/common/pathItem/operation/requestBody/required/reset/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/required/reset/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|---------------------|--------------------------------------------------|
+| 0 | 1 |
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### Request
+
+Request body is no longer required.
diff --git a/test/golden/common/pathItem/operation/requestBody/required/reset/trace-tree.yaml b/test/golden/common/pathItem/operation/requestBody/required/reset/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/required/reset/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges: {}
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest: RequestBodyRequired
diff --git a/test/golden/common/pathItem/operation/requestBody/required/set/a.yaml b/test/golden/common/pathItem/operation/requestBody/required/set/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/required/set/a.yaml
@@ -0,0 +1,21 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/required/set/b.yaml b/test/golden/common/pathItem/operation/requestBody/required/set/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/required/set/b.yaml
@@ -0,0 +1,21 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: true
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/requestBody/required/set/report.md b/test/golden/common/pathItem/operation/requestBody/required/set/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/required/set/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |
+|------------------------------------------|-------------------------|
+| 1 | 0 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### Request
+
+Request body has become required.
diff --git a/test/golden/common/pathItem/operation/requestBody/required/set/trace-tree.yaml b/test/golden/common/pathItem/operation/requestBody/required/set/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/requestBody/required/set/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest: RequestBodyRequired
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/responses/add/a.yaml b/test/golden/common/pathItem/operation/responses/add/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/add/a.yaml
@@ -0,0 +1,21 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/add/b.yaml b/test/golden/common/pathItem/operation/responses/add/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/add/b.yaml
@@ -0,0 +1,23 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ "500":
+ description: "Added"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/add/report.md b/test/golden/common/pathItem/operation/responses/add/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/add/report.md
@@ -0,0 +1,11 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |
+|------------------------------------------|-------------------------|
+| 1 | 0 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+Response code 500 has been added.
diff --git a/test/golden/common/pathItem/operation/responses/add/trace-tree.yaml b/test/golden/common/pathItem/operation/responses/add/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/add/trace-tree.yaml
@@ -0,0 +1,4 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod: ConsumerDoesntHaveResponseCode 500
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/a.yaml b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/a.yaml
@@ -0,0 +1,25 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ headers:
+ "Test":
+ description: "Test header"
+ required: true
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/b.yaml b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/b.yaml
@@ -0,0 +1,28 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ headers:
+ "Test":
+ description: "Test header"
+ required: true
+ "Test2":
+ description: "Test2 header"
+ required: true
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/report.md b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|---------------------|--------------------------------------------------|
+| 0 | 1 |
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### Response code 200
+
+New header was added `Test2`.
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/trace-tree.yaml b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges: {}
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200: ProducerDoesntHaveResponseHeader "Test2"
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/a.yaml b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/a.yaml
@@ -0,0 +1,28 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ headers:
+ "Test":
+ description: "Test header"
+ required: true
+ "Test2":
+ description: "Test2 header"
+ required: true
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/b.yaml b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/b.yaml
@@ -0,0 +1,25 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ headers:
+ "Test":
+ description: "Test header"
+ required: true
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/report.md b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |
+|------------------------------------------|-------------------------|
+| 1 | 0 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### Response code 200
+
+Header was removed `Test2`.
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/trace-tree.yaml b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200: ProducerDoesntHaveResponseHeader "Test2"
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/optional/add/a.yaml b/test/golden/common/pathItem/operation/responses/change/headers/optional/add/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/optional/add/a.yaml
@@ -0,0 +1,24 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ headers:
+ "Test":
+ description: "Test header"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/optional/add/b.yaml b/test/golden/common/pathItem/operation/responses/change/headers/optional/add/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/optional/add/b.yaml
@@ -0,0 +1,26 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ headers:
+ "Test":
+ description: "Test header"
+ "Test2":
+ description: "Test2 header"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/optional/add/report.md b/test/golden/common/pathItem/operation/responses/change/headers/optional/add/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/optional/add/report.md
@@ -0,0 +1,5 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes |
+|---------------------|-------------------------|
+| 0 | 0 |
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/optional/add/trace-tree.yaml b/test/golden/common/pathItem/operation/responses/change/headers/optional/add/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/optional/add/trace-tree.yaml
@@ -0,0 +1,2 @@
+forwardChanges: {}
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/optional/del/a.yaml b/test/golden/common/pathItem/operation/responses/change/headers/optional/del/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/optional/del/a.yaml
@@ -0,0 +1,26 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ headers:
+ "Test":
+ description: "Test header"
+ "Test2":
+ description: "Test2 header"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/optional/del/b.yaml b/test/golden/common/pathItem/operation/responses/change/headers/optional/del/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/optional/del/b.yaml
@@ -0,0 +1,24 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ headers:
+ "Test":
+ description: "Test header"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/optional/del/report.md b/test/golden/common/pathItem/operation/responses/change/headers/optional/del/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/optional/del/report.md
@@ -0,0 +1,5 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes |
+|---------------------|-------------------------|
+| 0 | 0 |
diff --git a/test/golden/common/pathItem/operation/responses/change/headers/optional/del/trace-tree.yaml b/test/golden/common/pathItem/operation/responses/change/headers/optional/del/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/headers/optional/del/trace-tree.yaml
@@ -0,0 +1,2 @@
+forwardChanges: {}
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/a.yaml b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/a.yaml
@@ -0,0 +1,25 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ content:
+ "application/json":
+ schema:
+ type: "string"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/b.yaml b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/b.yaml
@@ -0,0 +1,28 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ content:
+ "application/json":
+ schema:
+ type: "string"
+ "application/x-www-form-urlencoded":
+ schema:
+ type: "string"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/report.md b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |
+|------------------------------------------|-------------------------|
+| 1 | 0 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### Response code 200
+
+Media type was added: `application/x-www-form-urlencoded`.
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/trace-tree.yaml b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200: ConsumerDoesntHaveMediaType application/x-www-form-urlencoded
+backwardChanges: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/a.yaml b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/a.yaml
@@ -0,0 +1,25 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ content:
+ "application/json":
+ schema:
+ type: "string"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/b.yaml b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/b.yaml
@@ -0,0 +1,25 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ content:
+ "application/json":
+ schema:
+ type: "number"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md
@@ -0,0 +1,25 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 1 | 1 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Number)`
+
+The type has been added.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(String)`
+
+The type has been removed.
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/trace-tree.yaml b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/trace-tree.yaml
@@ -0,0 +1,14 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Number: TypeBecomesEmpty
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType String: TypeBecomesEmpty
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/a.yaml b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/a.yaml
@@ -0,0 +1,28 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ content:
+ "application/json":
+ schema:
+ type: "string"
+ "application/x-www-form-urlencoded":
+ schema:
+ type: "string"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/b.yaml b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/b.yaml
@@ -0,0 +1,25 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ content:
+ "application/json":
+ schema:
+ type: "string"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/report.md b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|---------------------|--------------------------------------------------|
+| 0 | 1 |
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### Response code 200
+
+Media type was removed: `application/x-www-form-urlencoded`.
diff --git a/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/trace-tree.yaml b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/trace-tree.yaml
@@ -0,0 +1,5 @@
+forwardChanges: {}
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200: ConsumerDoesntHaveMediaType application/x-www-form-urlencoded
diff --git a/test/golden/common/pathItem/operation/responses/del/a.yaml b/test/golden/common/pathItem/operation/responses/del/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/del/a.yaml
@@ -0,0 +1,23 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+ "500":
+ description: "Added"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/del/b.yaml b/test/golden/common/pathItem/operation/responses/del/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/del/b.yaml
@@ -0,0 +1,21 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: http://petstore.swagger.io/v1
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ "application/json" :
+ schema:
+ type: "string"
+ required: false
+ responses:
+ "200":
+ description: "Test"
+components: {}
diff --git a/test/golden/common/pathItem/operation/responses/del/report.md b/test/golden/common/pathItem/operation/responses/del/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/del/report.md
@@ -0,0 +1,11 @@
+# Summary
+
+| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|---------------------|--------------------------------------------------|
+| 0 | 1 |
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+Response code 500 has been removed.
diff --git a/test/golden/common/pathItem/operation/responses/del/trace-tree.yaml b/test/golden/common/pathItem/operation/responses/del/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/pathItem/operation/responses/del/trace-tree.yaml
@@ -0,0 +1,4 @@
+forwardChanges: {}
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod: ConsumerDoesntHaveResponseCode 500
diff --git a/test/golden/common/property-removed-additional/a.yaml b/test/golden/common/property-removed-additional/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-removed-additional/a.yaml
@@ -0,0 +1,32 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ required:
+ - property1
+ - property2
+ properties:
+ property1:
+ type: string
+ property2:
+ type: number
diff --git a/test/golden/common/property-removed-additional/b.yaml b/test/golden/common/property-removed-additional/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-removed-additional/b.yaml
@@ -0,0 +1,29 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ required:
+ - property1
+ properties:
+ property1:
+ type: string
diff --git a/test/golden/common/property-removed-additional/report.md b/test/golden/common/property-removed-additional/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-removed-additional/report.md
@@ -0,0 +1,39 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 3 | 3 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$.property2`
+
+1. Values are no longer limited to the following types:
+
+ - Number
+
+2. The property was previously explicitly defined. It is now implicitly
+ described by the catch-all "additional properties" case.
+
+3. The property may not be present.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$.property2`
+
+1. Values are no longer limited to the following types:
+
+ - Number
+
+2. The property was previously explicitly defined. It is now implicitly
+ described by the catch-all "additional properties" case.
+
+3. The property may not be present.
diff --git a/test/golden/common/property-removed-additional/trace-tree.yaml b/test/golden/common/property-removed-additional/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-removed-additional/trace-tree.yaml
@@ -0,0 +1,22 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "property2":
+ - TypesRestricted [Number]
+ - AdditionalToProperty
+ - PropertyNowRequired
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "property2":
+ - TypesRestricted [Number]
+ - AdditionalToProperty
+ - PropertyNowRequired
diff --git a/test/golden/common/property-removed/a.yaml b/test/golden/common/property-removed/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-removed/a.yaml
@@ -0,0 +1,33 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ required:
+ - property1
+ - property2
+ properties:
+ property1:
+ type: string
+ property2:
+ type: number
+ additionalProperties: false
diff --git a/test/golden/common/property-removed/b.yaml b/test/golden/common/property-removed/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-removed/b.yaml
@@ -0,0 +1,30 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ required:
+ - property1
+ properties:
+ property1:
+ type: string
+ additionalProperties: false
diff --git a/test/golden/common/property-removed/report.md b/test/golden/common/property-removed/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-removed/report.md
@@ -0,0 +1,21 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |
+|------------------------------------------|-------------------------|
+| 2 | 0 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$.property2`
+
+The property has been removed.
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$.property2`
+
+The property may not be present.
diff --git a/test/golden/common/property-removed/trace-tree.yaml b/test/golden/common/property-removed/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-removed/trace-tree.yaml
@@ -0,0 +1,26 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "property2": UnexpectedProperty
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "property2": PropertyNowRequired
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "property2": PropertyNowRequired
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "property2": UnexpectedProperty
diff --git a/test/golden/common/property-required/a.yaml b/test/golden/common/property-required/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-required/a.yaml
@@ -0,0 +1,32 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ required:
+ - property1
+ properties:
+ property1:
+ type: string
+ property2:
+ type: number
+ additionalProperties: false
diff --git a/test/golden/common/property-required/b.yaml b/test/golden/common/property-required/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-required/b.yaml
@@ -0,0 +1,33 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ required:
+ - property1
+ - property2
+ properties:
+ property1:
+ type: string
+ property2:
+ type: number
+ additionalProperties: false
diff --git a/test/golden/common/property-required/report.md b/test/golden/common/property-required/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-required/report.md
@@ -0,0 +1,25 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 1 | 1 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$.property2`
+
+The property has become required.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$.property2`
+
+The property has become required.
diff --git a/test/golden/common/property-required/trace-tree.yaml b/test/golden/common/property-required/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/property-required/trace-tree.yaml
@@ -0,0 +1,16 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "property2": PropertyNowRequired
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "property2": PropertyNowRequired
diff --git a/test/golden/common/random-example/a.yaml b/test/golden/common/random-example/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/random-example/a.yaml
@@ -0,0 +1,56 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: https://example.com
+paths:
+ /pets:
+ get:
+ parameters:
+ - name: limit
+ in: query
+ required: false
+ schema:
+ type: integer
+ maximum: 20
+ responses:
+ "200":
+ description: ""
+ headers:
+ x-next:
+ schema:
+ type: string
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pets"
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pet"
+ responses:
+ "201":
+ description: ""
+components:
+ schemas:
+ Pet:
+ type: object
+ required:
+ - id
+ - name
+ properties:
+ id:
+ type: integer
+ name:
+ type: string
+ minLength: 3
+ maxLength: 10
+ Pets:
+ type: array
+ items:
+ $ref: "#/components/schemas/Pet"
diff --git a/test/golden/common/random-example/b.yaml b/test/golden/common/random-example/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/random-example/b.yaml
@@ -0,0 +1,58 @@
+openapi: "3.0.0"
+info:
+ version: 1.1.0
+ title: Swagger Petstore
+ license:
+ name: MIT
+servers:
+ - url: https://example.com
+paths:
+ /pets:
+ get:
+ parameters:
+ - name: limit
+ in: query
+ required: false
+ schema:
+ type: integer
+ maximum: 30
+ responses:
+ "200":
+ description: ""
+ headers:
+ x-next:
+ schema:
+ type: string
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pets"
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Pet"
+ responses:
+ "201":
+ description: ""
+components:
+ schemas:
+ Pet:
+ type: object
+ required:
+ - id
+ - name
+ properties:
+ id:
+ type: integer
+ name:
+ type: string
+ minLength: 1
+ maxLength: 15
+ weight:
+ type: integer
+ Pets:
+ type: array
+ items:
+ $ref: "#/components/schemas/Pet"
diff --git a/test/golden/common/random-example/report.md b/test/golden/common/random-example/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/random-example/report.md
@@ -0,0 +1,71 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 5 | 6 |
+
+# ❌ Breaking changes
+
+## **GET** /pets
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$[*].name(String)`
+
+1. Maximum length of the string changed from 10 to 15.
+
+2. Minimum length of the string changed from 3 to 1.
+
+## **POST** /pets
+
+### ➡️☁️ JSON Request
+
+#### `$.weight`
+
+1. Values are now limited to the following types:
+
+ - Number
+
+2. The property was previously implicitly described by the catch-all
+ "additional properties" case. It is now explicitly defined.
+
+#### `$.weight(Number)`
+
+Value is now a multiple of 1.0.
+
+# ⚠️ Non-breaking changes
+
+## **GET** /pets
+
+### Parameter limit
+
+#### JSON Schema
+
+##### `$(Number)`
+
+Upper bound changed from 20.0 inclusive to 30.0 inclusive.
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$[*].weight`
+
+1. Values are now limited to the following types:
+
+ - Number
+
+2. The property was previously implicitly described by the catch-all
+ "additional properties" case. It is now explicitly defined.
+
+#### `$[*].weight(Number)`
+
+Value is now a multiple of 1.0.
+
+## **POST** /pets
+
+### ➡️☁️ JSON Request
+
+#### `$.name(String)`
+
+1. Maximum length of the string changed from 10 to 15.
+
+2. Minimum length of the string changed from 3 to 1.
diff --git a/test/golden/common/random-example/trace-tree.yaml b/test/golden/common/random-example/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/random-example/trace-tree.yaml
@@ -0,0 +1,48 @@
+forwardChanges:
+ AtPath "/pets":
+ InOperation GetMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array:
+ InItems:
+ OfType Object:
+ InProperty "name":
+ OfType String:
+ - MatchingMaxLengthWeak (ProdCons {producer = 15, consumer = 10})
+ - MatchingMinLengthWeak (ProdCons {producer = 1, consumer = 3})
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "weight":
+ - TypesRestricted [Number]
+ - AdditionalToProperty
+ - OfType Number: NoMatchingMultipleOf 1.0
+backwardChanges:
+ AtPath "/pets":
+ InOperation GetMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array:
+ InItems:
+ OfType Object:
+ InProperty "weight":
+ - TypesRestricted [Number]
+ - AdditionalToProperty
+ - OfType Number: NoMatchingMultipleOf 1.0
+ InParam "limit":
+ InParamSchema:
+ OfType Number: MatchingMaximumWeak (ProdCons {producer = Inclusive 30.0,
+ consumer = Inclusive 20.0})
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "name":
+ OfType String:
+ - MatchingMaxLengthWeak (ProdCons {producer = 15, consumer = 10})
+ - MatchingMinLengthWeak (ProdCons {producer = 1, consumer = 3})
diff --git a/test/golden/common/recursive/a.yaml b/test/golden/common/recursive/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/recursive/a.yaml
@@ -0,0 +1,50 @@
+openapi: 3.0.0
+info:
+ title: ""
+ version: ""
+servers:
+ - url: /
+paths:
+ /api/foo:
+ get:
+ requestBody:
+ content:
+ application/json;charset=utf-8:
+ schema:
+ $ref: "#/components/schemas/Tree"
+
+ responses:
+ 200:
+ description: ""
+ content:
+ application/json;charset=utf-8:
+ schema:
+ $ref: "#/components/schemas/Tree"
+components:
+ schemas:
+ Tree:
+ type: object
+ properties:
+ node:
+ required:
+ - children
+ type: object
+ properties:
+ children:
+ type: array
+ items:
+ $ref: "#/components/schemas/Tree"
+ leaf:
+ required:
+ - value
+ type: object
+ properties:
+ value:
+ $ref: "#/components/schemas/Item"
+ Item:
+ required:
+ - foo
+ type: object
+ properties:
+ foo:
+ type: string
diff --git a/test/golden/common/recursive/b.yaml b/test/golden/common/recursive/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/recursive/b.yaml
@@ -0,0 +1,49 @@
+openapi: 3.0.0
+info:
+ title: ""
+ version: ""
+servers:
+ - url: /
+paths:
+ /api/foo:
+ get:
+ requestBody:
+ content:
+ application/json;charset=utf-8:
+ schema:
+ $ref: "#/components/schemas/Tree"
+
+ responses:
+ 200:
+ description: ""
+ content:
+ application/json;charset=utf-8:
+ schema:
+ $ref: "#/components/schemas/Tree"
+components:
+ schemas:
+ Tree:
+ type: object
+ properties:
+ node:
+ required:
+ - children
+ type: object
+ properties:
+ children:
+ type: array
+ items:
+ $ref: "#/components/schemas/Tree"
+ leaf:
+ required:
+ - value
+ type: object
+ properties:
+ value:
+ required:
+ - foo
+ type: object
+ properties:
+ foo:
+ enum:
+ - "a"
diff --git a/test/golden/common/recursive/report.md b/test/golden/common/recursive/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/recursive/report.md
@@ -0,0 +1,33 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 1 | 1 |
+
+# ❌ Breaking changes
+
+## **GET** /api/foo
+
+### ➡️☁️ JSON Request
+
+#### `$.leaf.value.foo(String)`
+
+The following enum value has been added:
+
+``` json
+"a"
+```
+
+# ⚠️ Non-breaking changes
+
+## **GET** /api/foo
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$.leaf.value.foo(String)`
+
+The following enum value has been added:
+
+``` json
+"a"
+```
diff --git a/test/golden/common/recursive/trace-tree.yaml b/test/golden/common/recursive/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/recursive/trace-tree.yaml
@@ -0,0 +1,26 @@
+forwardChanges:
+ AtPath "/api/foo":
+ InOperation GetMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "leaf":
+ OfType Object:
+ InProperty "value":
+ OfType Object:
+ InProperty "foo":
+ OfType String: NoMatchingEnum (String "a")
+backwardChanges:
+ AtPath "/api/foo":
+ InOperation GetMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "leaf":
+ OfType Object:
+ InProperty "value":
+ OfType Object:
+ InProperty "foo":
+ OfType String: NoMatchingEnum (String "a")
diff --git a/test/golden/common/security-scheme/a.yaml b/test/golden/common/security-scheme/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/security-scheme/a.yaml
@@ -0,0 +1,110 @@
+openapi: 3.0.0
+info:
+ version: ""
+ title: ""
+paths:
+ /oauth/sign_out:
+ get:
+ parameters:
+ - required: false
+ schema:
+ type: string
+ in: query
+ name: redirect
+ responses:
+ "302":
+ content:
+ application/x-www-form-urlencoded: {}
+ headers:
+ Location:
+ schema:
+ type: string
+ set-cookie:
+ schema:
+ type: string
+ description: ""
+ "400":
+ description: Invalid `redirect`
+ security:
+ - sign-out-oauth: []
+ - oauth: []
+ /oauth/authorize:
+ get:
+ responses:
+ "302":
+ content:
+ application/x-www-form-urlencoded: {}
+ headers:
+ Location:
+ schema:
+ type: string
+ description: ""
+ security:
+ - get-oauth: []
+ /oauth/token:
+ post:
+ requestBody:
+ content:
+ application/x-www-form-urlencoded:
+ schema:
+ type: string
+ responses:
+ "200":
+ content:
+ application/json;charset=utf-8:
+ schema:
+ type: string
+ description: ""
+ "400":
+ description: Invalid `body`
+ security:
+ - oauth: []
+ /oauth/check:
+ post:
+ requestBody:
+ content:
+ application/json;charset=utf-8:
+ schema:
+ type: string
+ responses:
+ "200":
+ content:
+ application/json;charset=utf-8:
+ schema:
+ example: []
+ items: {}
+ maxItems: 0
+ type: array
+ description: ""
+ "400":
+ description: Invalid `body`
+ security:
+ - oauth: []
+components:
+ securitySchemes:
+ sign-out-oauth:
+ in: cookie
+ name: _SESSION
+ type: apiKey
+ description: Session cookie
+ get-oauth:
+ in: cookie
+ name: _SESSION
+ type: apiKey
+ description: Session cookie
+ oauth:
+ scheme: Basic
+ type: http
+ oauth-token:
+ scheme: Bearer
+ type: http
+ description: Bearer token
+ oauth-token-client-only:
+ scheme: Bearer
+ type: http
+ description: Bearer token
+ spa-oauth:
+ in: cookie
+ name: _SESSION
+ type: apiKey
+ description: Session cookie
diff --git a/test/golden/common/security-scheme/b.yaml b/test/golden/common/security-scheme/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/security-scheme/b.yaml
@@ -0,0 +1,110 @@
+openapi: 3.0.0
+info:
+ version: ""
+ title: ""
+paths:
+ /oauth/sign_out:
+ get:
+ parameters:
+ - required: false
+ schema:
+ type: string
+ in: query
+ name: redirect
+ responses:
+ "302":
+ content:
+ application/x-www-form-urlencoded: {}
+ headers:
+ Location:
+ schema:
+ type: string
+ set-cookie:
+ schema:
+ type: string
+ description: ""
+ "400":
+ description: Invalid `redirect`
+ security:
+ - sign-out-oauth: []
+ /oauth/authorize:
+ get:
+ responses:
+ "302":
+ content:
+ application/x-www-form-urlencoded: {}
+ headers:
+ Location:
+ schema:
+ type: string
+ description: ""
+ security:
+ - get-oauth: []
+ - spa-oauth: []
+ /oauth/token:
+ post:
+ requestBody:
+ content:
+ application/x-www-form-urlencoded:
+ schema:
+ type: string
+ responses:
+ "200":
+ content:
+ application/json;charset=utf-8:
+ schema:
+ type: string
+ description: ""
+ "400":
+ description: Invalid `body`
+ security:
+ - oauth: []
+ /oauth/check:
+ post:
+ requestBody:
+ content:
+ application/json;charset=utf-8:
+ schema:
+ type: string
+ responses:
+ "200":
+ content:
+ application/json;charset=utf-8:
+ schema:
+ example: []
+ items: {}
+ maxItems: 0
+ type: array
+ description: ""
+ "400":
+ description: Invalid `body`
+ security:
+ - spa-oauth: []
+components:
+ securitySchemes:
+ sign-out-oauth:
+ in: cookie
+ name: _SESSION
+ type: apiKey
+ description: Session cookie
+ get-oauth:
+ in: cookie
+ name: _SESSION
+ type: apiKey
+ description: Session cookie
+ oauth:
+ scheme: Basic
+ type: http
+ oauth-token:
+ scheme: Bearer
+ type: http
+ description: Bearer token
+ oauth-token-client-only:
+ scheme: Bearer
+ type: http
+ description: Bearer token
+ spa-oauth:
+ in: cookie
+ name: _SESSION
+ type: apiKey
+ description: Session cookie
diff --git a/test/golden/common/security-scheme/report.md b/test/golden/common/security-scheme/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/security-scheme/report.md
@@ -0,0 +1,33 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 2 | 1 |
+
+# ❌ Breaking changes
+
+## **POST** /oauth/check
+
+### Security requirement 0
+
+#### oauth
+
+Security scheme has been removed.
+
+## **GET** /oauth/sign\_out
+
+### Security requirement 1
+
+#### oauth
+
+Security scheme has been removed.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /oauth/check
+
+### Security requirement 0
+
+#### spa-oauth
+
+Security scheme has been added.
diff --git a/test/golden/common/security-scheme/trace-tree.yaml b/test/golden/common/security-scheme/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/security-scheme/trace-tree.yaml
@@ -0,0 +1,14 @@
+forwardChanges:
+ AtPath "/oauth/sign_out":
+ InOperation GetMethod:
+ SecurityRequirementStep 1:
+ SecuritySchemeStep "oauth": SecuritySchemeNotMatched
+ AtPath "/oauth/check":
+ InOperation PostMethod:
+ SecurityRequirementStep 0:
+ SecuritySchemeStep "oauth": SecuritySchemeNotMatched
+backwardChanges:
+ AtPath "/oauth/check":
+ InOperation PostMethod:
+ SecurityRequirementStep 0:
+ SecuritySchemeStep "spa-oauth": SecuritySchemeNotMatched
diff --git a/test/golden/common/servers/a.yaml b/test/golden/common/servers/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/servers/a.yaml
@@ -0,0 +1,38 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+servers:
+ - url: http://petstore.swagger.io/v1
+ variables:
+ variableThatDoesntDoAnything:
+ default: a
+ enum:
+ - a
+ - bbb
+ - url: http://missing.url
+ - url: http://{x}variable.path/{y}/{openVariable1}/{openVariable2}
+ variables:
+ x:
+ default: a
+ enum:
+ - a
+ - b
+ - c
+ y:
+ default: aa
+ enum:
+ - a
+ - aa
+ - aaa
+ openVariable1:
+ default: henlo
+ openVariable2:
+ default: henlo
+paths:
+ /pets:
+ get:
+ responses:
+ "200":
+ description: A paged array of pets
+components: {}
diff --git a/test/golden/common/servers/b.yaml b/test/golden/common/servers/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/servers/b.yaml
@@ -0,0 +1,34 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Swagger Petstore
+servers:
+ - url: http://petstore.swagger.io/v1
+ - url: http://{x}variable.path/{y}/{openVariable1}/{openVariable2}
+ variables:
+ x:
+ default: a
+ enum:
+ - b
+ - c
+ y:
+ default: aa
+ enum:
+ - a
+ - aa
+ - aaa
+ - bbb
+ openVariable1:
+ default: henlo
+ openVariable2:
+ default: henlo
+ enum:
+ - a
+ - aaa
+paths:
+ /pets:
+ get:
+ responses:
+ "200":
+ description: A paged array of pets
+components: {}
diff --git a/test/golden/common/servers/report.md b/test/golden/common/servers/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/servers/report.md
@@ -0,0 +1,27 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 3 | 1 |
+
+# ❌ Breaking changes
+
+## **GET** /pets
+
+### Server `http://missing.url`
+
+The server was removed.
+
+### Server `http://{x}variable.path/{y}/{openVariable1}/{openVariable2}`
+
+1. Enum value `a` has been removed.
+
+2. A variable has been changed from being open to being closed.
+
+# ⚠️ Non-breaking changes
+
+## **GET** /pets
+
+### Server `http://{x}variable.path/{y}/{openVariable1}/{openVariable2}`
+
+Enum value `bbb` has been added.
diff --git a/test/golden/common/servers/trace-tree.yaml b/test/golden/common/servers/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/servers/trace-tree.yaml
@@ -0,0 +1,12 @@
+forwardChanges:
+ AtPath "/pets":
+ InOperation GetMethod:
+ InServer "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}":
+ - EnumValueNotConsumed 1 "a"
+ - ConsumerNotOpen 7
+ InServer "http://missing.url": ServerNotMatched
+backwardChanges:
+ AtPath "/pets":
+ InOperation GetMethod:
+ InServer "http://{x}variable.path/{y}/{openVariable1}/{openVariable2}": EnumValueNotConsumed
+ 3 "bbb"
diff --git a/test/golden/common/tuple-items/heterogeneous-component-mismatch/a.yaml b/test/golden/common/tuple-items/heterogeneous-component-mismatch/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/heterogeneous-component-mismatch/a.yaml
@@ -0,0 +1,28 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ type: array
+ items:
+ - type: number
+ - type: string
diff --git a/test/golden/common/tuple-items/heterogeneous-component-mismatch/b.yaml b/test/golden/common/tuple-items/heterogeneous-component-mismatch/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/heterogeneous-component-mismatch/b.yaml
@@ -0,0 +1,28 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ type: array
+ items:
+ - type: number
+ - type: object
diff --git a/test/golden/common/tuple-items/heterogeneous-component-mismatch/report.md b/test/golden/common/tuple-items/heterogeneous-component-mismatch/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/heterogeneous-component-mismatch/report.md
@@ -0,0 +1,37 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 2 | 2 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$[1](String)`
+
+The type has been removed.
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$[1](Object)`
+
+The type has been added.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$[1](Object)`
+
+The type has been added.
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$[1](String)`
+
+The type has been removed.
diff --git a/test/golden/common/tuple-items/heterogeneous-component-mismatch/trace-tree.yaml b/test/golden/common/tuple-items/heterogeneous-component-mismatch/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/heterogeneous-component-mismatch/trace-tree.yaml
@@ -0,0 +1,30 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array:
+ InItem 1:
+ OfType String: TypeBecomesEmpty
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array:
+ InItem 1:
+ OfType Object: TypeBecomesEmpty
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array:
+ InItem 1:
+ OfType Object: TypeBecomesEmpty
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array:
+ InItem 1:
+ OfType String: TypeBecomesEmpty
diff --git a/test/golden/common/tuple-items/heterogeneous-length-mismatch/a.yaml b/test/golden/common/tuple-items/heterogeneous-length-mismatch/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/heterogeneous-length-mismatch/a.yaml
@@ -0,0 +1,29 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ type: array
+ items:
+ - type: number
+ - type: string
+ - type: object
diff --git a/test/golden/common/tuple-items/heterogeneous-length-mismatch/b.yaml b/test/golden/common/tuple-items/heterogeneous-length-mismatch/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/heterogeneous-length-mismatch/b.yaml
@@ -0,0 +1,28 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ type: array
+ items:
+ - type: number
+ - type: object
diff --git a/test/golden/common/tuple-items/heterogeneous-length-mismatch/report.md b/test/golden/common/tuple-items/heterogeneous-length-mismatch/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/heterogeneous-length-mismatch/report.md
@@ -0,0 +1,21 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |
+|------------------------------------------|-------------------------|
+| 2 | 0 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$(Array)`
+
+Tuple length changed from 3 to 2.
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Array)`
+
+Tuple length changed from 3 to 2.
diff --git a/test/golden/common/tuple-items/heterogeneous-length-mismatch/trace-tree.yaml b/test/golden/common/tuple-items/heterogeneous-length-mismatch/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/heterogeneous-length-mismatch/trace-tree.yaml
@@ -0,0 +1,26 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array: TupleItemsLengthChanged (ProdCons {producer = 3, consumer
+ = 2})
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array: TupleItemsLengthChanged (ProdCons {producer = 2, consumer
+ = 3})
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array: TupleItemsLengthChanged (ProdCons {producer = 2, consumer
+ = 3})
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array: TupleItemsLengthChanged (ProdCons {producer = 3, consumer
+ = 2})
diff --git a/test/golden/common/tuple-items/homogeneous-component-mismatch/a.yaml b/test/golden/common/tuple-items/homogeneous-component-mismatch/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-component-mismatch/a.yaml
@@ -0,0 +1,28 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ type: array
+ items:
+ - type: string
+ - type: number
diff --git a/test/golden/common/tuple-items/homogeneous-component-mismatch/b.yaml b/test/golden/common/tuple-items/homogeneous-component-mismatch/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-component-mismatch/b.yaml
@@ -0,0 +1,29 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ type: array
+ minItems: 2
+ maxItems: 2
+ items:
+ type: number
diff --git a/test/golden/common/tuple-items/homogeneous-component-mismatch/report.md b/test/golden/common/tuple-items/homogeneous-component-mismatch/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-component-mismatch/report.md
@@ -0,0 +1,45 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 4 | 2 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$(Array)`
+
+The array is no longer explicitly defined as a tuple.
+
+#### `$[0](String)`
+
+The type has been removed.
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Array)`
+
+The array is no longer explicitly defined as a tuple.
+
+#### `$[0](Number)`
+
+The type has been added.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$[0](Number)`
+
+The type has been added.
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$[0](String)`
+
+The type has been removed.
diff --git a/test/golden/common/tuple-items/homogeneous-component-mismatch/trace-tree.yaml b/test/golden/common/tuple-items/homogeneous-component-mismatch/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-component-mismatch/trace-tree.yaml
@@ -0,0 +1,34 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array:
+ - TupleToArray
+ - InItem 0:
+ OfType String: TypeBecomesEmpty
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array:
+ - ArrayToTuple
+ - InItem 0:
+ OfType Number: TypeBecomesEmpty
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array:
+ - ArrayToTuple
+ - InItem 0:
+ OfType Number: TypeBecomesEmpty
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array:
+ - TupleToArray
+ - InItem 0:
+ OfType String: TypeBecomesEmpty
diff --git a/test/golden/common/tuple-items/homogeneous-length-mismatch/a.yaml b/test/golden/common/tuple-items/homogeneous-length-mismatch/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-length-mismatch/a.yaml
@@ -0,0 +1,56 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test1:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ /test2:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ /test3:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ type: array
+ items:
+ - type: number
+ - type: number
diff --git a/test/golden/common/tuple-items/homogeneous-length-mismatch/b.yaml b/test/golden/common/tuple-items/homogeneous-length-mismatch/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-length-mismatch/b.yaml
@@ -0,0 +1,67 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test1:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test1"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test1"
+ /test2:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test2"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test2"
+ /test3:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test3"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test3"
+components:
+ schemas:
+ Test1:
+ type: array
+ maxItems: 2
+ items:
+ type: number
+ Test2:
+ type: array
+ minItems: 2
+ items:
+ type: number
+ Test3:
+ type: array
+ minItems: 3
+ maxItems: 3
+ items:
+ type: number
diff --git a/test/golden/common/tuple-items/homogeneous-length-mismatch/report.md b/test/golden/common/tuple-items/homogeneous-length-mismatch/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-length-mismatch/report.md
@@ -0,0 +1,73 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 5 | 5 |
+
+# ❌ Breaking changes
+
+## **POST** /test1
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Array)`
+
+The array is no longer explicitly defined as a tuple.
+
+## **POST** /test2
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Array)`
+
+The array is no longer explicitly defined as a tuple.
+
+## **POST** /test3
+
+### ➡️☁️ JSON Request
+
+#### `$(Array)`
+
+Minimum length of the array changed from 2 to 3.
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Array)`
+
+1. Tuple length changed from 2 to 3.
+
+2. The array is no longer explicitly defined as a tuple.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test1
+
+### ➡️☁️ JSON Request
+
+#### `$(Array)`
+
+The array is no longer explicitly defined as a tuple.
+
+## **POST** /test2
+
+### ➡️☁️ JSON Request
+
+#### `$(Array)`
+
+The array is no longer explicitly defined as a tuple.
+
+## **POST** /test3
+
+### ➡️☁️ JSON Request
+
+#### `$(Array)`
+
+1. Tuple length changed from 2 to 3.
+
+2. The array is no longer explicitly defined as a tuple.
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Array)`
+
+Minimum length of the array changed from 2 to 3.
diff --git a/test/golden/common/tuple-items/homogeneous-length-mismatch/trace-tree.yaml b/test/golden/common/tuple-items/homogeneous-length-mismatch/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-length-mismatch/trace-tree.yaml
@@ -0,0 +1,52 @@
+forwardChanges:
+ AtPath "/test3":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array: MatchingMinItemsWeak (ProdCons {producer = 2, consumer =
+ 3})
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array:
+ - TupleItemsLengthChanged (ProdCons {producer = 3, consumer = 2})
+ - ArrayToTuple
+ AtPath "/test1":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array: NoMatchingTupleItems
+ AtPath "/test2":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array: NoMatchingTupleItems
+backwardChanges:
+ AtPath "/test3":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array:
+ - TupleItemsLengthChanged (ProdCons {producer = 3, consumer = 2})
+ - ArrayToTuple
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array: MatchingMinItemsWeak (ProdCons {producer = 2, consumer =
+ 3})
+ AtPath "/test1":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array: NoMatchingTupleItems
+ AtPath "/test2":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array: NoMatchingTupleItems
diff --git a/test/golden/common/tuple-items/homogeneous-vector/a.yaml b/test/golden/common/tuple-items/homogeneous-vector/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-vector/a.yaml
@@ -0,0 +1,28 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ type: array
+ items:
+ - type: number
+ - type: number
diff --git a/test/golden/common/tuple-items/homogeneous-vector/b.yaml b/test/golden/common/tuple-items/homogeneous-vector/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-vector/b.yaml
@@ -0,0 +1,29 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ type: array
+ minItems: 2
+ maxItems: 2
+ items:
+ type: number
diff --git a/test/golden/common/tuple-items/homogeneous-vector/report.md b/test/golden/common/tuple-items/homogeneous-vector/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-vector/report.md
@@ -0,0 +1,5 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes |
+|---------------------|-------------------------|
+| 0 | 0 |
diff --git a/test/golden/common/tuple-items/homogeneous-vector/trace-tree.yaml b/test/golden/common/tuple-items/homogeneous-vector/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/tuple-items/homogeneous-vector/trace-tree.yaml
@@ -0,0 +1,2 @@
+forwardChanges: {}
+backwardChanges: {}
diff --git a/test/golden/common/type-changing/a.yaml b/test/golden/common/type-changing/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/type-changing/a.yaml
@@ -0,0 +1,113 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test1:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test1"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test1"
+ /test2:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test2"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test2"
+ /test3:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test3"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test3"
+ /test4:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test4"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test4"
+ /test5:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test5"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test5"
+components:
+ schemas:
+ Test1:
+ multipleOf: 1
+ minLength: 1
+ minItems: 1
+ Test2:
+ multipleOf: 1
+ minLength: 1
+ minItems: 1
+ Test3:
+ anyOf:
+ - type: number
+ multipleOf: 1
+ - type: array
+ minItems: 1
+ - type: string
+ minLength: 1
+ - type: object
+ Test4:
+ anyOf:
+ - type: number
+ multipleOf: 1
+ - type: array
+ minItems: 1
+ - type: string
+ minLength: 1
+ - type: object
+ Test5:
+ anyOf:
+ - type: number
+ multipleOf: 1
+ - type: array
+ minItems: 1
+ - type: object
+ - minLength: 1
diff --git a/test/golden/common/type-changing/b.yaml b/test/golden/common/type-changing/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/type-changing/b.yaml
@@ -0,0 +1,108 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test1:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test1"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test1"
+ /test2:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test2"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test2"
+ /test3:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test3"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test3"
+ /test4:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test4"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test4"
+ /test5:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test5"
+ responses:
+ "200":
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test5"
+components:
+ schemas:
+ Test1:
+ type: array
+ minItems: 1
+ Test2:
+ anyOf:
+ - type: number
+ multipleOf: 1
+ - type: array
+ minItems: 1
+ - type: object
+ Test3:
+ anyOf:
+ - type: number
+ multipleOf: 1
+ - type: string
+ minLength: 1
+ - type: object
+ Test4:
+ anyOf:
+ - type: number
+ multipleOf: 1
+ - type: array
+ minItems: 1
+ - type: string
+ minLength: 1
+ Test5:
+ anyOf:
+ - type: number
+ multipleOf: 1
diff --git a/test/golden/common/type-changing/report.md b/test/golden/common/type-changing/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/type-changing/report.md
@@ -0,0 +1,105 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 6 | 6 |
+
+# ❌ Breaking changes
+
+## **POST** /test1
+
+### ➡️☁️ JSON Request
+
+Values are now limited to the following types:
+
+- Array
+
+## **POST** /test2
+
+### ➡️☁️ JSON Request
+
+Values are now limited to the following types:
+
+- Number
+
+- Array
+
+- Object
+
+## **POST** /test3
+
+### ➡️☁️ JSON Request
+
+#### `$(Array)`
+
+The type has been removed.
+
+## **POST** /test4
+
+### ➡️☁️ JSON Request
+
+#### `$(Object)`
+
+The type has been removed.
+
+## **POST** /test5
+
+### ➡️☁️ JSON Request
+
+Values are now limited to the following types:
+
+- Number
+
+#### `$(Number)`
+
+Value is now a multiple of 1.0.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test1
+
+### ⬅️☁️ JSON Response – 200
+
+Values are now limited to the following types:
+
+- Array
+
+## **POST** /test2
+
+### ⬅️☁️ JSON Response – 200
+
+Values are now limited to the following types:
+
+- Number
+
+- Array
+
+- Object
+
+## **POST** /test3
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Array)`
+
+The type has been removed.
+
+## **POST** /test4
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Object)`
+
+The type has been removed.
+
+## **POST** /test5
+
+### ⬅️☁️ JSON Response – 200
+
+Values are now limited to the following types:
+
+- Number
+
+#### `$(Number)`
+
+Value is now a multiple of 1.0.
diff --git a/test/golden/common/type-changing/trace-tree.yaml b/test/golden/common/type-changing/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/type-changing/trace-tree.yaml
@@ -0,0 +1,60 @@
+forwardChanges:
+ AtPath "/test5":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ - TypesRestricted [Number]
+ - OfType Number: NoMatchingMultipleOf 1.0
+ AtPath "/test3":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Array: TypeBecomesEmpty
+ AtPath "/test4":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object: TypeBecomesEmpty
+ AtPath "/test1":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema: TypesRestricted [Array]
+ AtPath "/test2":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema: TypesRestricted [Number,Array,Object]
+backwardChanges:
+ AtPath "/test5":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ - TypesRestricted [Number]
+ - OfType Number: NoMatchingMultipleOf 1.0
+ AtPath "/test3":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Array: TypeBecomesEmpty
+ AtPath "/test4":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object: TypeBecomesEmpty
+ AtPath "/test1":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema: TypesRestricted [Array]
+ AtPath "/test2":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema: TypesRestricted [Number,Array,Object]
diff --git a/test/golden/common/unguarded-recursive/basic/a.yaml b/test/golden/common/unguarded-recursive/basic/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/unguarded-recursive/basic/a.yaml
@@ -0,0 +1,21 @@
+openapi: 3.0.0
+info:
+ title: ""
+ version: ""
+servers:
+ - url: /
+paths:
+ /api/foo:
+ get:
+ responses:
+ 200:
+ description: ""
+ content:
+ application/json;charset=utf-8:
+ schema:
+ $ref: "#/components/schemas/Bad"
+components:
+ schemas:
+ Bad:
+ anyOf:
+ - $ref: "#/components/schemas/Bad"
diff --git a/test/golden/common/unguarded-recursive/basic/b.yaml b/test/golden/common/unguarded-recursive/basic/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/unguarded-recursive/basic/b.yaml
@@ -0,0 +1,21 @@
+openapi: 3.0.0
+info:
+ title: ""
+ version: ""
+servers:
+ - url: /
+paths:
+ /api/foo:
+ get:
+ responses:
+ 200:
+ description: ""
+ content:
+ application/json;charset=utf-8:
+ schema:
+ $ref: "#/components/schemas/Bad"
+components:
+ schemas:
+ Bad:
+ allOf:
+ - $ref: "#/components/schemas/Bad"
diff --git a/test/golden/common/unguarded-recursive/basic/report.md b/test/golden/common/unguarded-recursive/basic/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/unguarded-recursive/basic/report.md
@@ -0,0 +1,13 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |
+|---------------------|-------------------------|--------------------------------------------------------|
+| 0 | 0 | 1 |
+
+# ❓ Unsupported feature changes
+
+## **GET** /api/foo
+
+### ⬅️☁️ JSON Response – 200
+
+Encountered recursion that is too complex for CompaREST to untangle.
diff --git a/test/golden/common/unguarded-recursive/basic/trace-tree.yaml b/test/golden/common/unguarded-recursive/basic/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/unguarded-recursive/basic/trace-tree.yaml
@@ -0,0 +1,12 @@
+forwardChanges:
+ AtPath "/api/foo":
+ InOperation GetMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema: UnguardedRecursion
+backwardChanges:
+ AtPath "/api/foo":
+ InOperation GetMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema: UnguardedRecursion
diff --git a/test/golden/common/unguarded-recursive/silent/a.yaml b/test/golden/common/unguarded-recursive/silent/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/unguarded-recursive/silent/a.yaml
@@ -0,0 +1,25 @@
+components:
+ schemas:
+ A:
+ type: object
+ properties:
+ bar:
+ $ref: "#/components/schemas/B"
+ B:
+ anyOf:
+ - $ref: "#/components/schemas/B"
+ type: object
+openapi: 3.0.0
+info:
+ version: ""
+ title: ""
+paths:
+ /foo:
+ get:
+ responses:
+ "200":
+ content:
+ application/json;charset=utf-8:
+ schema:
+ $ref: "#/components/schemas/A"
+ description: ""
diff --git a/test/golden/common/unguarded-recursive/silent/b.yaml b/test/golden/common/unguarded-recursive/silent/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/unguarded-recursive/silent/b.yaml
@@ -0,0 +1,19 @@
+components:
+ schemas: {}
+openapi: 3.0.0
+info:
+ version: ""
+ title: ""
+paths:
+ /foo:
+ get:
+ responses:
+ "200":
+ content:
+ application/json;charset=utf-8:
+ schema:
+ type: object
+ properties:
+ bar:
+ type: object
+ description: ""
diff --git a/test/golden/common/unguarded-recursive/silent/report.md b/test/golden/common/unguarded-recursive/silent/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/unguarded-recursive/silent/report.md
@@ -0,0 +1,15 @@
+# Summary
+
+| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |
+|---------------------|-------------------------|--------------------------------------------------------|
+| 0 | 0 | 1 |
+
+# ❓ Unsupported feature changes
+
+## **GET** /foo
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$.bar`
+
+Encountered recursion that is too complex for CompaREST to untangle.
diff --git a/test/golden/common/unguarded-recursive/silent/trace-tree.yaml b/test/golden/common/unguarded-recursive/silent/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/unguarded-recursive/silent/trace-tree.yaml
@@ -0,0 +1,16 @@
+forwardChanges:
+ AtPath "/foo":
+ InOperation GetMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "bar": UnguardedRecursion
+backwardChanges:
+ AtPath "/foo":
+ InOperation GetMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InProperty "bar": UnguardedRecursion
diff --git a/test/golden/common/variant-added/a.yaml b/test/golden/common/variant-added/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-added/a.yaml
@@ -0,0 +1,39 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ oneOf:
+ - type: object
+ required: ["tag", "prop_A"]
+ properties:
+ tag:
+ enum: ["A"]
+ prop_A:
+ type: string
+ - type: object
+ required: ["tag", "prop_B"]
+ properties:
+ tag:
+ enum: ["B"]
+ prop_B:
+ type: number
diff --git a/test/golden/common/variant-added/b.yaml b/test/golden/common/variant-added/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-added/b.yaml
@@ -0,0 +1,46 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ oneOf:
+ - type: object
+ required: ["tag", "prop_A"]
+ properties:
+ tag:
+ enum: ["A"]
+ prop_A:
+ type: string
+ - type: object
+ required: ["tag", "prop_B"]
+ properties:
+ tag:
+ enum: ["B"]
+ prop_B:
+ type: number
+ - type: object
+ required: ["tag", "prop_C"]
+ properties:
+ tag:
+ enum: ["C"]
+ prop_C:
+ type: number
diff --git a/test/golden/common/variant-added/report.md b/test/golden/common/variant-added/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-added/report.md
@@ -0,0 +1,25 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 1 | 1 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ⬅️☁️ JSON Response – 200
+
+#### `$(Object)`
+
+The case where `$.tag` is `"C"` – has been added.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### `$(Object)`
+
+The case where `$.tag` is `"C"` – has been added.
diff --git a/test/golden/common/variant-added/trace-tree.yaml b/test/golden/common/variant-added/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-added/trace-tree.yaml
@@ -0,0 +1,16 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object: PartitionBecomesEmpty (PInProperty "tag" PHere,CByEnumValue
+ (fromList [String "C"]))
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object: PartitionBecomesEmpty (PInProperty "tag" PHere,CByEnumValue
+ (fromList [String "C"]))
diff --git a/test/golden/common/variant-changed/a.yaml b/test/golden/common/variant-changed/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-changed/a.yaml
@@ -0,0 +1,39 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ oneOf:
+ - type: object
+ required: ["tag", "prop_A"]
+ properties:
+ tag:
+ enum: ["A"]
+ prop_A:
+ type: string
+ - type: object
+ required: ["tag", "prop_B"]
+ properties:
+ tag:
+ enum: ["B"]
+ prop_B:
+ type: number
diff --git a/test/golden/common/variant-changed/b.yaml b/test/golden/common/variant-changed/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-changed/b.yaml
@@ -0,0 +1,39 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ oneOf:
+ - type: object
+ required: ["tag", "prop_A"]
+ properties:
+ tag:
+ enum: ["A"]
+ prop_A:
+ type: string
+ - type: object
+ required: ["tag", "prop_B"]
+ properties:
+ tag:
+ enum: ["B"]
+ prop_B:
+ type: string
diff --git a/test/golden/common/variant-changed/report.md b/test/golden/common/variant-changed/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-changed/report.md
@@ -0,0 +1,45 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 2 | 2 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### In cases where `$.tag` is `"B"`
+
+##### `$.prop_B(Number)`
+
+The type has been removed.
+
+### ⬅️☁️ JSON Response – 200
+
+#### In cases where `$.tag` is `"B"`
+
+##### `$.prop_B(String)`
+
+The type has been added.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### In cases where `$.tag` is `"B"`
+
+##### `$.prop_B(String)`
+
+The type has been added.
+
+### ⬅️☁️ JSON Response – 200
+
+#### In cases where `$.tag` is `"B"`
+
+##### `$.prop_B(Number)`
+
+The type has been removed.
diff --git a/test/golden/common/variant-changed/trace-tree.yaml b/test/golden/common/variant-changed/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-changed/trace-tree.yaml
@@ -0,0 +1,34 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):
+ InProperty "prop_B":
+ OfType Number: TypeBecomesEmpty
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):
+ InProperty "prop_B":
+ OfType String: TypeBecomesEmpty
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):
+ InProperty "prop_B":
+ OfType String: TypeBecomesEmpty
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):
+ InProperty "prop_B":
+ OfType Number: TypeBecomesEmpty
diff --git a/test/golden/common/variant-deep-changed/a.yaml b/test/golden/common/variant-deep-changed/a.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-deep-changed/a.yaml
@@ -0,0 +1,47 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ oneOf:
+ - type: object
+ required: ["desc", "prop_A"]
+ properties:
+ desc:
+ type: object
+ required: ["name"]
+ properties:
+ name:
+ enum: ["A"]
+ prop_A:
+ type: string
+ - type: object
+ required: ["desc", "prop_B"]
+ properties:
+ desc:
+ type: object
+ required: ["name"]
+ properties:
+ name:
+ enum: ["B"]
+ prop_B:
+ type: number
diff --git a/test/golden/common/variant-deep-changed/b.yaml b/test/golden/common/variant-deep-changed/b.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-deep-changed/b.yaml
@@ -0,0 +1,47 @@
+openapi: "3.0.0"
+info:
+ version: 1.0.0
+ title: Test
+servers:
+ - url: http://localhost/
+paths:
+ /test:
+ post:
+ requestBody:
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+ responses:
+ '200':
+ description: test
+ content:
+ application/json:
+ schema:
+ $ref: "#/components/schemas/Test"
+components:
+ schemas:
+ Test:
+ oneOf:
+ - type: object
+ required: ["desc", "prop_A"]
+ properties:
+ desc:
+ type: object
+ required: ["name"]
+ properties:
+ name:
+ enum: ["A"]
+ prop_A:
+ type: string
+ - type: object
+ required: ["desc", "prop_B"]
+ properties:
+ desc:
+ type: object
+ required: ["name"]
+ properties:
+ name:
+ enum: ["B"]
+ prop_B:
+ type: string
diff --git a/test/golden/common/variant-deep-changed/report.md b/test/golden/common/variant-deep-changed/report.md
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-deep-changed/report.md
@@ -0,0 +1,45 @@
+# Summary
+
+| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |
+|------------------------------------------|--------------------------------------------------|
+| 2 | 2 |
+
+# ❌ Breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### In cases where `$.desc.name` is `"B"`
+
+##### `$.prop_B(Number)`
+
+The type has been removed.
+
+### ⬅️☁️ JSON Response – 200
+
+#### In cases where `$.desc.name` is `"B"`
+
+##### `$.prop_B(String)`
+
+The type has been added.
+
+# ⚠️ Non-breaking changes
+
+## **POST** /test
+
+### ➡️☁️ JSON Request
+
+#### In cases where `$.desc.name` is `"B"`
+
+##### `$.prop_B(String)`
+
+The type has been added.
+
+### ⬅️☁️ JSON Response – 200
+
+#### In cases where `$.desc.name` is `"B"`
+
+##### `$.prop_B(Number)`
+
+The type has been removed.
diff --git a/test/golden/common/variant-deep-changed/trace-tree.yaml b/test/golden/common/variant-deep-changed/trace-tree.yaml
new file mode 100644
--- /dev/null
+++ b/test/golden/common/variant-deep-changed/trace-tree.yaml
@@ -0,0 +1,34 @@
+forwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):
+ InProperty "prop_B":
+ OfType Number: TypeBecomesEmpty
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):
+ InProperty "prop_B":
+ OfType String: TypeBecomesEmpty
+backwardChanges:
+ AtPath "/test":
+ InOperation PostMethod:
+ InRequest:
+ InPayload:
+ PayloadSchema:
+ OfType Object:
+ InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):
+ InProperty "prop_B":
+ OfType String: TypeBecomesEmpty
+ WithStatusCode 200:
+ ResponsePayload:
+ PayloadSchema:
+ OfType Object:
+ InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):
+ InProperty "prop_B":
+ OfType Number: TypeBecomesEmpty