master..2a7f02a · compaREST

.github/actions/common_setup/action.yamldeleted−42

@@ -1,42 +0,0 @@

1−name: "Common setup"

2−description: "Common setup steps"

3−inputs:

4− authToken:

5− description: "Cachix auth token"

6− required: true

7−runs:

8− using: "composite"

9− steps:

10− - name: Increase swap if linux

11− shell: bash

12− run: |

13− if [ "$RUNNER_OS" == "Linux" ]; then

14−

15− echo "Is Linux"

16−

17− free -h

18−

19− sudo swapoff /mnt/swapfile

20− sudo fallocate -l 12G /mnt/swapfile

21− sudo mkswap /mnt/swapfile

22− sudo swapon /mnt/swapfile

23−

24− free -h

25−

26− else

27−

28− echo "Not Linux"

29−

30− fi

31−

32− - name: Install Nix

33− uses: cachix/install-nix-action@v16

34− with:

35− extra_nix_config: |

36− system-features = kvm

37− trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=

38− substituters = https://hydra.iohk.io https://cache.nixos.org/

39− - uses: cachix/cachix-action@v10

40− with:

41− name: typeable

42− authToken: "${{ inputs.authToken }}"

.github/workflows/github-actions-image.yamldeleted−311

@@ -1,311 +0,0 @@

1−name: Github Action Docker Image

2−

3−on:

4− push:

5− branches: [master]

6− pull_request:

7− branches: [master]

8− release:

9− types: [prereleased]

10−

11−jobs:

12− check-formatting:

13− name: Check Haskell formatting

14− runs-on: ubuntu-latest

15− steps:

16− - uses: actions/checkout@v2

17−

18− - name: Common setup

19− uses: ./.github/actions/common_setup

20− with:

21− authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

22−

23− - name: Run fourmolu

24− run: |

25− nix-shell nix/ci.nix -j auto --run "git ls-files '*.hs' | xargs fourmolu -m inplace -o -XRecursiveDo -o -XTypeApplications -o -XPatternSynonyms -o -XBangPatterns"

26− git diff --exit-code

27−

28− policeman:

29− runs-on: ubuntu-latest

30− steps:

31− - uses: actions/checkout@v2

32− with:

33− submodules: recursive

34−

35− - name: Common setup

36− uses: ./.github/actions/common_setup

37− with:

38− authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

39−

40− - name: Run policeman

41− run: |

42− jq --argjson msg "$( $(nix-build ci/policeman.nix)/bin/policeman | grep -v "⚙" | jq -aRs . )" ".[0].message = \$msg" <policeman.json >message.json

43− cat message.json

44−

45− - name: Post notice

46− uses: yuzutech/annotations-action@v0.4.0

47− with:

48− title: 👮 Policeman

49− repo-token: "${{ secrets.GITHUB_TOKEN }}"

50− input: "./message.json"

51−

52− check_versions:

53− runs-on: ubuntu-latest

54− steps:

55− - uses: actions/checkout@v2

56− with:

57− submodules: recursive

58−

59− - name: Check library version

60− if: github.event_name == 'release'

61− run: |

62− if [ "$(awk -F ':' '/^version/ {gsub(/ /, "", $2); print $2}' compaREST.cabal)" != "${{ github.event.release.tag_name }}" ]; then

63− echo "::error file=compaREST.cabal::Library version does not match release version."

64− exit 1

65− fi

66−

67− - name: Check docker tag

68− if: github.event_name == 'release'

69− run: |

70− if [ "$(yq eval '.runs.image' action.yaml | awk -F ':' '{print $NF}')" != "${{ github.event.release.tag_name }}" ]; then

71− echo "::error file=action.yaml::Action docker tag does not match release tag."

72− exit 1

73− fi

74−

75− - name: Check changelog

76− if: github.event_name == 'release'

77− run: |

78− if ! grep '^## ${{ github.event.release.tag_name }}$' CHANGELOG.md; then

79− echo "::error file=CHANGELOG.md::CHANGELOG.md does not contain an entry for this release."

80− exit 1

81− fi

82−

83− Linux:

84− needs: check_versions

85− runs-on: ubuntu-latest

86− steps:

87− - uses: actions/checkout@v2

88− with:

89− submodules: recursive

90−

91− - name: Common setup

92− uses: ./.github/actions/common_setup

93− with:

94− authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

95−

96− - name: Test

97− shell: bash

98− run: |

99− $(nix-build -A test -j auto --no-out-link)/bin/compaREST-tests

100−

101− - name: Build Linux static binary

102− shell: bash

103− run: |

104− cp $(nix-build -A compaRESTStaticBin -j auto --no-out-link)/bin/compaREST compaREST

105−

106− - name: Upload compaREST Linux Binary

107− uses: actions/upload-artifact@v2

108− with:

109− name: compaREST-Linux

110− path: compaREST

111−

112− - name: Build Docker Images

113− shell: bash

114− run: |

115− cp $(nix-build -A compaRESTGithubAction -j auto --no-out-link) compaREST-Github-Action-image.tar.gz

116− cp $(nix-build -A compaRESTImage -j auto --no-out-link) compaREST-image.tar.gz

117−

118− - name: Upload compaREST Docker Github Action Image

119− uses: actions/upload-artifact@v2

120− with:

121− name: compaREST Github Action Docker Image

122− path: compaREST-Github-Action-image.tar.gz

123−

124− - name: Upload compaREST Docker Image

125− uses: actions/upload-artifact@v2

126− with:

127− name: compaREST Docker Image

128− path: compaREST-image.tar.gz

129−

130− - name: Install skopeo

131− if: github.event_name == 'release'

132− shell: bash

133− run: |

134− sudo apt-get -y update

135− sudo apt-get -y install skopeo

136−

137− - name: Login to DockerHub

138− uses: docker/login-action@v1.10.0

139− with:

140− username: ${{ secrets.DOCKER_HUB_USERNAME }}

141− password: ${{ secrets.DOCKER_HUB_ACCESS_TOKEN }}

142−

143− - name: Push Nightly Docker Images to DockerHub

144− if: github.ref == 'refs/heads/master' && github.event_name == 'push'

145− shell: bash

146− run: |

147− skopeo copy docker-archive:$(nix-build -A compaRESTGithubAction -j auto --no-out-link) docker://ilyakooo0/comparest-github-action:nightly

148− skopeo copy docker-archive:$(nix-build -A compaRESTImage -j auto --no-out-link) docker://ilyakooo0/comparest:nightly

149−

150− - name: Push Release Docker Images to DockerHub

151− if: github.event_name == 'release'

152− shell: bash

153− run: |

154− skopeo copy docker-archive:$(nix-build -A compaRESTGithubAction -j auto --no-out-link) docker://ilyakooo0/comparest-github-action:${{ github.event.release.tag_name }}

155− skopeo copy docker-archive:$(nix-build -A compaRESTImage -j auto --no-out-link) docker://ilyakooo0/comparest:${{ github.event.release.tag_name }}

156−

157− - name: Zip Release Assets

158− if: github.event_name == 'release'

159− shell: bash

160− run: |

161− zip compaREST-Linux-x86.zip compaREST

162−

163− - name: Upload compaREST Github Action Docker Image to release

164− if: github.event_name == 'release'

165− uses: svenstaro/upload-release-action@2.2.1

166− with:

167− repo_token: ${{ secrets.GITHUB_TOKEN }}

168− file: compaREST-Github-Action-image.tar.gz

169− tag: ${{ github.ref }}

170−

171− - name: Upload compaREST Docker Image to release

172− if: github.event_name == 'release'

173− uses: svenstaro/upload-release-action@2.2.1

174− with:

175− repo_token: ${{ secrets.GITHUB_TOKEN }}

176− file: compaREST-image.tar.gz

177− tag: ${{ github.ref }}

178−

179− - name: Upload compaREST binary – Linux – x86 to release

180− if: github.event_name == 'release'

181− uses: svenstaro/upload-release-action@2.2.1

182− with:

183− repo_token: ${{ secrets.GITHUB_TOKEN }}

184− file: compaREST-Linux-x86.zip

185− tag: ${{ github.ref }}

186−

187− dist:

188− needs: check_versions

189− runs-on: ubuntu-latest

190− steps:

191− - uses: actions/checkout@v2

192− with:

193− submodules: recursive

194−

195− - name: Cache

196− uses: actions/cache@v1

197− with:

198− path: |

199− ~/.stack

200− .stack-work

201− key: ${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }}-${{ hashFiles('**.cabal') }}

202− restore-keys: |

203− ${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }}

204− ${{ runner.os }}-stack

205−

206− - name: Upgrade stack

207− shell: bash

208− # Needed for Hackage token authorization

209− run: stack upgrade --git

210−

211− - name: Build dist

212− run: |

213− stack sdist --pvp-bounds both --test-tarball

214− echo "distPath=$(stack path | awk -F ": " '/dist-dir/ {print $2}')" >> $GITHUB_ENV

215−

216− - name: Upload compaREST sources artifact

217− uses: actions/upload-artifact@v2

218− with:

219− name: compaREST sources

220− path: ${{ env.distPath }}/*.tar.gz

221−

222− - name: Upload compaREST sources to release

223− if: github.event_name == 'release'

224− uses: svenstaro/upload-release-action@2.2.1

225− with:

226− repo_token: ${{ secrets.GITHUB_TOKEN }}

227− file_glob: true

228− file: ${{ env.distPath }}/*.tar.gz

229− tag: ${{ github.ref }}

230−

231− - name: Publish compaREST candidate to Hackage

232− shell: bash

233− if: github.event_name == 'release'

234− env:

235− HACKAGE_KEY: ${{ secrets.HACKAGE_KEY }}

236− run: |

237− stack upload --pvp-bounds both --test-tarball --candidate .

238−

239− macOS:

240− needs: check_versions

241− runs-on: macos-latest

242− steps:

243− - uses: actions/checkout@v2

244− with:

245− submodules: recursive

246−

247− - name: Common setup

248− uses: ./.github/actions/common_setup

249− with:

250− authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

251−

252− - name: Build macOS binary bundle

253− run: |

254− cp -LR $(nix-build -A macOSCompaRESTBundle -j auto --no-out-link) compaREST

255−

256− - name: Upload macOS compaREST bundle

257− uses: actions/upload-artifact@v2

258− with:

259− name: compaREST binary – macOS – x86

260− path: compaREST

261−

262− - name: Zip Release Assets

263− if: github.event_name == 'release'

264− shell: bash

265− run: |

266− zip -r compaREST-macOS-x86.zip compaREST

267−

268− - name: Upload compaREST binary – macOS – x86 to release

269− if: github.event_name == 'release'

270− uses: svenstaro/upload-release-action@2.2.1

271− with:

272− repo_token: ${{ secrets.GITHUB_TOKEN }}

273− file: compaREST-macOS-x86.zip

274− tag: ${{ github.ref }}

275−

276− Linux-Windows:

277− needs: check_versions

278− runs-on: ubuntu-latest

279− steps:

280− - uses: actions/checkout@v2

281− with:

282− submodules: recursive

283−

284− - name: Common setup

285− uses: ./.github/actions/common_setup

286− with:

287− authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

288−

289− - name: Build Windows binary

290− run: |

291− cp -LR $(nix-build -A WindowsCompaRESTBin -j auto --no-out-link)/bin compaREST

292−

293− - name: Upload Windows compaREST bundle

294− uses: actions/upload-artifact@v2

295− with:

296− name: compaREST binary – Windows

297− path: compaREST

298−

299− - name: Zip Release Assets

300− if: github.event_name == 'release'

301− shell: bash

302− run: |

303− zip -r compaREST-Windows.zip compaREST

304−

305− - name: Upload compaREST binary – Windows to release

306− if: github.event_name == 'release'

307− uses: svenstaro/upload-release-action@2.2.1

308− with:

309− repo_token: ${{ secrets.GITHUB_TOKEN }}

310− file: compaREST-Windows.zip

311− tag: ${{ github.ref }}

.github/workflows/haskell.ymlnew file+54

@@ -0,0 +1,54 @@

1+name: Haskell CI

2+

3+on:

4+ push:

5+ branches: [master]

6+ pull_request:

7+ branches: [master]

8+

9+jobs:

10+ linux-build:

11+ runs-on: ubuntu-latest

12+

13+ steps:

14+ - uses: actions/checkout@v2

15+ with:

16+ submodules: recursive

17+ - name: Cache

18+ uses: actions/cache@v1

19+ with:

20+ path: ~/.stack

21+ key: ${{ runner.os }}-build-stack-${{ hashFiles('**/stack.yaml') }}-${{ hashFiles('**/*.cabal') }}

22+ restore-keys: |

23+ ${{ runner.os }}-build-stack-${{ hashFiles('**/stack.yaml') }}

24+ ${{ runner.os }}-build-stack-

25+ - name: Increase swap

26+ run: |

27+ free -h

28+

29+ sudo swapoff /mnt/swapfile

30+ sudo fallocate -l 12G /mnt/swapfile

31+ sudo mkswap /mnt/swapfile

32+ sudo swapon /mnt/swapfile

33+

34+ free -h

35+

36+ - name: Build

37+ run: |

38+ stack build --ghc-options=-O3 --local-bin-path openapi-diff-linux --copy-bins --flag openapi-diff:Static

39+ - name: Test

40+ run: stack test --ghc-options=-O3 --flag openapi-diff:Static --test-arguments='--hide-successes --no-create'

41+

42+ - name: Zip

43+ if: github.ref == 'refs/heads/master'

44+ run: |

45+ zip openapi-diff-linux openapi-diff-linux/openapi-diff

46+ - uses: "marvinpinto/action-automatic-releases@latest"

47+ if: github.ref == 'refs/heads/master'

48+ with:

49+ repo_token: "${{ secrets.GITHUB_TOKEN }}"

50+ automatic_release_tag: "latest"

51+ prerelease: false

52+ title: "Pre-Release"

53+ files: |

54+ *.zip

.github/workflows/remove-artifacts.yamlnew file+17

@@ -0,0 +1,17 @@

1+name: Remove old artifacts

2+

3+on:

4+ schedule:

5+ - cron: '0 0 * * *'

6+jobs:

7+ remove-old-artifacts:

8+ runs-on: ubuntu-latest

9+ timeout-minutes: 10

10+

11+ steps:

12+ - name: Remove old artifacts

13+ uses: c-hive/gha-remove-artifacts@v1

14+ with:

15+ age: '7 days'

16+ skip-tags: true

17+ skip-recent: 10

CHANGELOG.md+1−1

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

11# Changelog

22

3−`comparest` uses [PVP Versioning][1].

3+`openapi-diff` uses [PVP Versioning][1].

44

55## 0.0.0.0

66

README.md+4−305

@@ -1,309 +1,8 @@

1−# CompaREST

1+# openapi-diff

22

3−[![Hackage](https://img.shields.io/hackage/v/comparest.svg?logo=haskell)](https://hackage.haskell.org/package/comparest)

4−[![Stackage Lts](http://stackage.org/package/comparest/badge/lts)](http://stackage.org/lts/package/comparest)

5−[![Stackage Nightly](http://stackage.org/package/comparest/badge/nightly)](http://stackage.org/nightly/package/comparest)

3+[![Hackage](https://img.shields.io/hackage/v/openapi-diff.svg?logo=haskell)](https://hackage.haskell.org/package/openapi-diff)

4+[![Stackage Lts](http://stackage.org/package/openapi-diff/badge/lts)](http://stackage.org/lts/package/openapi-diff)

5+[![Stackage Nightly](http://stackage.org/package/openapi-diff/badge/nightly)](http://stackage.org/nightly/package/openapi-diff)

66[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE)

77

88Compatibility checker for OpenAPI

9−# Quick Start Guide

10−

11−## Your situation

12−

13−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.)

14−

15−You have recently released version 1.0 and things are going great: user are downloading your app, servers are processing requests.

16−

17−You describe your API in a file `api-1.0.0.yaml`:

18−

19−```yaml

20−openapi: "3.0.0"

21−info:

22− version: 1.0.0

23− title: Swagger Petstore

24− license:

25− name: MIT

26−servers:

27− - url: https://example.com

28−paths:

29− /pets:

30− get:

31− parameters:

32− - name: limit

33− in: query

34− required: false

35− schema:

36− type: integer

37− maximum: 20

38− responses:

39− "200":

40− description: ""

41− headers:

42− x-next:

43− schema:

44− type: string

45− content:

46− application/json:

47− schema:

48− $ref: "#/components/schemas/Pets"

49− post:

50− requestBody:

51− content:

52− application/json:

53− schema:

54− $ref: "#/components/schemas/Pet"

55− responses:

56− "201":

57− description: ""

58−components:

59− schemas:

60− Pet:

61− type: object

62− required:

63− - id

64− - name

65− properties:

66− id:

67− type: integer

68− name:

69− type: string

70− minLength: 3

71− maxLength: 10

72− Pets:

73− type: array

74− items:

75− $ref: "#/components/schemas/Pet"

76−```

77−

78−## Evolving your product

79−

80−Enthused over your initial success you hurry to release a new and improved version of your API and mobile app.

81−

82−After a round of very intense programming you take a look at your new `api-1.1.0.yaml`:

83−

84−```yaml

85−openapi: "3.0.0"

86−info:

87− version: 1.1.0

88− title: Swagger Petstore

89− license:

90− name: MIT

91−servers:

92− - url: https://example.com

93−paths:

94− /pets:

95− get:

96− parameters:

97− - name: limit

98− in: query

99− required: false

100− schema:

101− type: integer

102− maximum: 30

103− responses:

104− "200":

105− description: ""

106− headers:

107− x-next:

108− schema:

109− type: string

110− content:

111− application/json:

112− schema:

113− $ref: "#/components/schemas/Pets"

114− post:

115− requestBody:

116− content:

117− application/json:

118− schema:

119− $ref: "#/components/schemas/Pet"

120− responses:

121− "201":

122− description: ""

123−components:

124− schemas:

125− Pet:

126− type: object

127− required:

128− - id

129− - name

130− properties:

131− id:

132− type: integer

133− name:

134− type: string

135− minLength: 1

136− maxLength: 15

137− weight:

138− type: integer

139− Pets:

140− type: array

141− items:

142− $ref: "#/components/schemas/Pet"

143−```

144−

145−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.

146−

147−## Assessing compatibility automatically

148−

149−Luckily, you have access to compaREST which can programmatically analyze your APIs and determine what, if anything, breaks compatibility and what doesn't.

150−

151−You can call it, passing the API your client will be aware of, and the API your server will serve like so:

152−

153−```bash

154−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

155−```

156−

157−Running this command will output a file `report.md`, containing the compatibility report between the two APIs:

158−

159−> # Summary

160−>

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

162−> |------------------------------------------|-------------------------------------------------|-------------------------------|

163−> | 5 | 6 | 0 |

164−>

165−> # ⚠️ Breaking changes

166−>

167−> ## **GET** /pets

168−>

169−> ### 📱⬅️ JSON Response – 200

170−>

171−> #### `$[*].name(String)`

172−>

173−> 1. Maximum length of the string changed from 10 to 15.

174−>

175−> 2. Minimum length of the string changed from 3 to 1.

176−>

177−> ## **POST** /pets

178−>

179−> ### 📱➡️ JSON Request

180−>

181−> #### `$.weight`

182−>

183−> 1. Values are now limited to the following types:

184−>

185−> - Number

186−>

187−> 2. The property was previously implicitly described by the catch-all

188−> "additional properties" case. It is now explicitly defined.

189−>

190−> #### `$.weight(Number)`

191−>

192−> Value is now a multiple of 1.0.

193−>

194−> # 🙆 Non-breaking changes

195−>

196−> ## **GET** /pets

197−>

198−> ### Parameter limit

199−>

200−> #### JSON Schema

201−>

202−> ##### `$(Number)`

203−>

204−> Upper bound changed from 20.0 inclusive to 30.0 inclusive.

205−>

206−> ### 📱⬅️ JSON Response – 200

207−>

208−> #### `$[*].weight`

209−>

210−> 1. Values are now limited to the following types:

211−>

212−> - Number

213−>

214−> 2. The property was previously implicitly described by the catch-all

215−> "additional properties" case. It is now explicitly defined.

216−>

217−> #### `$[*].weight(Number)`

218−>

219−> Value is now a multiple of 1.0.

220−>

221−> ## **POST** /pets

222−>

223−> ### 📱➡️ JSON Request

224−>

225−> #### `$.name(String)`

226−>

227−> 1. Maximum length of the string changed from 10 to 15.

228−>

229−> 2. Minimum length of the string changed from 3 to 1.

230−

231−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.

232−

233−## Additional formats

234−

235−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:

236−

237−```bash

238−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

239−```

240−

241−# CLI docs

242−

243−```

244−Usage: comparest (-c|--client ARG) (-s|--server ARG)

245− [--silent | --only-breaking | --all] [-o|--output ARG]

246− [--folding-block-quotes-style | --header-style]

247− [--signal-exit-code]

248− A tool to check compatibility between two OpenAPI specifications.

249−

250− Usage examples

251−

252− Compare files old.yaml with new.yaml and output the resulting report to

253− stdout:

254−

255− comparest -c old.yaml -s new.yaml

256−

257− Only output breaking changes and write a styled HTML report to file

258− report.html:

259−

260− comparest -c old.yaml -s new.yaml --only-breaking -o report

261−

262− Don't output anything, only fail if there are breaking changes:

263−

264− comparest -c old.json -s new.json --silent

265−

266− Write full report suitable for embedding into a GitHub comment to

267− report.html:

268−

269− comparest -c old.json -s new.json --folding-block-quotes-style -o report.html

270−

271−Available options:

272− -h,--help Show this help text

273− -c,--client ARG A path to the file containing the specification that

274− will be used for the client of the API. Can be either

275− a YAML or JSON file.

276− -s,--server ARG A path to the file containing the specification that

277− will be used for the server of the API. Can be either

278− a YAML or JSON file.

279− --silent Silence all output. Only makes sense in combination

280− with --signal-exit-code.

281− --only-breaking Only report breaking changes in the output.

282− --all Report both incompatible and compatible changes.

283− Compatible changes will not trigger a failure exit

284− code.

285− -o,--output ARG The file path where the output should be written. If

286− the option is omitted the result will be written to

287− stdout.

288−

289− The file extension is used to determine the type of

290− the output file.

291−

292− Supports many formats such as markdown, html, rtf,

293− doc, txt, rst, and many more.

294−

295− Leave out the extension to produce a self-contained

296− HTML report with styling.

297− --folding-block-quotes-style

298− The report tree is structured using summary/detail

299− HTML elements and indented using block quotes. This

300− style renders well on GitHub.Intended for HTML output

301− format. Markdown has rendering bugs on GitHub.

302− --header-style The report tree is structured using increasing levels

303− of headers.

304− --signal-exit-code Signal API compatibility with the exit code.

305−

306− Exit with 0 if there are no breaking changes.

307− Exit with 1 if there are breaking changes.

308− Exit with 2 if could not determine compatibility.

309−```

action.yamldeleted−47

@@ -1,47 +0,0 @@

1−name: compaREST

2−author: Typeable

3−description: API reliability checker

4−inputs:

5− GITHUB_TOKEN:

6− description: "The GitHub access token (e.g. secrets.GITHUB_TOKEN) used to create or update the comment. This defaults to {{ github.token }}."

7− default: "${{ github.token }}"

8− required: false

9− repo:

10− description: The owner of the repo in which to post the comment.

11− default: "${{ github.repository }}"

12− required: false

13− project_name:

14− description: The name of the project to which the API pertains.

15− required: true

16− footer:

17− description: A footer that can be appended to the comment.

18− required: false

19− default: ""

20− old:

21− description: The path to old specification of the API.

22− required: true

23− new:

24− description: The path to new specification of the API.

25− required: true

26− sha:

27− description: The sha of the commit to post the check for.

28− required: false

29− default: "${{ github.event.pull_request.head.sha }}"

30−runs:

31− using: "docker"

32− image: "docker://typeable/comparest-github-action:0.0.0.0"

33− env:

34− GITHUB_TOKEN: "${{ inputs.GITHUB_TOKEN }}"

35− REPO: "${{ inputs.repo }}"

36− PROJECT_NAME: "${{ inputs.project_name }}"

37− FOOTER: "${{ inputs.footer }}"

38− ROOT: "/github/workspace"

39− OLD: "${{ inputs.old }}"

40− NEW: "${{ inputs.new }}"

41− SHA: "${{ inputs.sha }}"

42− pre-entrypoint: "/bin/pre"

43− entrypoint: "/bin/run"

44−

45−branding:

46− icon: crosshair

47− color: gray-dark

app/Data/OpenApi/Compare/Options.hsdeleted−134

@@ -1,134 +0,0 @@

1−module Data.OpenApi.Compare.Options

2− ( Options (..),

3− OutputMode (..),

4− parseOptions,

5− )

6−where

7−

8−import Data.OpenApi.Compare.Report

9−import GHC.Generics (Generic)

10−import Options.Applicative

11−import Options.Applicative.Help hiding (fullDesc)

12−

13−parseOptions :: IO Options

14−parseOptions = customExecParser (prefs $ showHelpOnError) optionsParserInfo

15−

16−data Options = Options

17− { clientFile :: FilePath

18− , serverFile :: FilePath

19− , -- | 'Nothing' means "don't produce any output"

20− mode :: Maybe ReportMode

21− , outputMode :: OutputMode

22− , reportTreeStyle :: ReportTreeStyle

23− , signalExitCode :: Bool

24− }

25− deriving stock (Generic)

26−

27−data OutputMode = StdoutMode | FileMode FilePath

28−

29−optionsParserInfo :: ParserInfo Options

30−optionsParserInfo =

31− info

32− (helper <*> optionsParser)

33− ( fullDesc

34− <> header "CompaREST"

35− <> progDescDoc

36− ( Just $

37− par "A tool to check compatibility between two OpenAPI specifications."

38− <$$> hardline <> par "Usage examples" <> hardline

39− <$$> indent

40− 4

41− ( par "Compare files old.yaml with new.yaml and output the resulting report to stdout:"

42− <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml"

43− <$$> hardline <> par "Only output breaking changes and write a styled HTML report to file report.html:"

44− <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml --only-breaking -o report"

45− <$$> hardline <> par "Don't output anything, only fail if there are breaking changes:"

46− <$$> hardline <> indent 4 "comparest -c old.json -s new.json --silent"

47− <$$> hardline <> par "Write full report suitable for embedding into a GitHub comment to report.html:"

48− <$$> hardline <> indent 4 "comparest -c old.json -s new.json --folding-block-quotes-style -o report.html"

49− )

50− )

51− )

52−

53−optionsParser :: Parser Options

54−optionsParser =

55− Options

56− <$> strOption

57− ( short 'c'

58− <> long "client"

59− <> help

60− "A path to the file containing the specification that will be \

61− \used for the client of the API. Can be either a YAML or JSON file."

62− )

63− <*> strOption

64− ( short 's'

65− <> long "server"

66− <> help

67− "A path to the file containing the specification that will be \

68− \used for the server of the API. Can be either a YAML or JSON file."

69− )

70− <*> ( flag'

71− Nothing

72− ( long "silent"

73− <> help "Silence all output. Only makes sense in combination with --signal-exit-code."

74− )

75− <|> flag'

76− (Just OnlyErrors)

77− ( long "only-breaking"

78− <> help "Only report breaking changes in the output."

79− )

80− <|> flag'

81− (Just All)

82− ( long "all"

83− <> help

84− "Report both incompatible and compatible changes. \

85− \Compatible changes will not trigger a failure exit code."

86− )

87− <|> pure (Just All)

88− )

89− <*> ( ( FileMode

90− <$> strOption

91− ( short 'o' <> long "output"

92− <> helpDoc

93− ( Just $

94− par "The file path where the output should be written. If the option is omitted the result will be written to stdout."

95− <$$> hardline <> par "The file extension is used to determine the type of the output file."

96− <$$> hardline <> par "Supports many formats such as markdown, html, rtf, doc, txt, rst, and many more."

97− <$$> hardline <> par "Leave out the extension to produce a self-contained HTML report with styling."

98− )

99− )

100− )

101− <|> pure StdoutMode

102− )

103− <*> ( flag'

104− FoldingBlockquotesTreeStyle

105− ( long "folding-block-quotes-style"

106− <> help

107− "The report tree is structured using \

108− \summary/detail HTML elements and indented using \

109− \block quotes. This style renders well on GitHub.\

110− \Intended for HTML output format. Markdown has rendering \

111− \bugs on GitHub."

112− )

113− <|> flag'

114− HeadersTreeStyle

115− ( long "header-style"

116− <> help

117− "The report tree is structured using \

118− \increasing levels of headers."

119− )

120− <|> pure HeadersTreeStyle

121− )

122− <*> switch

123− ( long "signal-exit-code"

124− <> helpDoc

125− ( Just $

126− par "Signal API compatibility with the exit code."

127− <$$> hardline <> par "Exit with 0 if there are no breaking changes."

128− <$$> par "Exit with 1 if there are breaking changes."

129− <$$> par "Exit with 2 if could not determine compatibility."

130− )

131− )

132−

133−par :: String -> Doc

134−par = foldr1 (</>) . fmap string . words

app/FormatHeuristic.hs+3−3

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

22-- Originally based on:

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

44module FormatHeuristic

5− ( formatFromFilePath,

5+ ( formatFromFilePath

66 )

77where

88

@@ -10,10 +10,10 @@ import Data.ByteString.Lazy (ByteString)

1010import Data.Char (toLower)

1111import Data.Functor

1212import qualified Data.Map as M

13−import qualified Data.OpenApi.Compare.Report.Html.Template as Html

1413import Data.Text (Text)

1514import qualified Data.Text.Lazy as TL

1615import qualified Data.Text.Lazy.Encoding as TL

16+import qualified OpenAPI.Checker.Report.Html.Template as Html

1717import System.FilePath (takeExtension)

1818import Text.DocTemplates.Internal

1919import Text.Pandoc

@@ -80,7 +80,7 @@ formatFromFilePath x =

8080 def

8181 { writerTemplate = Just Html.template

8282 , -- Not actually used. Needed to silence warning.

83− writerVariables = Context $ M.fromList [("pagetitle", toVal ("CompaREST" :: Text))]

83+ writerVariables = Context $ M.fromList [("pagetitle", toVal ("OpenApi Diff" :: Text))]

8484 }

8585 _ -> Nothing

8686 where

app/Main.hs+8−10

@@ -6,19 +6,18 @@ import Data.Aeson

66import qualified Data.ByteString.Lazy as BSL

77import Data.Default

88import Data.Maybe

9−import Data.OpenApi.Compare.Options

10−import Data.OpenApi.Compare.Run

119import qualified Data.Text.IO as T

1210import qualified Data.Yaml as Yaml

1311import FormatHeuristic

12+import OpenAPI.Checker.Options

13+import OpenAPI.Checker.Run

1414import System.Exit

1515import System.IO

1616import Text.Pandoc hiding (report)

17−import Text.Pandoc.Builder

1817

1918main :: IO ()

2019main = do

21− opts <- parseOptions

20+ opts <- execParser optionsParserInfo

2221 let parseSchema path =

2322 eitherDecodeFileStrict path >>= \case

2423 Left jsonErr -> do

@@ -48,13 +47,12 @@ main = do

4847 }

4948 (report, status) = runReport reportConfig (a, b)

5049 case mode opts of

51− Just _ -> either handler pure <=< runExceptT $ write $ doc report

50+ Just _ -> either handler pure <=< runExceptT $ write report

5251 Nothing -> pure ()

53− when (signalExitCode opts) $

54− case status of

55− NoBreakingChanges -> exitSuccess

56− BreakingChanges -> exitWith $ ExitFailure 1

57− OnlyUnsupportedChanges -> exitWith $ ExitFailure 2

52+ case status of

53+ NoBreakingChanges -> exitSuccess

54+ BreakingChanges -> exitWith $ ExitFailure 1

55+ OnlyUnsupportedChanges -> exitWith $ ExitFailure 2

5856

5957data Errors

6058 = DocumentError PandocError

app/OpenAPI/Checker/Options.hsnew file+81

@@ -0,0 +1,81 @@

1+module OpenAPI.Checker.Options

2+ ( Options (..)

3+ , OutputMode (..)

4+ , optionsParserInfo

5+ , execParser

6+ )

7+where

8+

9+import GHC.Generics (Generic)

10+import OpenAPI.Checker.Report

11+import Options.Applicative

12+

13+data Options = Options

14+ { clientFile :: FilePath

15+ , serverFile :: FilePath

16+ , -- | 'Nothing' means "don't produce any output"

17+ mode :: Maybe ReportMode

18+ , outputMode :: OutputMode

19+ , reportTreeStyle :: ReportTreeStyle

20+ }

21+ deriving stock (Generic)

22+

23+data OutputMode = StdoutMode | FileMode FilePath

24+

25+optionsParserInfo :: ParserInfo Options

26+optionsParserInfo =

27+ info

28+ (helper <*> optionsParser)

29+ (fullDesc

30+ <> header "openapi-diff"

31+ <> progDesc "A tool to check compatibility between two OpenApi specifications.")

32+

33+optionsParser :: Parser Options

34+optionsParser =

35+ Options

36+ <$> strOption

37+ (short 'c'

38+ <> long "client"

39+ <> help "The specification that will be used for the client of the API.")

40+ <*> strOption

41+ (short 's'

42+ <> long "server"

43+ <> help "The specification that will be used for the server of the API.")

44+ <*> (flag'

45+ Nothing

46+ (long "silent"

47+ <> help "Silence all output.")

48+ <|> flag'

49+ (Just OnlyErrors)

50+ (long "only-errors"

51+ <> help "Only report incompatibility errors in the output.")

52+ <|> flag'

53+ (Just All)

54+ (long "all"

55+ <> help

56+ "Report both incompatible and compatible changes. \

57+ \Compatible changes will not trigger a failure exit code.")

58+ <|> pure (Just All))

59+ <*> ((FileMode

60+ <$> strOption

61+ (short 'o' <> long "output"

62+ <> help

63+ "The file path where the output should be writtrn. \

64+ \Leave blank to output result to stdout."))

65+ <|> pure StdoutMode)

66+ <*> (flag'

67+ FoldingBlockquotesTreeStyle

68+ (long "folding-block-quotes-style"

69+ <> help

70+ "The report tree is structured using \

71+ \summary/detail HTML elements and indented using \

72+ \block quotes. This style renders well on GitHub.\

73+ \Intended for HTML output format. Markdown has rendering \

74+ \bugs on GitHub.")

75+ <|> flag'

76+ HeadersTreeStyle

77+ (long "header-style"

78+ <> help

79+ "The report tree is structured using \

80+ \increasing levels of headers.")

81+ <|> pure HeadersTreeStyle)

benchmarks/README.md+2−2

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

11# OpenApi comparison benchmarks

22

3−This is a nix expression that automatically downloads, builds and runs multiple OpenAPI comparison tools on the same set of inputs to compare how well they behave.

3+This is a nix expression that automatically downloads, builds and runs multiple OpenApi comparison tools on the same set of inputs to compare how well they behave.

44

55To run the benchmarks run the following command in this directory:

66

@@ -12,7 +12,7 @@ nix-build

1212

1313| Tool | Output file name |

1414| -------------------------------------------------------------------------- | ------------------------------------------- |

15−| [Typeable CompaREST](https://github.com/typeable/compaREST) | `typeable.md` |

15+| [Typeable OpenApi Diff](https://github.com/typeable/openapi-diff) | `typeable.md` |

1616| [Atlassian OpenApi Diff](https://bitbucket.org/atlassian/openapi-diff) | `atlassian.json`, `atlassian.error.txt` |

1717| [OpenApi Tools OpenApi Diff](https://github.com/OpenAPITools/openapi-diff) | `openapitools.md`, `openapitools.error.txt` |

1818| [Tufin OpenApi Diff](https://github.com/tufin/oasdiff) | `oasdiff.txt`, `oasdiff.error.txt` |

benchmarks/default.nix+12−8

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

11{ sources ? import ./nix/sources.nix

2+, haskellNix ? import sources.haskellNix { }

23, gomod2nix ? sources.gomod2nix

3−, haskellNix ? (import ../. {}).haskellNix

44, pkgs ? import haskellNix.sources.nixpkgs-2105 (haskellNix.nixpkgsArgs // {

55 overlays = haskellNix.nixpkgsArgs.overlays ++ [

66 (self: super: {

@@ -8,19 +8,23 @@

88 })

99 ];

1010 })

11−, compaRESThsPkgs ? (import ../. {}).hsPkgs

1211, npmNix ? import (sources.npmNix + "/npmPackages") { inherit pkgs; }

1312, mavenix ? import (sources.mavenix) { inherit pkgs; }

1413, bumpToken ? null

1514, bumpDocumentation ? null

1615}:

1716let

18− typeable-comparest = compaRESThsPkgs.comparest.components.exes.comparest;

19− typeable-comparest-exe = typeable-comparest + "/bin/comparest";

20− typeable-comparest-differ = pkgs.writeScript "typeable-comparest-differ" ''

17+ typeable-openapi-diff = (pkgs.haskell-nix.stackProject {

18+ src = pkgs.haskell-nix.haskellLib.cleanGit {

19+ name = "openapi-diff";

20+ src = ./..;

21+ };

22+ }).openapi-diff.components.exes.openapi-diff;

23+ typeable-openapi-diff-exe = typeable-openapi-diff + "/bin/openapi-diff";

24+ typeable-openapi-diff-differ = pkgs.writeScript "typeable-openapi-diff-differ" ''

2125 #!${pkgs.stdenv.shell}

2226 set +e

23− ${typeable-comparest-exe} -c $1 -s $2 -o $3/typeable.md

27+ ${typeable-openapi-diff-exe} -c $1 -s $2 -o $3/typeable.md

2428 exit 0

2529 '';

2630

@@ -126,7 +130,7 @@ let

126130 })

127131 (getInputs root);

128132 differs = [

129− typeable-comparest-differ

133+ typeable-openapi-diff-differ

130134 atlassian-openapi-diff-differ

131135 openapitools-openapi-diff-differ

132136 oasdiff-differ

@@ -160,7 +164,7 @@ let

160164 tools = [

161165 "Typeable"

162166 "Atlassian"

163− "OpenAPI Tools"

167+ "OpenApi Tools"

164168 "oasdiff"

165169 "Bump.sh"

166170 ];

ci/policeman.nixdeleted−4

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

1−{ sources ? import ../nix/sources.nix

2−, pkgs ? import sources.nixpkgs { }

3−}:

4−pkgs.haskellPackages.policeman

default.nixdeleted−114

@@ -1,114 +0,0 @@

1−{ sources ? import ./nix/sources.nix

2−, haskellNix ? import sources.haskellNix { inherit system; }

3−, pkgs ? import haskellNix.sources.nixpkgs-2105 (haskellNix.nixpkgsArgs // { inherit system; })

4−, system ? builtins.currentSystem

5−, nix-filter ? import sources.nix-filter

6−}:

7−let

8− masterPkgs = import sources.nixpkgs { inherit system; };

9−

10− hsPkgs = pkgs.haskell-nix.stackProject {

11− src = nix-filter {

12− root = ./.;

13− name = "compaREST";

14− include = [

15− ./stack.yaml

16− ./stack.yaml.lock

17− ./compaREST.cabal

18− ];

19− };

20−

21− modules = [

22− {

23− dontStrip = false;

24− dontPatchELF = false;

25− enableDeadCodeElimination = true;

26− ghcOptions = [

27− "-O2"

28− "-fexpose-all-unfoldings"

29− "-fspecialise-aggressively"

30− ];

31− packages.pandoc.ghcOptions = [ "-O1" ];

32− packages.compaREST.src = nix-filter {

33− root = ./.;

34− name = "compaREST-src";

35− include = with nix-filter; [

36− (./compaREST.cabal)

37− (inDirectory ./test)

38− (inDirectory ./src)

39− (inDirectory ./app)

40− (inDirectory ./github-action)

41− ./awsm-css/dist/awsm.min.css

42− ./LICENSE

43− ];

44− };

45− }

46− ];

47− };

48−

49− staticify = name: drv: pkgs.runCommand name { } ''

50− mkdir -p $out/bin

51− cp ${drv + "/bin"}/* $out/bin

52−

53− ${pkgs.nukeReferences}/bin/nuke-refs $out/bin/*

54− '';

55−

56− compaRESTBin = hsPkgs.compaREST.components.exes.compaREST;

57− compaRESTStaticBin = (staticify "compaREST-static" hsPkgs.projectCross.musl64.hsPkgs.compaREST.components.exes.compaREST);

58−

59−

60− # doesn't work

61− armDarwinCompaREST = hsPkgs.projectCross.aarch64-darwin.hsPkgs.compaREST.components.exes.compaREST;

62−

63− compaRESTImage = pkgs.dockerTools.buildImage {

64− name = "compaREST";

65− contents = [ compaRESTStaticBin ];

66− config = {

67− Entrypoint = [ "/bin/compaREST" ];

68− };

69− };

70−

71− macOSCompaRESTBundle = pkgs.runCommand "compaREST-macOS-bundled"

72− {

73− buildInputs = [ masterPkgs.macdylibbundler ];

74− } ''

75− mkdir -p $out/lib

76− cp ${compaRESTBin}/bin/compaREST $out/compaREST

77− chmod 755 $out/compaREST

78− dylibbundler -b \

79− -x $out/compaREST \

80− -d $out/lib \

81− -p '@executable_path/lib'

82− '';

83−

84−

85− compaRESTGithubAction =

86− let

87− action = staticify "compaREST-GitHub-Action-static" hsPkgs.projectCross.musl64.hsPkgs.compaREST.components.exes.compaREST-GitHub-Action;

88− wrapped = pkgs.runCommand "wrapped-compaREST-GitHub-Action" { buildInputs = [ pkgs.makeWrapper ]; } ''

89− makeWrapper ${action}/bin/compaREST-GitHub-Action $out/bin/pre --add-flags "pre"

90− makeWrapper ${action}/bin/compaREST-GitHub-Action $out/bin/run --add-flags "run"

91− '';

92− in

93− pkgs.dockerTools.buildImage {

94− name = "typeable/compaREST-GitHub-Action";

95− tag = "latest";

96− contents = [ wrapped pkgs.cacert ];

97− };

98−

99− WindowsCompaRESTBin = hsPkgs.projectCross.mingwW64.hsPkgs.compaREST.components.exes.compaREST;

100−in

101−{

102− inherit

103− compaRESTImage

104− compaRESTGithubAction

105− compaRESTStaticBin

106− compaRESTBin

107− hsPkgs

108− macOSCompaRESTBundle

109− WindowsCompaRESTBin;

110−

111− # We use the static version so that we don't have to rebuild everything on CI.

112− # The only binaries build on CI are static.

113− test = hsPkgs.projectCross.musl64.hsPkgs.compaREST.components.tests.compaREST-tests;

114−}

docs/Development_guide.mddeleted−149

@@ -1,149 +0,0 @@

1−CompaREST

2−=========

3−The tool works by simultaneously looking at a pair of nodes in OpenAPI schema

4−trees. At every place we try to understand whether one side (the producer) can

5−produce something that the other side (the consumer) cannot consume. This often

6−involves recursively running the same check on child sub-nodes. The necessary

7−criteria are implemented manually for all types of nodes that appear in the

8−schema. The `Subtree` class in `Data.OpenApi.Compare.Subtree` designates types

9−of nodes for which this compatibility checking is defined. The implementations

10−for various types reside in `Data.OpenApi.Compare.Validate.*`.

11−

12−Producer/Consumer

13−-----------------

14−Rather than looking at which schema is the server's and which is the client's,

15−in terms of compatibility checking it is more useful to track which side is the

16−"producer" and which is the "consumer". At the root of the schema the producer

17−is the client, but as we descend into an HTTP response, the direction flips and

18−the producer becomes the server.

19−

20−We deal with a lot of things in pairs, where one thing belongs to the producer

21−and another belongs to the consumer. The `ProdCons` datatype (in

22−`Data.OpenApi.Compare.Subtree`) is just a pair type that provides an Applicative

23−abstraction for working with two things simultaneously.

24−

25−Trees

26−-----

27−We directly use the datatypes defined in the `openapi3` library. For reasons of

28−identifiability and memoization we tag all nodes in the trees with a path from

29−the root. The tree is heterogeneous (nodes have different types), and every type

30−of node has a different arrangement of children. There is a `Step` data family

31−that defines all the possible children (of a specific type) of a node (of a

32−specific type).

33−

34−A `Trace` is a sequence of steps, except in a path the types of adjacent steps

35−have to agree. The `Paths` datatype achieves this. Together all paths form a

36−`Category`, and we often concatenate them using `>>>`. This is defined in

37−`Data.OpenApi.Compare.Paths`.

38−

39−We often keep a node and a path to it next to each other using an environment

40−comonad. `Traced` is a type alias around `Env` which ensures that the type of

41−the path matches the type of the node.

42−

43−Issues

44−------

45−The output of the tool is a list of compatibility issues that came up during

46−checking. The `Issue` data family describes the kinds of issues that can occur

47−at each type of node. An issue is supposed to characterize a set of interactions

48−(requests or responses) that demonstrate that the schemas are incompatible.

49−

50−Each issue is tagged with a `Behavior` that describes the path to reproducing

51−the issue. While a `Trace` describes a syntactic path down the schema tree, a

52−`Behavior` describes which part of an interaction needs to be focused on for the

53−issue to manifest itself.

54−

55−In most places where we keep multiple issues (e.g. the output), to store them we

56−use a prefix tree map, indexed by both types and values of `Behavior`s. See

57−`Data.OpenApi.Compare.PathsPrefixTree`.

58−

59−Report

60−------

61−The checker ultimately outputs a list of `Issue`s, together with `Behavior`s

62−that cause them. We run the checker twice: forwards and backwards -- to detect

63−non-breaking changes. All of this is then compiled into a report in

64−`Data.OpenApi.Compare.Report`. The tree structure of headings is computed from

65−`Behavior`s, using `Jet`s to collapse particular sequences of behavior steps

66−into a single human-readable header item. The text of each paragraph comes from

67−`describeIssue`.

68−

69−We then use the `pandoc` library to render the report in a variety of formats.

70−

71−Formulas

72−--------

73−The schema has references, so it can end up being recursive. Similarly the

74−process for establishing compatibility can end up being recursive. To keep track

75−of this, the checker actually manipulates *formulas* which can have variables in

76−them, defined in (`Data.OpenApi.Compare.Formula`).

77−

78−A formula represents a set of issues, with the empty set corresponding to a

79−successful compatibility check. A formula can have conjunctions, where we only

80−report success if all parts succeeded, and if not we take the union of all

81−issues. A formula can also have disjunctions, but there it's impossible to

82−guarantee that the issues for the parts also make sense as issues for the whole

83−thing. Due to this if all disjuncted parts have issues we instead return a

84−different issue (usually non-descriptive).

85−

86−The `FormulaF` datatype implements a functor that carries formulaic calculations

87−as well as a result value (a co-Yoneda extension of formulas for the most part).

88−The Applicative interface provides conjunction, and the Alternative interface

89−provides disjunction.

90−

91−When we detect recursion we introduce a variable, compute the compatibility

92−check as a formula with that variable, and then we solve a fixed point equation

93−(`maxFixpoint`) with the variable to obtain the answer.

94−

95−This `FomulaF` is further wrapped in a couple monad transformers

96−(`SemanticCompatFormula`, `StructuralCompatFormula`), and the whole checker is

97−then implemented in the resulting Applicative using ApplicativeDo.

98−

99−Memoization

100−-----------

101−The `Data.OpenApi.Compare.Memo` module contains utilities for stateful

102−memoization and recursion detection. The entire checking process is memoized,

103−and can detect, propagate, and resolve recursion.

104−

105−Structural/Semantic Compatibility

106−---------------------------------

107−When we encounter two nodes we first try to optimistically establish whether

108−they're structurally equal, i.e. the trees are exactly the same modulo reference

109−inlining. This check is also memoized and recursion-aware. If the check succeeds

110−we conclude that the schemas are compatible. Otherwise we fall back to the

111−"normal" semantic compatibility.

112−

113−

114−JSON Schema

115−-----------

116−The language that describes JSON payloads is probably the richest part of

117−OpenAPI schemas, and the checker for it also comes with a lot of moving parts.

118−

119−JSON schema allows arbitrary set arithmetic using `allOf`, `anyOf`, `not` and

120−`oneOf`. To fully check `not` and `oneOf` we would need to compare set

121−subtraction, which involves negating a comparison result. If recursion is

122−involved we would need to be able to solve equations with negation, which we

123−cannot do. So `not` is unsupported altogether, and `oneOf` is only supported

124−when it has disjoint branches and behaves like `anyOf`.

125−

126−With that in mind a JSON schema is first pre-processed into a Disjunctive Normal

127−Form (`DNF` in `Data.OpenApi.Compare.Validate.Schema.DNF`). This pre-processing

128−happens in `Data.OpenApi.Compare.Validate.Schema.Process`.

129−

130−The DNF contains elementary clauses that match on a specific aspect of a JSON

131−object (`Condition`). Most clauses only affect objects of a single type, so JSON

132−values and clauses are segregated by type (`JsonType`, `TypedValue` in

133−`Data.OpenApi.Compare.Validate.Schema.JsonFormula`)

134−

135−Then we reduce the problem of comparing two DNF's to the comparison of a

136−conjunction of clauses in the producer with a single clause in the consumer

137−(`checkFormulas` in `Data.OpenApi.Compare.Validate.Schema`).

138−

139−When we do disjunction in the formula we lose information, so we try to avoid

140−having disjunctions in the consumer DNF. This is done by the means of

141−partitioning. We look for factors that would let us partition the set of all

142−objects into several bins, in a way that hopefully corresponds only a single

143−consumer to each producer. This is implemented in

144−`Data.OpenApi.Compare.Validate.Schema.Partition`. Currently we can only

145−partition by an `enum` value that is accessible via a chain of `required`

146−fields.

147−

148−The same partitioning mechanism is used to test whether the branches of a

149−`oneOf` are disjoint, and emit a warning otherwise.

docs/Integration_guide.mddeleted−51

@@ -1,51 +0,0 @@

1−# Integration guide

2−

3−## Github Actions

4−

5−In cases where your OpenAPI spec can be generated from your code, it can be useful to see how a pull request changes your API. For this very purpose we have a Github Action.

6−

7−### Generating the inputs

8−

9−To use it you need to first get the old (before the pull request) and new (after the pull request) specs.

10−

11−For example:

12−

13−- To get the old spec you can:

14− - Download from a public "production" server (if your api is public and you provide an OpenAPI spec)

15− - Checkout the base commit of the pull request and generate is programmatically.

16−

17− You can checkout the base commit like so in Github Actions:

18−

19− ```bash

20− git checkout $(git merge-base ${{ github.event.pull_request.head.sha }} ${{ github.event.pull_request.base.sha }})

21− ```

22−- To get the new spec you can:

23− - Build and run the spec generation for the head commit of the pull request

24−

25−### Run the action

26−

27−In our example we have already generated the two OpenAPI specs and placed them in the `old-openapi.yaml` and `new-openapi.yaml` files.

28−

29−We can now run our action:

30−

31−##### NOTE: will only work after public release

32−

33−```yaml

34−- uses: typeable/comparest

35− with:

36− old: old-openapi.yaml

37− new: new-openapi.yaml

38− project_name: TEST

39−```

40−

41−This will create a check on the pull request displaying the changes (if there are any) similar to this:

42−

43−![](img/github-action-report.png)

44−

45−The check will show success when there are no breaking changes, and be neutral otherwise.

46−

47−## Integrating into something other than Github Actions

48−

49−We have a dedicated implementation only for Github Actions. However, we provide a generic CLI which can be used to integrate compaREST into arbitrary workflows and CI systems.

50−

51−You see an example of CLI usage in our [readme](../README.md#assessing-compatibility-automatically).

docs/User_guide.mddeleted−51

@@ -1,51 +0,0 @@

1−CompaREST User Guide

2−====================

3−

4−Running the Tool

5−----------------

6−The tool accepts two OpenAPI 3.0.0 schema files in either JSON or YAML format.

7−One is assumed to be the client version of the schema, and the other is the

8−server version.

9−

10−The tool will look for changes between the schemas and detect whether they are

11−breaking or not -- that is, if they prevent interoperability between the client

12−and the server.

13−

14−Running:

15−```

16−comparest -c client.json -s server.json

17−```

18−will output a markdown report of the changes to the standard output.

19−

20−Compatibility status can be signaled via the exit code using

21−`--signal-exit-code`. In case no report is needed, output can be suppressed with

22−`--silent`. For example:

23−```

24−comparest -c client.json -s server.json --signal-exit-code --silent

25−echo $?

26−```

27−If there were changes that the tool determined to be breaking, the exit code

28−will be 1. If there were some changes the tool couldn't understand, the exit

29−code will be 2. Otherwise if there were no breaking changes, the exit code will

30−be 0.

31−

32−Controlling the Report

33−----------------------

34−By default the report includes breaking changes, as well as non-breaking:

35−changes that would be considered breaking in the opposite direction. To only

36−include breaking changes in the report use `--only-breaking`. The `--all` option

37−restores the default behavior.

38−

39−The report can be formatted in a variety of ways supported by Pandoc. The `-o`

40−option causes the report to be written to a file. The format of the file is

41−determined from the extension. The supported extensions include:

42− - `.md` for markdown

43− - `.html` for an HTML snippet

44− - `.rst` for restructured text

45− - no extension for a self-contained HTML document with styles

46−

47−By default the report is split up into parts relating to different paths,

48−requests, responses, etc, using headers of various levels. Alternatively, the

49−report can use indended block-quotes to visualize the tree structure of the

50−report. The header style is enabled with `--header-style`, and the block-quote

51−style is enabled with `--folding-block-quotes-style`.

docs/img/github-action-report.pngdeleted

Binary file not shown.

fourmolu.yamldeleted−8

@@ -1,8 +0,0 @@

1−indentation: 2

2−comma-style: leading # for lists, tuples etc. - can also be 'trailing'

3−record-brace-space: true # rec {x = 1} vs. rec{x = 1}

4−indent-wheres: true # 'false' means save space by only half-indenting the 'where' keyword

5−diff-friendly-import-export: false # 'false' uses Ormolu-style lists

6−respectful: true # don't be too opinionated about newlines etc.

7−haddock-style: single-line # '--' vs. '{-'

8−newlines-between-decls: 1 # number of newlines between top-level declarations

github-action/CompaREST/GitHub/API.hsdeleted−86

@@ -1,86 +0,0 @@

1−module CompaREST.GitHub.API

2− ( postStatus,

3− postStatusProcessing,

4− )

5−where

6−

7−import CompaREST.GitHub.Action.Config

8−import Control.Monad.Freer

9−import Control.Monad.Freer.GitHub

10−import Control.Monad.Freer.Reader

11−import Control.Monad.IO.Class

12−import Data.Aeson

13−import qualified Data.ByteString.Lazy.Char8 as BSLC

14−import Data.OpenApi.Compare.Report

15−import Data.Proxy

16−import Data.Text (Text)

17−import GitHub

18−import GitHub.Data.Checks

19−import GitHub.Endpoints.Checks

20−

21−postStatusProcessing ::

22− (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>

23− Eff effs ()

24−postStatusProcessing = do

25− Config {..} <- ask

26− printJSON $

27− sendGitHub $

28− checkR

29− repoOwner

30− repoName

31− Check

32− { checkName = mkName Proxy $ "compaREST – " <> projectName

33− , checkSha = sha

34− , checkDetailsURL = Nothing

35− , checkExternalId = Nothing

36− , checkStatus = Just CheckInProgress

37− , checkStartedAt = Nothing

38− , checkConclusion = Nothing

39− , checkCompletedAt = Nothing

40− , checkOutput = Nothing

41− , checkActions = Nothing

42− }

43−

44−postStatus ::

45− (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>

46− -- | 'Nothing' means that there were no changes at all

47− Maybe (Text, ReportStatus) ->

48− Eff effs ()

49−postStatus x = do

50− let (body, (title, conclusion)) = case x of

51− Just (b, s) -> (b,) $ case s of

52− BreakingChanges -> ("⚠️ Breaking changes found!", CheckNeutral)

53− NoBreakingChanges -> ("No breaking changes found ✨", CheckSuccess)

54− OnlyUnsupportedChanges -> ("🤷 Couldn't determine compatibility", CheckNeutral)

55− Nothing -> ("", ("✅ The API did not change", CheckSuccess))

56− Config {..} <- ask

57− printJSON $

58− sendGitHub $

59− checkR

60− repoOwner

61− repoName

62− Check

63− { checkName = mkName Proxy $ "compaREST – " <> projectName

64− , checkSha = sha

65− , checkDetailsURL = Nothing

66− , checkExternalId = Nothing

67− , checkStatus = Just CheckCompleted

68− , checkStartedAt = Nothing

69− , checkConclusion = Just conclusion

70− , checkCompletedAt = Nothing

71− , checkOutput =

72− Just $

73− CheckOutput

74− { checkTitle = title

75− , checkSummary = body

76− , checkText = Nothing

77− , checkAnnotations = Nothing

78− , checkImages = Nothing

79− }

80− , checkActions = Nothing

81− }

82−

83−printJSON :: MonadIO (Eff effs) => Eff effs Value -> Eff effs ()

84−printJSON m = do

85− x <- m

86− liftIO . BSLC.putStrLn $ encode x

github-action/CompaREST/GitHub/Action/Config.hsdeleted−43

@@ -1,43 +0,0 @@

1−module CompaREST.GitHub.Action.Config

2− ( Config (..),

3− )

4−where

5−

6−import Data.Proxy

7−import Data.Text (Text)

8−import qualified Data.Text as T

9−import qualified GitHub as GH

10−

11−import System.Envy

12−

13−data Config = Config

14− { githubToken :: GH.Auth

15− , repoOwner :: GH.Name GH.Owner

16− , repoName :: GH.Name GH.Repo

17− , projectName :: Text

18− , footerText :: Text

19− , root :: FilePath

20− , sha :: GH.Name GH.Commit

21− }

22−

23−instance FromEnv Config where

24− fromEnv _ = do

25− token <- GH.OAuth <$> env "GITHUB_TOKEN"

26− (owner, repo) <-

27− T.split (== '/') <$> env "REPO" >>= \case

28− [owner, name] -> pure (owner, name)

29− _ -> fail "malformed repo"

30− projectName <- env "PROJECT_NAME"

31− footerText <- env "FOOTER"

32− root <- envMaybe "ROOT" .!= "."

33− sha <- env "SHA"

34− pure $

35− Config

36− { githubToken = token

37− , repoOwner = GH.mkName Proxy owner

38− , repoName = GH.mkName Proxy repo

39− , projectName = projectName

40− , footerText = footerText

41− , root = root

42− , sha = GH.mkName Proxy sha

43− }

github-action/Control/Monad/Freer/GitHub.hsdeleted−27

@@ -1,27 +0,0 @@

1−module Control.Monad.Freer.GitHub

2− ( GitHub (..),

3− runGitHub,

4− sendGitHub,

5− )

6−where

7−

8−import Control.Monad.Freer

9−import Control.Monad.Freer.Error

10−import Control.Monad.IO.Class

11−import Data.Aeson

12−import GitHub hiding (Error)

13−import qualified GitHub as GH

14−

15−data GitHub r where

16− SendGHRequest :: FromJSON x => Request 'RW x -> GitHub x

17−

18−runGitHub :: (Member (Error GH.Error) effs, MonadIO (Eff effs)) => Auth -> Eff (GitHub ': effs) ~> Eff effs

19−runGitHub auth =

20− interpret

21− ( \(SendGHRequest req) ->

22− liftIO (executeRequest auth req)

23− >>= either throwError pure

24− )

25−

26−sendGitHub :: (FromJSON x, Member GitHub effs) => Request 'RW x -> Eff effs x

27−sendGitHub req = send $ SendGHRequest req

github-action/GitHub/Data/Checks.hsdeleted−173

@@ -1,173 +0,0 @@

1−module GitHub.Data.Checks

2− ( Check (..),

3− CheckStatus (..),

4− CheckConclusion (..),

5− CheckOutput (..),

6− CheckAnnotation (..),

7− CheckAnnotationLevel (..),

8− CheckImage (..),

9− CheckAction (..),

10− )

11−where

12−

13−import Data.Aeson

14−import Data.Aeson.Types

15−import Data.Text (Text)

16−import Data.Vector (Vector)

17−import GHC.Generics (Generic)

18−import GitHub

19−import GitHub.Internal.Prelude (UTCTime)

20−

21−data Check = Check

22− { checkName :: !(Name Check)

23− , checkSha :: !(Name Commit)

24− , checkDetailsURL :: !(Maybe URL)

25− , checkExternalId :: !(Maybe (Id Check))

26− , checkStatus :: !(Maybe CheckStatus)

27− , checkStartedAt :: !(Maybe UTCTime)

28− , checkConclusion :: !(Maybe CheckConclusion)

29− , checkCompletedAt :: !(Maybe UTCTime)

30− , checkOutput :: !(Maybe CheckOutput)

31− , checkActions :: !(Maybe (Vector CheckAction))

32− }

33− deriving stock (Show, Eq, Ord, Generic)

34−

35−instance ToJSON Check where

36− toJSON (Check n sha durl eid s sa c ca o a) =

37− object'

38− [ "name" .= n

39− , "head_sha" .= sha

40− , "details_url" .= durl

41− , "external_id" .= eid

42− , "status" .= s

43− , "started_at" .= sa

44− , "conclusion" .= c

45− , "completed_at" .= ca

46− , "output" .= o

47− , "actions" .= a

48− ]

49−

50−data CheckStatus

51− = CheckQueued

52− | CheckInProgress

53− | CheckCompleted

54− deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)

55−

56−instance ToJSON CheckStatus where

57− toJSON CheckQueued = String "queued"

58− toJSON CheckInProgress = String "in_progress"

59− toJSON CheckCompleted = String "completed"

60−

61−data CheckConclusion

62− = CheckActionRequired

63− | CheckCancelled

64− | CheckFailure

65− | CheckNeutral

66− | CheckSuccess

67− | CheckSkipped

68− | CheckStale

69− | CheckTimedOut

70− deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)

71−

72−instance ToJSON CheckConclusion where

73− toJSON CheckActionRequired = String "action_required"

74− toJSON CheckCancelled = String "cancelled"

75− toJSON CheckFailure = String "failure"

76− toJSON CheckNeutral = String "neutral"

77− toJSON CheckSuccess = String "success"

78− toJSON CheckSkipped = String "skipped"

79− toJSON CheckStale = String "stale"

80− toJSON CheckTimedOut = String "timed_out"

81−

82−data CheckOutput = CheckOutput

83− { checkTitle :: !Text

84− , checkSummary :: !Text

85− , checkText :: !(Maybe Text)

86− , checkAnnotations :: !(Maybe (Vector CheckAnnotation))

87− , checkImages :: !(Maybe (Vector CheckImage))

88− }

89− deriving stock (Show, Eq, Ord, Generic)

90−

91−instance ToJSON CheckOutput where

92− toJSON (CheckOutput t s txt a i) =

93− object'

94− [ "title" .= t

95− , "summary" .= s

96− , "text" .= txt

97− , "annotations" .= a

98− , "images" .= i

99− ]

100−

101−data CheckAnnotation = CheckAnnotation

102− { checkPath :: !Text

103− , checkStartLine :: !Int

104− , checkEndLine :: !Int

105− , checkStartColumn :: !(Maybe Int)

106− , checkEndColumn :: !(Maybe Int)

107− , checkAnnotationLevel :: !CheckAnnotationLevel

108− , checkMessage :: !Text

109− , checkTitle :: !(Maybe Text)

110− , checkRawDetails :: !(Maybe Text)

111− }

112− deriving stock (Show, Eq, Ord, Generic)

113−

114−instance ToJSON CheckAnnotation where

115− toJSON (CheckAnnotation p sl el sc ec al m t rd) =

116− object'

117− [ "path" .= p

118− , "start_line" .= sl

119− , "end_line" .= el

120− , "start_column" .= sc

121− , "end_column" .= ec

122− , "annotation_level" .= al

123− , "message" .= m

124− , "title" .= t

125− , "raw_details" .= rd

126− ]

127−

128−data CheckAnnotationLevel

129− = NoticeAnnotation

130− | WarningAnnotation

131− | FailureAnnotation

132− deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)

133−

134−instance ToJSON CheckAnnotationLevel where

135− toJSON NoticeAnnotation = String "notice"

136− toJSON WarningAnnotation = String "warning"

137− toJSON FailureAnnotation = String "failure"

138−

139−data CheckImage = CheckImage

140− { checkImageAlt :: !Text

141− , checkImageURL :: !URL

142− , checkImageCaption :: !(Maybe Text)

143− }

144− deriving stock (Show, Eq, Ord, Generic)

145−

146−instance ToJSON CheckImage where

147− toJSON (CheckImage a url c) =

148− object'

149− [ "alt" .= a

150− , "image_url" .= url

151− , "caption" .= c

152− ]

153−

154−data CheckAction = CheckAction

155− { checkActionLabel :: !Text

156− , checkActionDescription :: !Text

157− , checkActionIdentifier :: !Text

158− }

159− deriving stock (Show, Eq, Ord, Generic)

160−

161−instance ToJSON CheckAction where

162− toJSON (CheckAction l d i) =

163− object'

164− [ "label" .= l

165− , "description" .= d

166− , "identifier" .= i

167− ]

168−

169−object' :: [Pair] -> Value

170−object' = object . filter notNull

171− where

172− notNull (_, Null) = False

173− notNull (_, _) = True

github-action/GitHub/Endpoints/Checks.hsdeleted−12

@@ -1,12 +0,0 @@

1−module GitHub.Endpoints.Checks

2− ( checkR,

3− )

4−where

5−

6−import Data.Aeson

7−import GitHub

8−import GitHub.Data.Checks

9−

10−checkR :: Name Owner -> Name Repo -> Check -> Request 'RW Value

11−checkR user repo =

12− command Post ["repos", toPathPart user, toPathPart repo, "check-runs"] . encode

github-action/Main.hsdeleted−66

@@ -1,66 +0,0 @@

1−module Main (main) where

2−

3−import CompaREST.GitHub.API

4−import CompaREST.GitHub.Action.Config

5−import Control.Exception

6−import Control.Monad.Freer

7−import Control.Monad.Freer.Error

8−import Control.Monad.Freer.GitHub

9−import Control.Monad.Freer.Reader

10−import Data.OpenApi.Compare.Run

11−import Data.Text (Text)

12−import qualified Data.Yaml.Aeson as Yaml

13−import qualified GitHub as GH

14−import System.Environment

15−import System.Envy (decodeEnv)

16−import System.FilePath ((</>))

17−import Text.Pandoc (runPure)

18−import Text.Pandoc.Builder

19−import Text.Pandoc.Options

20−import Text.Pandoc.Writers

21−

22−main :: IO ()

23−main = do

24− cfg <- decodeEnv >>= either error pure

25− getArgs >>= \case

26− ["pre"] -> runPre cfg

27− ["run"] -> do

28− oldFile <- getEnv "OLD"

29− newFile <- getEnv "NEW"

30− runRun cfg (root cfg </> oldFile) (root cfg </> newFile)

31− _ -> error "Invalid arguments."

32−

33−runner :: Config -> Eff '[GitHub, Error GH.Error, Reader Config, IO] a -> IO a

34−runner cfg =

35− runM @IO . runReader cfg

36− . flip (handleError @GH.Error) (error . displayException)

37− . runGitHub (githubToken cfg)

38−

39−runPre :: Config -> IO ()

40−runPre cfg = runner cfg postStatusProcessing

41−

42−runRun :: Config -> FilePath -> FilePath -> IO ()

43−runRun cfg old' new' = runner cfg $ do

44− old <- Yaml.decodeFileThrow old'

45− new <- Yaml.decodeFileThrow new'

46− let reportConfig =

47− ReportConfig

48− { treeStyle = FoldingBlockquotesTreeStyle

49− , reportMode = All

50− }

51− (report, status) = runReport reportConfig (old, new)

52−

53− body = markdown report <> "\n\n" <> footerText cfg

54−

55− result =

56− if old == new

57− then Nothing

58− else Just (body, status)

59− postStatus result

60−

61−markdown :: Blocks -> Text

62−markdown =

63− either (error . displayException) id

64− . runPure

65− . writeHtml5String def

66− . doc

nix/ci.nixdeleted−6

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

1−{ sources ? import ./sources.nix

2−, pkgs ? import sources.nixpkgs { }

3−}:

4−pkgs.mkShell {

5− packages = [ pkgs.haskellPackages.fourmolu ];

6−}

nix/sources.jsondeleted−50

@@ -1,50 +0,0 @@

1−{

2− "haskellNix": {

3− "branch": "master",

4− "description": "Alternative Haskell Infrastructure for Nixpkgs",

5− "homepage": "https://input-output-hk.github.io/haskell.nix",

6− "owner": "input-output-hk",

7− "repo": "haskell.nix",

8− "rev": "c8a8f57de3c14fcf1c5cda045ed885fb6d06a00e",

9− "sha256": "0frzmvz8rhb4vgx20qms9xxqbkmg5pwivis4qis63ny5wxclzb34",

10− "type": "tarball",

11− "url": "https://github.com/input-output-hk/haskell.nix/archive/c8a8f57de3c14fcf1c5cda045ed885fb6d06a00e.tar.gz",

12− "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

13− },

14− "niv": {

15− "branch": "master",

16− "description": "Easy dependency management for Nix projects",

17− "homepage": "https://github.com/nmattia/niv",

18− "owner": "nmattia",

19− "repo": "niv",

20− "rev": "5830a4dd348d77e39a0f3c4c762ff2663b602d4c",

21− "sha256": "1d3lsrqvci4qz2hwjrcnd8h5vfkg8aypq3sjd4g3izbc8frwz5sm",

22− "type": "tarball",

23− "url": "https://github.com/nmattia/niv/archive/5830a4dd348d77e39a0f3c4c762ff2663b602d4c.tar.gz",

24− "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

25− },

26− "nix-filter": {

27− "branch": "master",

28− "description": "a small self-container source filtering lib",

29− "homepage": "",

30− "owner": "numtide",

31− "repo": "nix-filter",

32− "rev": "3c9e33ed627e009428197b07216613206f06ed80",

33− "sha256": "19w142crrkywxynmyw4rhz4nglrg64yjawfkw3j91qwkwbfjds84",

34− "type": "tarball",

35− "url": "https://github.com/numtide/nix-filter/archive/3c9e33ed627e009428197b07216613206f06ed80.tar.gz",

36− "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

37− },

38− "nixpkgs": {

39− "branch": "master",

40− "description": "Nix Packages collection",

41− "homepage": "",

42− "owner": "NixOS",

43− "repo": "nixpkgs",

44− "rev": "f0fe5e9ba08e658474476317717aca7acacef4d4",

45− "sha256": "1n5syynwmg3x8lj2kyb2ilbxw5nmw7f2kw6yxsi8qadx91hrvkwm",

46− "type": "tarball",

47− "url": "https://github.com/NixOS/nixpkgs/archive/f0fe5e9ba08e658474476317717aca7acacef4d4.tar.gz",

48− "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

49− }

50−}

nix/sources.nixdeleted−174

@@ -1,174 +0,0 @@

1−# This file has been generated by Niv.

2−

3−let

4−

5− #

6− # The fetchers. fetch_<type> fetches specs of type <type>.

7− #

8−

9− fetch_file = pkgs: name: spec:

10− let

11− name' = sanitizeName name + "-src";

12− in

13− if spec.builtin or true then

14− builtins_fetchurl { inherit (spec) url sha256; name = name'; }

15− else

16− pkgs.fetchurl { inherit (spec) url sha256; name = name'; };

17−

18− fetch_tarball = pkgs: name: spec:

19− let

20− name' = sanitizeName name + "-src";

21− in

22− if spec.builtin or true then

23− builtins_fetchTarball { name = name'; inherit (spec) url sha256; }

24− else

25− pkgs.fetchzip { name = name'; inherit (spec) url sha256; };

26−

27− fetch_git = name: spec:

28− let

29− ref =

30− if spec ? ref then spec.ref else

31− if spec ? branch then "refs/heads/${spec.branch}" else

32− if spec ? tag then "refs/tags/${spec.tag}" else

33− abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";

34− in

35− builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; };

36−

37− fetch_local = spec: spec.path;

38−

39− fetch_builtin-tarball = name: throw

40− ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.

41− $ niv modify ${name} -a type=tarball -a builtin=true'';

42−

43− fetch_builtin-url = name: throw

44− ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.

45− $ niv modify ${name} -a type=file -a builtin=true'';

46−

47− #

48− # Various helpers

49− #

50−

51− # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695

52− sanitizeName = name:

53− (

54− concatMapStrings (s: if builtins.isList s then "-" else s)

55− (

56− builtins.split "[^[:alnum:]+._?=-]+"

57− ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)

58− )

59− );

60−

61− # The set of packages used when specs are fetched using non-builtins.

62− mkPkgs = sources: system:

63− let

64− sourcesNixpkgs =

65− import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };

66− hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;

67− hasThisAsNixpkgsPath = <nixpkgs> == ./.;

68− in

69− if builtins.hasAttr "nixpkgs" sources

70− then sourcesNixpkgs

71− else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then

72− import <nixpkgs> {}

73− else

74− abort

75− ''

76− Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or

77− add a package called "nixpkgs" to your sources.json.

78− '';

79−

80− # The actual fetching function.

81− fetch = pkgs: name: spec:

82−

83− if ! builtins.hasAttr "type" spec then

84− abort "ERROR: niv spec ${name} does not have a 'type' attribute"

85− else if spec.type == "file" then fetch_file pkgs name spec

86− else if spec.type == "tarball" then fetch_tarball pkgs name spec

87− else if spec.type == "git" then fetch_git name spec

88− else if spec.type == "local" then fetch_local spec

89− else if spec.type == "builtin-tarball" then fetch_builtin-tarball name

90− else if spec.type == "builtin-url" then fetch_builtin-url name

91− else

92− abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";

93−

94− # If the environment variable NIV_OVERRIDE_${name} is set, then use

95− # the path directly as opposed to the fetched source.

96− replace = name: drv:

97− let

98− saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;

99− ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";

100− in

101− if ersatz == "" then drv else

102− # this turns the string into an actual Nix path (for both absolute and

103− # relative paths)

104− if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";

105−

106− # Ports of functions for older nix versions

107−

108− # a Nix version of mapAttrs if the built-in doesn't exist

109− mapAttrs = builtins.mapAttrs or (

110− f: set: with builtins;

111− listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))

112− );

113−

114− # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295

115− range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1);

116−

117− # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257

118− stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));

119−

120− # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269

121− stringAsChars = f: s: concatStrings (map f (stringToCharacters s));

122− concatMapStrings = f: list: concatStrings (map f list);

123− concatStrings = builtins.concatStringsSep "";

124−

125− # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331

126− optionalAttrs = cond: as: if cond then as else {};

127−

128− # fetchTarball version that is compatible between all the versions of Nix

129− builtins_fetchTarball = { url, name ? null, sha256 }@attrs:

130− let

131− inherit (builtins) lessThan nixVersion fetchTarball;

132− in

133− if lessThan nixVersion "1.12" then

134− fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))

135− else

136− fetchTarball attrs;

137−

138− # fetchurl version that is compatible between all the versions of Nix

139− builtins_fetchurl = { url, name ? null, sha256 }@attrs:

140− let

141− inherit (builtins) lessThan nixVersion fetchurl;

142− in

143− if lessThan nixVersion "1.12" then

144− fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))

145− else

146− fetchurl attrs;

147−

148− # Create the final "sources" from the config

149− mkSources = config:

150− mapAttrs (

151− name: spec:

152− if builtins.hasAttr "outPath" spec

153− then abort

154− "The values in sources.json should not have an 'outPath' attribute"

155− else

156− spec // { outPath = replace name (fetch config.pkgs name spec); }

157− ) config.sources;

158−

159− # The "config" used by the fetchers

160− mkConfig =

161− { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null

162− , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)

163− , system ? builtins.currentSystem

164− , pkgs ? mkPkgs sources system

165− }: rec {

166− # The sources, i.e. the attribute set of spec name to spec

167− inherit sources;

168−

169− # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers

170− inherit pkgs;

171− };

172−

173−in

174−mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }

compaREST.cabal → openapi-diff.cabalrenamed+49−83

@@ -1,24 +1,29 @@

11cabal-version: 2.4

2−name: compaREST

2+name: openapi-diff

33version: 0.0.0.0

44synopsis: Compatibility checker for OpenAPI

5−description: Compatibility checker for OpenAPI.

5+description: Compatibility checker for OpenAPI

66license: MIT

77license-file: LICENSE

8−author: Typeable

9−maintainer: compaREST@typeable.io

10−copyright: 2021 Typeable

8+author: Aleksey Uymanov

9+maintainer: Aleksey Uymanov <s9gf4ult@gmail.com>

10+copyright: 2021 Aleksey Uymanov

1111category: Web

1212build-type: Simple

1313extra-doc-files: README.md

1414 CHANGELOG.md

1515tested-with: GHC == 8.10.4

1616extra-source-files: awsm-css/dist/awsm.min.css

17−data-files:

18− test/golden/**/*.yaml

19− test/golden/**/*.md

17+

18+Flag static

19+ Default: False

20+ Manual: True

2021

2122common common-options

23+ if flag(static)

24+ cc-options: -static

25+ ld-options: -static -pthread

26+ ghc-options: -static

2227 ghc-options:

2328 -Weverything

2429 -Wno-implicit-prelude

@@ -33,9 +38,9 @@ common common-options

3338 -fconstraint-solver-iterations=0

3439 default-language: Haskell2010

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

41+ , bytestring

3642 , text

3743

38−

3944 default-extensions: ApplicativeDo

4045 , BangPatterns

4146 , ConstraintKinds

@@ -77,7 +82,6 @@ common common-options

7782 , QuantifiedConstraints

7883 , DefaultSignatures

7984

80−

8185library

8286 import: common-options

8387 build-depends:

@@ -107,53 +111,45 @@ library

107111 , file-embed

108112 , data-default

109113 , ordered-containers

110− , bytestring

111114 hs-source-dirs: src

112− exposed-modules: Data.OpenApi.Compare.Behavior

113− , Data.OpenApi.Compare.Common

114− , Data.OpenApi.Compare.Formula

115− , Data.OpenApi.Compare.Memo

116− , Data.OpenApi.Compare.Orphans

117− , Data.OpenApi.Compare.Paths

118− , Data.OpenApi.Compare.PathsPrefixTree

119− , Data.OpenApi.Compare.References

120− , Data.OpenApi.Compare.Report

121− , Data.OpenApi.Compare.Report.Html.Template

122− , Data.OpenApi.Compare.Report.Jet

123− , Data.OpenApi.Compare.Run

124− , Data.OpenApi.Compare.Subtree

125− , Data.OpenApi.Compare.Validate.Header

126− , Data.OpenApi.Compare.Validate.Link

127− , Data.OpenApi.Compare.Validate.MediaTypeObject

128− , Data.OpenApi.Compare.Validate.OAuth2Flows

129− , Data.OpenApi.Compare.Validate.OpenApi

130− , Data.OpenApi.Compare.Validate.Operation

131− , Data.OpenApi.Compare.Validate.Param

132− , Data.OpenApi.Compare.Validate.PathFragment

133− , Data.OpenApi.Compare.Validate.Products

134− , Data.OpenApi.Compare.Validate.RequestBody

135− , Data.OpenApi.Compare.Validate.Responses

136− , Data.OpenApi.Compare.Validate.Schema

137− , Data.OpenApi.Compare.Validate.Schema.DNF

138− , Data.OpenApi.Compare.Validate.Schema.Issues

139− , Data.OpenApi.Compare.Validate.Schema.JsonFormula

140− , Data.OpenApi.Compare.Validate.Schema.Partition

141− , Data.OpenApi.Compare.Validate.Schema.Process

142− , Data.OpenApi.Compare.Validate.Schema.Traced

143− , Data.OpenApi.Compare.Validate.Schema.TypedJson

144− , Data.OpenApi.Compare.Validate.SecurityRequirement

145− , Data.OpenApi.Compare.Validate.SecurityScheme

146− , Data.OpenApi.Compare.Validate.Server

147− , Data.OpenApi.Compare.Validate.Sums

148− other-modules: Data.HList

115+ exposed-modules: Data.HList

116+ , OpenAPI.Checker.Behavior

117+ , OpenAPI.Checker.Formula

118+ , OpenAPI.Checker.Memo

119+ , OpenAPI.Checker.Orphans

120+ , OpenAPI.Checker.Paths

121+ , OpenAPI.Checker.PathsPrefixTree

122+ , OpenAPI.Checker.References

123+ , OpenAPI.Checker.Subtree

124+ , OpenAPI.Checker.Validate.MediaTypeObject

125+ , OpenAPI.Checker.Validate.OpenApi

126+ , OpenAPI.Checker.Validate.Operation

127+ , OpenAPI.Checker.Validate.Param

128+ , OpenAPI.Checker.Validate.PathFragment

129+ , OpenAPI.Checker.Validate.Products

130+ , OpenAPI.Checker.Validate.RequestBody

131+ , OpenAPI.Checker.Validate.Responses

132+ , OpenAPI.Checker.Validate.Schema

133+ , OpenAPI.Checker.Validate.SecurityRequirement

134+ , OpenAPI.Checker.Validate.Server

135+ , OpenAPI.Checker.Validate.Sums

136+ , OpenAPI.Checker.Validate.Header

137+ , OpenAPI.Checker.Validate.Link

138+ , OpenAPI.Checker.Common

139+ , OpenAPI.Checker.Validate.SecurityScheme

140+ , OpenAPI.Checker.Validate.OAuth2Flows

141+ , OpenAPI.Checker.Report

149142 , Data.OpenUnion.Extra

143+ , OpenAPI.Checker.Report.Jet

144+ , OpenAPI.Checker.Run

145+ , OpenAPI.Checker.Report.Html.Template

150146

151−executable compaREST

147+executable openapi-diff

152148 import: common-options

153149 hs-source-dirs: app

154150 main-is: Main.hs

155151 build-depends:

156− compaREST

152+ openapi-diff

157153 , pandoc

158154 , data-default

159155 , bytestring

@@ -164,41 +160,14 @@ executable compaREST

164160 , aeson

165161 , containers

166162 , doctemplates

167− , pandoc-types

168163 ghc-options: -threaded

169164 -rtsopts

170165 -with-rtsopts=-N

171166 other-modules:

172167 FormatHeuristic

173− Data.OpenApi.Compare.Options

174−

175−executable compaREST-GitHub-Action

176− import: common-options

177− hs-source-dirs: github-action

178− main-is: Main.hs

179− build-depends:

180− compaREST

181− , pandoc

182− , yaml

183− , aeson

184− , github

185− , freer-simple

186− , vector

187− , pandoc-types

188− , envy

189− , filepath

190− , bytestring

191− ghc-options: -threaded

192− -rtsopts

193− -with-rtsopts=-N

194− other-modules:

195− Control.Monad.Freer.GitHub

196− CompaREST.GitHub.API

197− CompaREST.GitHub.Action.Config

198− GitHub.Data.Checks

199− GitHub.Endpoints.Checks

168+ OpenAPI.Checker.Options

200169

201−test-suite compaREST-tests

170+test-suite openapi-diff-test

202171 import: common-options

203172 type: exitcode-stdio-1.0

204173 hs-source-dirs: test

@@ -206,10 +175,8 @@ test-suite compaREST-tests

206175 other-modules:

207176 Spec.Golden.Extra

208177 Spec.Golden.TraceTree

209− Paths_compaREST

210− autogen-modules: Paths_compaREST

211178 build-depends:

212− , compaREST

179+ , openapi-diff

213180 , tasty-golden

214181 , tasty

215182 , bytestring

@@ -219,7 +186,6 @@ test-suite compaREST-tests

219186 , pandoc

220187 , data-default

221188 , lens

222− , pandoc-types

223189 ghc-options: -threaded

224190 -rtsopts

225191 -with-rtsopts=-N

policeman.jsondeleted−6

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

1−[{

2− "file": "compaREST.cabal",

3− "annotation_level": "notice",

4− "end_line": 0,

5− "start_line": 0

6−}]

src/Data/HList.hs+11−11

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

11module Data.HList

2− ( Has,

3− HasAll,

4− getH,

5− HList (..),

6− singletonH,

7− ReassembleHList,

8− reassemble,

2+ ( Has

3+ , HasAll

4+ , getH

5+ , HList (..)

6+ , singletonH

7+ , ReassembleHList

8+ , reassemble

99 )

1010where

1111

@@ -40,8 +40,8 @@ instance (Has' x xs t, HeadEq x (y : xs) ~ 'False) => Has' x (y ': xs) 'False wh

4040 {-# INLINE getH #-}

4141

4242instance

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

44− Has' x '[] 'False

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

44+ => Has' x '[] 'False

4545 where

4646 getH HNil = undefined

4747 {-# INLINE getH #-}

@@ -74,8 +74,8 @@ instance ReassembleHList' (x ': xs) '[] 'False where

7474 {-# INLINE reassemble #-}

7575

7676instance

77− (Has y xs, ReassembleHList' xs ys f, (xs == (y ': ys)) ~ 'False) =>

78− ReassembleHList' xs (y ': ys) 'False

77+ (Has y xs, ReassembleHList' xs ys f, (xs == (y ': ys)) ~ 'False)

78+ => ReassembleHList' xs (y ': ys) 'False

7979 where

8080 reassemble xs = getH @y xs `HCons` reassemble xs

8181 {-# INLINE reassemble #-}

src/Data/OpenApi/Compare/Memo.hsdeleted−164

@@ -1,164 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−

3−-- | Utilities for effectfully memoizing other, more effectful functions.

4−module Data.OpenApi.Compare.Memo

5− ( MonadMemo,

6− MemoState,

7− runMemo,

8− modifyMemoNonce,

9− KnotTier (..),

10− unknot,

11− memoWithKnot,

12− memoTaggedWithKnot,

13− )

14−where

15−

16−import Control.Monad.State

17−import Data.Dynamic

18−import qualified Data.Map as M

19−import Data.Tagged

20−import qualified Data.TypeRepMap as T

21−import Data.Void

22−import Type.Reflection

23−

24−data Progress a = Finished a | Started | TyingKnot Dynamic

25−

26−data MemoMap a where

27− MemoMap :: !(M.Map k (Progress v)) -> MemoMap (k, v)

28−

29−data MemoState s = MemoState s (T.TypeRepMap MemoMap)

30−

31−-- | An effectful memoization monad.

32−type MonadMemo s m = MonadState (MemoState s) m

33−

34−memoStateLookup ::

35− forall k v s.

36− (Typeable k, Typeable v, Ord k) =>

37− k ->

38− MemoState s ->

39− Maybe (Progress v)

40−memoStateLookup k (MemoState _ t) = case T.lookup @(k, v) t of

41− Just (MemoMap m) -> M.lookup k m

42− Nothing -> Nothing

43−

44−memoStateInsert ::

45− forall k v s.

46− (Typeable k, Typeable v, Ord k) =>

47− k ->

48− Progress v ->

49− MemoState s ->

50− MemoState s

51−memoStateInsert k x (MemoState s t) = MemoState s $ T.insert (MemoMap m'') t

52− where

53− m'' = M.insert k x m'

54− m' = case T.lookup @(k, v) t of

55− Just (MemoMap m) -> m

56− Nothing -> M.empty

57−

58−modifyMemoNonce :: MonadMemo s m => (s -> s) -> m s

59−modifyMemoNonce f = do

60− MemoState s t <- get

61− put $ MemoState (f s) t

62− pure s

63−

64−-- | Run a memoized computation.

65−runMemo :: Monad m => s -> StateT (MemoState s) m a -> m a

66−runMemo s = (`evalStateT` MemoState s T.empty)

67−

68−-- | A description of how to effectfully tie knots in type @v@, using the @m@

69−-- monad, and by sharing some @d@ data among the recursive instances.

70−data KnotTier v d m = KnotTier

71− { -- | Create some data that will be connected to this knot

72− onKnotFound :: m d

73− , -- | This is what the knot will look like as a value

74− -- to the inner computations

75− onKnotUsed :: d -> m v

76− , -- | Once we're done and we're outside, tie the

77− -- knot using the datum

78− tieKnot :: d -> v -> m v

79− }

80−

81−unknot :: KnotTier v Void m

82−unknot =

83− KnotTier

84− { onKnotFound = error "Recursion detected"

85− , onKnotUsed = absurd

86− , tieKnot = absurd

87− }

88−

89−-- | Run a potentially recursive computation. The provided key will be used to

90−-- refer to the result of this computation. If during the computation, another

91−-- attempt to run the computation with the same key is made, we run a

92−-- tying-the-knot procedure.

93−--

94−-- If another attempt to run the computation with the same key is made

95−-- *after we're done*, we will return the memoized value.

96−memoWithKnot ::

97− forall k v d m s.

98− (Typeable k, Typeable v, Typeable d, Ord k, MonadMemo s m) =>

99− KnotTier v d m ->

100− -- | the computation to memoize

101− m v ->

102− -- | key for memoization

103− k ->

104− m v

105−memoWithKnot tier f k =

106− memoStateLookup @k @v k <$> get >>= \case

107− Just (Finished v) -> pure v

108− Just Started -> do

109− d <- onKnotFound tier

110− modify $ memoStateInsert @k @v k (TyingKnot $ toDyn d)

111− onKnotUsed tier d

112− Just (TyingKnot dyn) -> case fromDynamic dyn of

113− Just d -> onKnotUsed tier d

114− Nothing ->

115− error $

116− "Type mismatch when examining the knot of "

117− <> show (typeRep @(k -> v))

118− <> ": expected "

119− <> show (typeRep @d)

120− <> ", got "

121− <> show (dynTypeRep dyn)

122− Nothing -> do

123− modify $ memoStateInsert @k @v k Started

124− v <- f

125− v' <-

126− memoStateLookup @k @v k <$> get >>= \case

127− Just Started -> pure v

128− Just (TyingKnot dyn) -> case fromDynamic dyn of

129− Just d -> tieKnot tier d v

130− Nothing ->

131− error $

132− "Type mismatch when tying the knot of "

133− <> show (typeRep @(k -> v))

134− <> ": expected "

135− <> show (typeRep @d)

136− <> ", got "

137− <> show (dynTypeRep dyn)

138− Just (Finished _) ->

139− error $

140− "Unexpected Finished when memoizing "

141− <> show (typeRep @(k -> v))

142− Nothing -> pure v

143− -- Normally this would be an error, but the underlying monad can refuse

144− -- to remember memoization state

145− modify $ memoStateInsert @k @v k (Finished v')

146− pure v'

147−

148−-- | Disambiguate memoized computations with an arbitrary tag.

149−memoTaggedWithKnot ::

150− forall t k v d m s.

151− ( Typeable t

152− , Typeable k

153− , Typeable v

154− , Typeable d

155− , Ord k

156− , MonadMemo s m

157− ) =>

158− KnotTier v d m ->

159− m v ->

160− k ->

161− m v

162−memoTaggedWithKnot tier f k =

163− withTypeable (typeRepKind $ typeRep @t) $

164− memoWithKnot tier f (Tagged @t k)

src/Data/OpenApi/Compare/Run.hsdeleted−31

@@ -1,31 +0,0 @@

1−module Data.OpenApi.Compare.Run

2− ( runChecker,

3− runReport,

4− module Data.OpenApi.Compare.Report,

5− )

6−where

7−

8−import Data.HList

9−import Data.OpenApi (OpenApi)

10−import Data.OpenApi.Compare.Paths

11−import Data.OpenApi.Compare.Report

12−import Data.OpenApi.Compare.Subtree

13−import Data.OpenApi.Compare.Validate.OpenApi ()

14−import Text.Pandoc.Builder

15−

16−runChecker :: (OpenApi, OpenApi) -> CheckerOutput

17−runChecker (client, server) =

18− CheckerOutput

19− { forwardChanges = run client server

20− , backwardChanges = run server client

21− }

22− where

23− toPC p c =

24− ProdCons

25− { producer = traced (step ClientSchema) p

26− , consumer = traced (step ServerSchema) c

27− }

28− run p c = either id mempty . runCompatFormula . checkCompatibility Root HNil $ toPC p c

29−

30−runReport :: ReportConfig -> (OpenApi, OpenApi) -> (Blocks, ReportStatus)

31−runReport cfg = generateReport cfg . segregateIssues . runChecker

src/Data/OpenApi/Compare/Validate/Products.hsdeleted−48

@@ -1,48 +0,0 @@

1−-- | Checks product-like entities. The key is some identificator for the product

2−--element. Each element may be required or optional.

3−--

4−--One example of product is request parameters. There are optional and required

5−--parameters. The client and server have possibly different set of

6−--parameters. What we must check is if server requires some request parameter,

7−--then this parameter must be presented by client and their schemas must match.

8−--

9−--So when we checking products we are checking from the server's (consumer)

10−--perspective, ensuring that all parameters are provided by the client (producer)

11−--and their schemas match.

12−--

13−--This module abstracts this logic for arbitrary elements

14−module Data.OpenApi.Compare.Validate.Products

15− ( checkProducts,

16− ProductLike (..),

17− )

18−where

19−

20−import Data.Foldable

21−import Data.Map.Strict (Map)

22−import qualified Data.Map.Strict as M

23−import Data.OpenApi.Compare.Behavior

24−import Data.OpenApi.Compare.Paths

25−import Data.OpenApi.Compare.Subtree

26−

27−-- | Some entity which is product-like

28−data ProductLike a = ProductLike

29− { productValue :: a

30− , required :: Bool

31− }

32−

33−checkProducts ::

34− (Ord k, Issuable l) =>

35− Paths q r l ->

36− -- | No required element found

37− (k -> Issue l) ->

38− (k -> ProdCons t -> CompatFormula' q AnIssue r ()) ->

39− ProdCons (Map k (ProductLike t)) ->

40− CompatFormula' q AnIssue r ()

41−checkProducts xs noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->

42− case M.lookup key p of

43− Nothing -> case required consElt of

44− True -> issueAt xs $ noElt key

45− False -> pure ()

46− Just prodElt -> do

47− let elts = ProdCons prodElt consElt

48− check key (productValue <$> elts)

src/Data/OpenApi/Compare/Validate/Schema.hsdeleted−398

@@ -1,398 +0,0 @@

1−{-# OPTIONS_GHC -Wno-orphans #-}

2−

3−module Data.OpenApi.Compare.Validate.Schema

4− (

5− )

6−where

7−

8−import Control.Monad.Writer

9−import qualified Data.Aeson as A

10−import Data.Coerce

11−import Data.Foldable (for_, toList)

12−import Data.Functor

13−import Data.HList

14−import Data.List (genericIndex, genericLength, group)

15−import qualified Data.List.NonEmpty as NE

16−import qualified Data.Map as M

17−import Data.Maybe

18−import Data.OpenApi

19−import Data.OpenApi.Compare.Behavior

20−import Data.OpenApi.Compare.Paths

21−import qualified Data.OpenApi.Compare.PathsPrefixTree as P

22−import Data.OpenApi.Compare.Subtree

23−import Data.OpenApi.Compare.Validate.Schema.DNF

24−import Data.OpenApi.Compare.Validate.Schema.Issues

25−import Data.OpenApi.Compare.Validate.Schema.JsonFormula

26−import Data.OpenApi.Compare.Validate.Schema.Partition

27−import Data.OpenApi.Compare.Validate.Schema.Process

28−import Data.OpenApi.Compare.Validate.Schema.Traced

29−import Data.OpenApi.Compare.Validate.Schema.TypedJson

30−import Data.Ord

31−import Data.Ratio

32−import Data.Semigroup

33−import qualified Data.Set as S

34−import Data.Text (Text)

35−

36−checkFormulas ::

37− (ReassembleHList xs (CheckEnv (Referenced Schema))) =>

38− HList xs ->

39− Behavior 'SchemaLevel ->

40− ProdCons (Trace Schema) ->

41− ProdCons (Traced (Definitions Schema)) ->

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

43− SemanticCompatFormula ()

44−checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =

45− case P.toList ep ++ P.toList ec of

46− issues@(_ : _) -> for_ issues $ embedFormula beh . anItem

47− [] -> do

48− -- We have the following isomorphisms:

49− -- (A ⊂ X ∩ Y) = (A ⊂ X) /\ (A ⊂ Y)

50− -- (A ⊂ ⊤) = 1

51− -- (X ∪ Y ⊂ B) = (X ⊂ B) /\ (Y ⊂ B)

52− -- (∅ ⊂ B) = 1

53− -- The remaining cases are, notably, not isomorphisms:

54− -- 1) (A ⊂ X ∪ Y) <= (A ⊂ X) \/ (A ⊂ Y)

55− -- 2) (A ⊂ ∅) <= 0

56− -- 3) (X ∩ Y ⊂ B) <= (X ⊂ B) \/ (Y ⊂ B)

57− -- 4) (⊤ ⊂ B) <= 0

58− -- Therefore we have the implications with (∃ and ∀ being the N-ary

59− -- versions of \/ and /\ respectively):

60− -- (⋃_i ⋂_j A[i,j]) ⊂ (⋃_k ⋂_l B[k,l])

61− -- <= ∃k ∀l ∀i, (⋂_j A[i,j]) ⊂ B[k,l]

62− -- = ∀i ∃k ∀l, (⋂_j A[i,j]) ⊂ B[k,l]

63− -- with the caveat that the the set over which k ranges is nonempty.

64− -- (because 2) is not an isomorphism), and that this is a sufficient

65− -- but not necessary condition (because 1) is not an isomorphism).

66− -- Our disjunction loses information, so it makes sense to nest it as

67− -- deeply as possible, hence we choose the latter representation.

68− --

69− -- We delegate the verification of (⋂_j A[j]) ⊂ B to a separate heuristic

70− -- function, with the understanding that ∃j, A[j] ⊂ B is a sufficient,

71− -- but not necessary condition (because of 3) and 4)).

72− --

73− -- If k ranges over an empty set, we have the isomorphism:

74− -- (⋃_i ⋂_j A[i,j]) ⊂ ∅ = ∀i, (⋂_j A[i,j]) ⊂ ∅

75− -- where we again delegate (⋂_j A[j]) ⊂ ∅ to a heuristic, though here the

76− -- shortcut of ∃j, A[j] ⊂ ∅ hardly helps.

77− --

78− -- Disjunctions tend to erase informative error messages, so we may want

79− -- to avoid them. This can be formally done as follows: if we can

80− -- partition the universal set into a disjoint union of some parts:

81− -- ⊤ = ⊔_α P[α]

82− -- such that the conjuncts in our disjunctive normal form are subordinate

83− -- to the partition:

84− -- ∀i ∃α, (⋂_j A[i,j]) ⊂ P[α]

85− -- ∀k ∃α, (⋂_l B[k,l]) ⊂ P[α]

86− -- then we can partition the sets over which i and k range into partitions

87− -- I[α] and K[α], and then in each "bucket" verify the inclusion in the

88− -- aforementioned way:

89− -- ∀α, (⋃_i∈I[α] ⋂_j A[i,j]) ⊂ (⋃_k∈K[α] ⋂_l B[k,l])

90− -- = ∀α ∀i∈I[α] ∃k∈K[α] ∀l, (⋂_j A[i,j]) ⊂ B[k,l]

91− -- We already somewhat do this by partitioning JSON into types, but we can

92− -- additionally partition e.g. "enum" fields or existence of particular

93− -- properties. This works especially well if we manage to ensure K[α] are

94− -- 1-element sets.

95− --

96− -- Since the set:

97− -- (⋃_i∈I[α] ⋂_j A[i,j]) = (⋃_i ⋂_j A[i,j]) ∩ P[α]

98− -- does not actually appear in the source schema, we need to construct it

99− -- ourselves and come up with a name for it.

100− let typesRestricted = not (anyBottomTypes fp) && anyBottomTypes fc

101− -- Specifically handle the case when a schema's type has been

102− -- restricted from "all" to specific types: if all types were allowed

103− -- in the producer and not all types are allowed in the consumer, it's

104− -- usually easier to say what's left than what's removed

105− when typesRestricted $ issueAt beh $ TypesRestricted $ nonBottomTypes fc

106− forType_ $ \tyName ty -> do

107− let beh' = beh >>> step (OfType tyName)

108− case (getJsonFormula $ ty fp, getJsonFormula $ ty fc) of

109− (DNF pss, BottomDNF) -> unless typesRestricted $ do

110− -- don't repeat the TypesRestricted issue

111− for_ pss $ \(Disjunct ps) -> checkContradiction beh' Nothing ps

112− (DNF pss, SingleDisjunct (Disjunct cs)) -> for_ pss $ \(Disjunct ps) -> do

113− for_ cs $ checkImplication env beh' trs ps -- avoid disjunction if there's only one conjunct

114− (TopDNF, DNF css) ->

115− -- producer is "open" (allows any value), but consumer has restrictions.

116− -- In this case we want to show which restrictions were added. (instead

117− -- of showing an empty list restrictions that couldn't be satisfied.)

118− for_ css $ \(Disjunct cs) -> for_ cs $ checkImplication env beh' trs S.empty

119− (pss', css') -> for_ (tryPartition defs $ ProdCons (JsonFormula pss') (JsonFormula css')) $ \case

120− (mPart, ProdCons pf cf) -> do

121− let beh'' = foldr ((<<<) . step . InPartition) beh' mPart

122− case (getJsonFormula pf, getJsonFormula cf) of

123− (DNF pss, BottomDNF) -> for_ pss $ \(Disjunct ps) -> checkContradiction beh' mPart ps

124− (DNF pss, SingleDisjunct (Disjunct cs)) -> for_ pss $ \(Disjunct ps) -> do

125− for_ cs $ checkImplication env beh'' trs ps

126− -- unlucky:

127− (DNF pss, DNF css) -> for_ pss $ \(Disjunct ps) -> do

128− anyOfAt

129− beh'

130− (issueFromDisjunct Nothing ps)

131− [for_ cs $ checkImplication env beh' trs ps | Disjunct cs <- S.toList css]

132− pure ()

133− where

134− anyBottomTypes f = getAny $

135− foldType $ \_ ty -> case getJsonFormula $ ty f of

136− BottomDNF -> Any True

137− _ -> mempty

138− nonBottomTypes f = foldType $ \tyName ty -> case getJsonFormula $ ty f of

139− BottomDNF -> mempty

140− _ -> [tyName]

141− issueFromDisjunct :: Typeable t => Maybe Partition -> S.Set (Condition t) -> Issue 'TypedSchemaLevel

142− issueFromDisjunct _ ps

143− | Just e <- findExactly ps

144− , all (satisfiesTyped e) ps =

145− EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?

146− issueFromDisjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> S.toList ps

147−

148−checkContradiction ::

149− Behavior 'TypedSchemaLevel ->

150− Maybe Partition ->

151− S.Set (Condition t) ->

152− SemanticCompatFormula ()

153−checkContradiction beh mPart _ = issueAt beh $ maybe TypeBecomesEmpty PartitionBecomesEmpty mPart -- TODO #70

154−

155−checkImplication ::

156− (ReassembleHList xs (CheckEnv (Referenced Schema))) =>

157− HList xs ->

158− Behavior 'TypedSchemaLevel ->

159− ProdCons (Trace Schema) -> -- the traces of the root schemas used in this comparison

160− S.Set (Condition t) ->

161− Condition t ->

162− SemanticCompatFormula ()

163−checkImplication env beh trs prods cons = case findExactly prods of

164− Just e

165− | all (satisfiesTyped e) prods ->

166− if satisfiesTyped e cons

167− then pure ()

168− else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

169− | otherwise -> pure () -- vacuously true

170− Nothing -> case cons of

171− -- the above code didn't catch it, so there's no Exactly condition on the lhs

172− Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)

173− Maximum m -> foldCheck min m NoMatchingMaximum MatchingMaximumWeak $ \case

174− Maximum m' -> Just m'

175− _ -> Nothing

176− Minimum m -> foldCheck max m (NoMatchingMinimum . coerce) (MatchingMinimumWeak . coerce) $ \case

177− Minimum m' -> Just m'

178− _ -> Nothing

179− MultipleOf m -> foldCheck lcmScientific m NoMatchingMultipleOf MatchingMultipleOfWeak $ \case

180− MultipleOf m' -> Just m'

181− _ -> Nothing

182− NumberFormat f -> case flip any prods $ \case

183− NumberFormat f' -> f == f'

184− _ -> False of

185− True -> pure ()

186− False -> issueAt beh (NoMatchingFormat f)

187− MaxLength m -> foldCheck min m NoMatchingMaxLength MatchingMaxLengthWeak $ \case

188− MaxLength m' -> Just m'

189− _ -> Nothing

190− MinLength m -> foldCheck max m NoMatchingMinLength MatchingMinLengthWeak $ \case

191− MinLength m' -> Just m'

192− _ -> Nothing

193− Pattern p -> case flip any prods $ \case

194− Pattern p' -> p == p'

195− _ -> False of

196− True -> pure ()

197− False -> issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32

198− StringFormat f -> case flip any prods $ \case

199− StringFormat f' -> f == f'

200− _ -> False of

201− True -> pure ()

202− False -> issueAt beh (NoMatchingFormat f)

203− Items _ cons' -> case foldSome (<>) prods $ \case

204− Items _ rs -> Just (Just (rs NE.:| []), mempty)

205− TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))

206− _ -> Nothing of

207− Just (mItems, Just pfs)

208− | not $ allSame (length <$> pfs) -> pure () -- vacuously

209− | let plen = genericLength (NE.head pfs) ->

210− clarifyIssue (AnItem beh (anIssue TupleToArray)) $

211− for_ [0 .. plen - 1] $ \i -> do

212− let prod' = tracedConjunct $ case mItems of

213− Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'

214− Nothing -> (`genericIndex` i) <$> pfs

215− checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'

216− Just (Just prods', Nothing) -> do

217− let prod' = tracedConjunct prods'

218− checkCompatibility (beh >>> step InItems) env $ ProdCons prod' cons'

219− _ -> clarifyIssue (AnItem beh (anIssue NoMatchingItems)) $ do

220− checkCompatibility (beh >>> step InItems) env $ ProdCons prodTopSchema cons'

221− TupleItems (map snd -> fs) -> case foldSome (<>) prods $ \case

222− TupleItems (map snd -> fs') -> Just (Just $ fs' NE.:| [], Just . Max $ genericLength fs', Just . Min $ genericLength fs', mempty)

223− MinItems m' -> Just (mempty, Just . Max $ m', mempty, mempty)

224− MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)

225− Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))

226− _ -> Nothing of

227− -- if the length constraints in the producer are contradictory:

228− Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()

229− -- We have an explicit tuple items clause...

230− Just (Just pfs, Just (Max plen), _, _)

231− | plen /= genericLength fs -> -- ...of wrong length

232− issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

233− | otherwise ->

234− for_ [0 .. plen - 1] $ \i -> do

235− checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct $ (`genericIndex` i) <$> pfs) (fs `genericIndex` i)

236− -- We have a fixed length array in the producer...

237− Just (Nothing, Just (Max plen), Just (Min plen'), mProd)

238− | plen == plen' ->

239− clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of

240− _

241− | plen /= genericLength fs -> -- ...of wrong length

242− issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

243− Just rs -> for_ [0 .. plen - 1] $ \i -> do

244− checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct rs) (fs `genericIndex` i)

245− -- ...and no "items" schema

246− Nothing -> clarifyIssue (AnItem beh (anIssue NoMatchingTupleItems)) $ do

247− for_ [0 .. plen - 1] $ \i -> do

248− checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prodTopSchema (fs `genericIndex` i)

249− _ -> issueAt beh NoMatchingTupleItems

250− MaxItems m -> foldCheck min m NoMatchingMaxItems MatchingMaxItemsWeak $ \case

251− MaxItems m' -> Just m'

252− TupleItems fs -> Just $ toInteger $ length fs

253− _ -> Nothing

254− MinItems m -> foldCheck max m NoMatchingMinItems MatchingMinItemsWeak $ \case

255− MinItems m' -> Just m'

256− TupleItems fs -> Just $ toInteger $ length fs

257− _ -> Nothing

258− UniqueItems -> case flip any prods $ \case

259− UniqueItems -> True

260− MaxItems 1 -> True

261− TupleItems fs | length fs == 1 -> True

262− _ -> False of

263− True -> pure ()

264− False -> issueAt beh NoMatchingUniqueItems

265− Properties props _ madd -> case foldSome (<>) prods $ \case

266− Properties props' _ madd' -> Just $ (props', madd') NE.:| []

267− _ -> Nothing of

268− Just pm ->

269− anyOfAt beh NoMatchingProperties $ -- TODO: could first "concat" the lists

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

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

272− let beh' = beh >>> step (InProperty k)

273− go sch sch' = checkCompatibility beh' env (ProdCons sch sch')

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

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

276− (False, True) -> issueAt beh' PropertyNowRequired

277− _ -> pure ()

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

279− -- (producer, additional producer, consumer, additional consumer)

280− (Nothing, Nothing, _, _) -> pure () -- vacuously: the producer asserts that this field cannot exist,

281− -- and the consumer either doesn't require it, or it does and we've already raised an error about it.

282− (_, _, Nothing, Nothing) -> issueAt beh' UnexpectedProperty

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

284− (Nothing, Just add', Just p, _) ->

285− clarifyIssue (AnItem beh' (anIssue AdditionalToProperty)) $

286− go add' (propRefSchema p)

287− (Just p', _, Nothing, Just add) ->

288− clarifyIssue (AnItem beh' (anIssue PropertyToAdditional)) $

289− go (propRefSchema p') add

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

291− pure ()

292− case (madd', madd) of

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

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

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

296− pure ()

297− Nothing -> issueAt beh NoMatchingProperties

298− MaxProperties m -> foldCheck min m NoMatchingMaxProperties MatchingMaxPropertiesWeak $ \case

299− MaxProperties m' -> Just m'

300− _ -> Nothing

301− MinProperties m -> foldCheck max m NoMatchingMinProperties MatchingMinPropertiesWeak $ \case

302− MinProperties m' -> Just m'

303− _ -> Nothing

304− where

305− lcmScientific (toRational -> a) (toRational -> b) =

306− fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

307−

308− foldCheck ::

309− Eq a =>

310− (a -> a -> a) ->

311− a ->

312− (a -> Issue 'TypedSchemaLevel) ->

313− (ProdCons a -> Issue 'TypedSchemaLevel) ->

314− (forall t. Condition t -> Maybe a) ->

315− SemanticCompatFormula ()

316− foldCheck f m missing weak extr = case foldSome f prods extr of

317− Just m'

318− | f m' m == m' -> pure ()

319− | otherwise -> issueAt beh (weak ProdCons {producer = m', consumer = m})

320− Nothing -> issueAt beh (missing m)

321−

322− prodTopSchema = traced (producer trs >>> step ImplicitTopSchema) $ Inline mempty

323−

324−allSame :: (Foldable f, Eq a) => f a -> Bool

325−allSame xs = case group (toList xs) of

326− [] -> True

327− [_] -> True

328− _ -> False

329−

330−foldSome :: (b -> b -> b) -> S.Set a -> (a -> Maybe b) -> Maybe b

331−foldSome combine xs extr =

332− fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr . S.toList $ xs

333−

334−findExactly :: S.Set (Condition t) -> Maybe (TypedValue t)

335−findExactly xs = foldSome const xs $ \case

336− Exactly x -> Just x

337− _ -> Nothing

338−

339−instance Subtree Schema where

340− type SubtreeLevel Schema = 'SchemaLevel

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

342− checkStructuralCompatibility env pc = do

343− structuralEq $ fmap _schemaRequired <$> pc

344− structuralEq $ fmap _schemaNullable <$> pc

345− structuralMaybeWith (structuralList env) $ tracedAllOf <$> pc

346− structuralMaybeWith (structuralList env) $ tracedOneOf <$> pc

347− structuralMaybe env $ sequence . stepTraced NotStep . fmap _schemaNot <$> pc

348− structuralMaybeWith (structuralList env) $ tracedAnyOf <$> pc

349− iohmStructural env $ stepTraced PropertiesStep . fmap _schemaProperties <$> pc

350− structuralMaybeWith structuralAdditionalProperties $ tracedAdditionalProperties <$> pc

351− structuralMaybeWith structuralDiscriminator $ tracedDiscriminator <$> pc

352− structuralEq $ fmap _schemaReadOnly <$> pc

353− structuralEq $ fmap _schemaWriteOnly <$> pc

354− structuralEq $ fmap _schemaXml <$> pc

355− structuralEq $ fmap _schemaMaxProperties <$> pc

356− structuralEq $ fmap _schemaMinProperties <$> pc

357− structuralEq $ fmap _schemaDefault <$> pc

358− structuralEq $ fmap _schemaType <$> pc

359− structuralEq $ fmap _schemaFormat <$> pc

360− structuralMaybeWith structuralItems $ tracedItems <$> pc

361− structuralEq $ fmap _schemaMaximum <$> pc

362− structuralEq $ fmap _schemaExclusiveMaximum <$> pc

363− structuralEq $ fmap _schemaMinimum <$> pc

364− structuralEq $ fmap _schemaExclusiveMinimum <$> pc

365− structuralEq $ fmap _schemaMaxLength <$> pc

366− structuralEq $ fmap _schemaMinLength <$> pc

367− structuralEq $ fmap _schemaPattern <$> pc

368− structuralEq $ fmap _schemaMaxItems <$> pc

369− structuralEq $ fmap _schemaMinItems <$> pc

370− structuralEq $ fmap _schemaUniqueItems <$> pc

371− structuralEq $ fmap _schemaEnum <$> pc

372− structuralEq $ fmap _schemaMultipleOf <$> pc

373− pure ()

374− where

375− structuralAdditionalProperties

376− (ProdCons (Left x) (Left y)) = unless (x == y) structuralIssue

377− structuralAdditionalProperties

378− (ProdCons (Right x) (Right y)) =

379− checkSubstructure env $ ProdCons x y

380− structuralAdditionalProperties _ = structuralIssue

381− structuralDiscriminator pc' = do

382− structuralEq $ fmap _discriminatorPropertyName <$> pc'

383− iohmStructural env $

384− stepTraced DiscriminatorMapping . fmap (fmap parseDiscriminatorValue . _discriminatorMapping) <$> pc'

385− pure ()

386− structuralItems (ProdCons (Left a) (Left b)) =

387− checkSubstructure env $ ProdCons a b

388− structuralItems (ProdCons (Right a) (Right b)) =

389− structuralList env $ ProdCons a b

390− structuralItems _ = structuralIssue

391− checkSemanticCompatibility env beh schs = do

392− let defs = getH env

393− checkFormulas env beh (ask <$> schs) defs $ schemaToFormula <$> defs <*> schs

394−

395−parseDiscriminatorValue :: Text -> Referenced Schema

396−parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of

397− A.Success x -> x

398− A.Error _ -> Ref $ Reference v

src/Data/OpenApi/Compare/Validate/Schema/DNF.hsdeleted−101

@@ -1,101 +0,0 @@

1−module Data.OpenApi.Compare.Validate.Schema.DNF

2− ( DNF (..),

3− Disjunct (..),

4− pattern SingleDisjunct,

5− pattern TopDNF,

6− pattern BottomDNF,

7− pattern LiteralDNF,

8− foldDNF,

9− forDNF,

10− )

11−where

12−

13−import Algebra.Lattice

14−import Control.Applicative

15−import Data.Foldable

16−import qualified Data.Set as S

17−

18−-- | A boolean formula (without "not") represented as a Disjunctive Normal Form:

19−-- the formula is a disjunction of a set of clauses, each of which is a

20−-- conjunction of a set of some elementary formulas.

21−-- Invariant: no two disjuncts imply eachother

22−newtype DNF a = DNF (S.Set (Disjunct a))

23− deriving stock (Eq, Ord, Show)

24−

25−-- A disjunct is a thing that is to be disjuncted. Itself it is a conjunction of some literals.

26−newtype Disjunct a = Disjunct (S.Set a)

27− deriving stock (Eq, Ord, Show)

28−

29−disjImplies :: Ord a => Disjunct a -> Disjunct a -> Bool

30−disjImplies (Disjunct xs) (Disjunct ys) = ys `S.isSubsetOf` xs

31−

32−disjConjunction :: Ord a => Disjunct a -> Disjunct a -> Disjunct a

33−disjConjunction (Disjunct xs) (Disjunct ys) = Disjunct $ xs `S.union` ys

34−

35−disjAdd :: Ord a => DNF a -> Disjunct a -> DNF a

36−disjAdd (DNF yss) xs

37− | any (xs `disjImplies`) yss = DNF yss

38− | otherwise = DNF $ S.insert xs $ S.filter (not . (`disjImplies` xs)) yss

39−

40−instance Ord a => Lattice (DNF a) where

41− xss \/ DNF yss = S.foldl' disjAdd xss yss

42− DNF xss /\ DNF yss =

43− foldl' disjAdd bottom $

44− liftA2 disjConjunction (S.toList xss) (S.toList yss)

45−

46−pattern BottomDNF :: DNF a

47−pattern BottomDNF <-

48− DNF (S.null -> True)

49− where

50− BottomDNF = DNF S.empty

51−

52−isSingleton :: S.Set a -> Maybe a

53−isSingleton s

54− | S.size s == 1 = S.lookupMin s

55− | otherwise = Nothing

56−

57−pattern SingleDisjunct :: Ord a => Disjunct a -> DNF a

58−pattern SingleDisjunct xs <-

59− DNF (isSingleton -> Just xs)

60− where

61− SingleDisjunct xs = DNF $ S.singleton xs

62−

63−pattern TopDNF :: DNF a

64−pattern TopDNF <-

65− DNF (isSingleton -> Just (Disjunct (S.null -> True)))

66− where

67− TopDNF = DNF $ S.singleton $ Disjunct S.empty

68−

69−pattern LiteralDNF :: Ord a => a -> DNF a

70−pattern LiteralDNF x <-

71− SingleDisjunct (Disjunct (isSingleton -> Just x))

72− where

73− LiteralDNF x = SingleDisjunct $ Disjunct $ S.singleton x

74−

75−instance Ord a => BoundedJoinSemiLattice (DNF a) where

76− bottom = BottomDNF

77−

78−instance Ord a => BoundedMeetSemiLattice (DNF a) where

79− top = TopDNF

80−

81−foldDisjunct :: BoundedMeetSemiLattice l => (a -> l) -> Disjunct a -> l

82−foldDisjunct f (Disjunct xs) = S.foldl' (\y l -> y /\ f l) top xs

83−

84−foldDNF :: BoundedLattice l => (a -> l) -> DNF a -> l

85−foldDNF f (DNF xss) = S.foldl' (\y xs -> y \/ foldDisjunct f xs) bottom xss

86−

87−newtype LiftA f a = LiftA {getLiftA :: f a}

88− deriving newtype (Functor, Applicative)

89−

90−instance (Lattice a, Applicative f) => Lattice (LiftA f a) where

91− (/\) = liftA2 (/\)

92− (\/) = liftA2 (\/)

93−

94−instance (BoundedJoinSemiLattice a, Applicative f) => BoundedJoinSemiLattice (LiftA f a) where

95− bottom = pure bottom

96−

97−instance (BoundedMeetSemiLattice a, Applicative f) => BoundedMeetSemiLattice (LiftA f a) where

98− top = pure top

99−

100−forDNF :: (BoundedLattice l, Applicative f) => (a -> f l) -> DNF a -> f l

101−forDNF f = getLiftA . foldDNF (LiftA . f)

src/Data/OpenApi/Compare/Validate/Schema/Issues.hsdeleted−321

@@ -1,321 +0,0 @@

1−{-# OPTIONS_GHC -Wno-orphans #-}

2−

3−module Data.OpenApi.Compare.Validate.Schema.Issues

4− ( Issue (..),

5− Behave (..),

6− )

7−where

8−

9−import qualified Data.Aeson as A

10−import Data.OpenApi

11−import Data.OpenApi.Compare.Behavior

12−import Data.OpenApi.Compare.Subtree

13−import Data.OpenApi.Compare.Validate.Schema.JsonFormula

14−import Data.OpenApi.Compare.Validate.Schema.Partition

15−import Data.OpenApi.Compare.Validate.Schema.TypedJson

16−import Data.Scientific

17−import Data.Text (Text)

18−import qualified Data.Text as T

19−import Text.Pandoc.Builder hiding (Format, Null)

20−

21−instance Issuable 'TypedSchemaLevel where

22− data Issue 'TypedSchemaLevel

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

24− EnumDoesntSatisfy A.Value

25− | -- | consumer only expects a specific value which the producer does not produce.

26− NoMatchingEnum A.Value

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

28− NoMatchingMaximum (Bound Scientific)

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

30− MatchingMaximumWeak (ProdCons (Bound Scientific))

31− | -- | consumer declares a minimum numeric value, producer doesn't

32− NoMatchingMinimum (Bound Scientific)

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

34− MatchingMinimumWeak (ProdCons (Bound Scientific))

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

36− NoMatchingMultipleOf Scientific

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

38− MatchingMultipleOfWeak (ProdCons Scientific)

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

40− NoMatchingFormat Format

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

42− NoMatchingMaxLength Integer

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

44− MatchingMaxLengthWeak (ProdCons Integer)

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

46− NoMatchingMinLength Integer

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

48− MatchingMinLengthWeak (ProdCons Integer)

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

50− NoMatchingPattern Pattern

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

52− NoMatchingItems

53− | -- | producer and consumer declare that an array must be a tuple of a fixed length, but the lengths don't match

54− TupleItemsLengthChanged (ProdCons Integer)

55− | -- | consumer declares that the array is a tuple, but the producer doesn't, the length constraints match, but there were issues with the components

56− ArrayToTuple

57− | -- | producer declares that the array is a tuple, but the consumer doesn't, and there were issues with the components

58− TupleToArray

59− | -- | consumer declares that the array is a tuple, but the producer doesn't, and there aren't sufficient length constraints

60− NoMatchingTupleItems

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

62− NoMatchingMaxItems Integer

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

64− MatchingMaxItemsWeak (ProdCons Integer)

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

66− NoMatchingMinItems Integer

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

68− MatchingMinItemsWeak (ProdCons Integer)

69− | -- | consumer declares that items must be unique, producer doesn't

70− NoMatchingUniqueItems

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

72− NoMatchingProperties

73− | -- | producer allows additional properties, consumer doesn't

74− NoAdditionalProperties

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

76− NoMatchingMaxProperties Integer

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

78− MatchingMaxPropertiesWeak (ProdCons Integer)

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

80− NoMatchingMinProperties Integer

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

82− MatchingMinPropertiesWeak (ProdCons Integer)

83− | -- | 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)

84− NoMatchingCondition (Maybe Partition) [SomeCondition]

85− | -- | 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)

86− TypeBecomesEmpty

87− | -- | consumer indicates that no values in a particular partition are allowed, but we weren't able to conclude this in the producer

88− PartitionBecomesEmpty Partition

89− deriving stock (Eq, Ord, Show)

90− issueKind = \case

91− NoMatchingEnum _ -> ProbablyIssue

92− MatchingMaximumWeak _ -> ProbablyIssue -- interplay with MultipleOf could make this not an issue

93− MatchingMinimumWeak _ -> ProbablyIssue -- ditto

94− MatchingMultipleOfWeak _ -> ProbablyIssue -- ditto

95− NoMatchingFormat _ -> Unsupported

96− NoMatchingPattern _ -> Unsupported

97− ArrayToTuple -> Comment

98− TupleToArray -> Comment

99− NoMatchingProperties -> ProbablyIssue -- TODO: #109

100− TypeBecomesEmpty -> ProbablyIssue -- TODO: #70

101− PartitionBecomesEmpty _ -> ProbablyIssue -- ditto

102− _ -> CertainIssue

103− relatedIssues =

104− (==) `withClass` \case

105− EnumDoesntSatisfy v -> Just v

106− NoMatchingEnum v -> Just v

107− _ -> Nothing

108− `withClass` \case

109− NoMatchingMaximum _ -> Just ()

110− MatchingMaximumWeak _ -> Just ()

111− _ -> Nothing

112− `withClass` \case

113− NoMatchingMinimum _ -> Just ()

114− MatchingMinimumWeak _ -> Just ()

115− _ -> Nothing

116− `withClass` \case

117− NoMatchingMultipleOf _ -> Just ()

118− MatchingMultipleOfWeak _ -> Just ()

119− _ -> Nothing

120− `withClass` \case

121− NoMatchingMaxLength _ -> Just ()

122− MatchingMaxLengthWeak _ -> Just ()

123− _ -> Nothing

124− `withClass` \case

125− NoMatchingMinLength _ -> Just ()

126− MatchingMinLengthWeak _ -> Just ()

127− _ -> Nothing

128− `withClass` \case

129− NoMatchingItems -> Just ()

130− ArrayToTuple -> Just ()

131− TupleToArray -> Just ()

132− NoMatchingTupleItems -> Just ()

133− TupleItemsLengthChanged _ -> Just ()

134− _ -> Nothing

135− `withClass` \case

136− NoMatchingMaxItems _ -> Just ()

137− MatchingMaxItemsWeak _ -> Just ()

138− _ -> Nothing

139− `withClass` \case

140− NoMatchingMinItems _ -> Just ()

141− MatchingMinItemsWeak _ -> Just ()

142− _ -> Nothing

143− `withClass` \case

144− NoMatchingMaxProperties _ -> Just ()

145− MatchingMaxPropertiesWeak _ -> Just ()

146− _ -> Nothing

147− `withClass` \case

148− NoMatchingMinProperties _ -> Just ()

149− MatchingMinPropertiesWeak _ -> Just ()

150− _ -> Nothing

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

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

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

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

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

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

157− describeIssue ori (MatchingMaximumWeak (orientProdCons ori -> ProdCons p c)) =

158− para $ "Upper bound changed from " <> showBound p <> " to " <> showBound c <> "."

159− describeIssue Forward (NoMatchingMinimum b) = para $ "Lower bound has been added: " <> showBound b <> "."

160− describeIssue Backward (NoMatchingMinimum b) = para $ "Lower bound has been removed: " <> showBound b <> "."

161− describeIssue ori (MatchingMinimumWeak (orientProdCons ori -> ProdCons p c)) =

162− para $ "Lower bound changed from " <> showBound p <> " to " <> showBound c <> "."

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

164− describeIssue Backward (NoMatchingMultipleOf n) = para $ "Value is no longer a multiple of " <> show' n <> "."

165− describeIssue ori (MatchingMultipleOfWeak (orientProdCons ori -> ProdCons p c)) =

166− para $ "Value changed from being a multiple of " <> show' p <> " to being a multiple of " <> show' c <> "."

167− describeIssue Forward (NoMatchingFormat f) = para $ "Format added: " <> code f <> "."

168− describeIssue Backward (NoMatchingFormat f) = para $ "Format removed: " <> code f <> "."

169− describeIssue Forward (NoMatchingMaxLength n) = para $ "Maximum length added: " <> show' n <> "."

170− describeIssue Backward (NoMatchingMaxLength n) = para $ "Maximum length removed: " <> show' n <> "."

171− describeIssue ori (MatchingMaxLengthWeak (orientProdCons ori -> ProdCons p c)) =

172− para $ "Maximum length of the string changed from " <> show' p <> " to " <> show' c <> "."

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

174− describeIssue Backward (NoMatchingMinLength n) = para $ "Minimum length of the string removed: " <> show' n <> "."

175− describeIssue ori (MatchingMinLengthWeak (orientProdCons ori -> ProdCons p c)) =

176− para $ "Minimum length of the string changed from " <> show' p <> " to " <> show' c <> "."

177− describeIssue Forward (NoMatchingPattern p) = para "Pattern (regular expression) added: " <> codeBlock p

178− describeIssue Backward (NoMatchingPattern p) = para "Pattern (regular expression) removed: " <> codeBlock p

179− describeIssue Forward NoMatchingItems = para "Array item schema has been added."

180− describeIssue Backward NoMatchingItems = para "Array item schema has been removed."

181− describeIssue ori (TupleItemsLengthChanged (orientProdCons ori -> ProdCons p c)) =

182− para $ "Tuple length changed from " <> show' p <> " to " <> show' c <> "."

183− describeIssue Forward ArrayToTuple = para "The array is now explicitly defined as a tuple."

184− describeIssue Backward ArrayToTuple = para "The array is no longer explicitly defined as a tuple."

185− describeIssue Forward TupleToArray = para "The array is no longer explicitly defined as a tuple."

186− describeIssue Backward TupleToArray = para "The array is now explicitly defined as a tuple."

187− describeIssue Forward NoMatchingTupleItems = para "The array is now explicitly defined as a tuple."

188− describeIssue Backward NoMatchingTupleItems = para "The array is no longer explicitly defined as a tuple."

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

190− describeIssue Backward (NoMatchingMaxItems n) = para $ "Maximum length of the array has been removed " <> show' n <> "."

191− describeIssue ori (MatchingMaxItemsWeak (orientProdCons ori -> ProdCons p c)) =

192− para $ "Maximum length of the array changed from " <> show' p <> " to " <> show' c <> "."

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

194− describeIssue Backward (NoMatchingMinItems n) = para $ "Minimum length of the array removed: " <> show' n <> "."

195− describeIssue ori (MatchingMinItemsWeak (orientProdCons ori -> ProdCons p c)) =

196− para $ "Minimum length of the array changed from " <> show' p <> " to " <> show' c <> "."

197− describeIssue Forward NoMatchingUniqueItems = para "Items are now required to be unique."

198− describeIssue Backward NoMatchingUniqueItems = para "Items are no longer required to be unique."

199− describeIssue Forward NoMatchingProperties = para "Property added."

200− describeIssue Backward NoMatchingProperties = para "Property removed."

201− describeIssue Forward NoAdditionalProperties = para "Additional properties have been removed."

202− describeIssue Backward NoAdditionalProperties = para "Additional properties have been added."

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

204− describeIssue Backward (NoMatchingMaxProperties n) = para $ "Maximum number of properties has been removed: " <> show' n <> "."

205− describeIssue ori (MatchingMaxPropertiesWeak (orientProdCons ori -> ProdCons p c)) =

206− para $ "Maximum number of properties has changed from " <> show' p <> " to " <> show' c <> "."

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

208− describeIssue Backward (NoMatchingMinProperties n) = para $ "Minimum number of properties removed: " <> show' n <> "."

209− describeIssue ori (MatchingMinPropertiesWeak (orientProdCons ori -> ProdCons p c)) =

210− para $ "Minimum number of properties has changed from " <> show' p <> " to " <> show' c <> "."

211− describeIssue _ (NoMatchingCondition mPart conds) =

212− para

213− ( case mPart of

214− Nothing -> "Could not verify that the following conditions hold (please file a bug if you see this):"

215− Just locPart ->

216− "In cases where " <> showPartition locPart

217− <> " – could not verify that the following conditions hold (please file a bug if you see this):"

218− )

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

220− describeIssue Forward TypeBecomesEmpty = para "The type has been removed."

221− describeIssue Backward TypeBecomesEmpty = para "The type has been added."

222− describeIssue Forward (PartitionBecomesEmpty part) = para $ "The case where " <> showPartition part <> " – has been removed."

223− describeIssue Backward (PartitionBecomesEmpty part) = para $ "The case where " <> showPartition part <> " – has been added."

224−

225−show' :: Show x => x -> Inlines

226−show' = str . T.pack . show

227−

228−instance Issuable 'SchemaLevel where

229− data Issue 'SchemaLevel

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

231− NotSupported Text

232− | -- | 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

233− OneOfNotDisjoint

234− | -- | The schema is actually invalid

235− InvalidSchema Text

236− | -- | The schema contains a reference loop along "anyOf"/"allOf"/"oneOf".

237− UnguardedRecursion

238− | -- | Producer doesn't place any restrictions on the types, but the consumer does. List what types remain available in the consumer.

239− TypesRestricted [JsonType]

240− | -- | 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

241− AdditionalToProperty

242− | -- | 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

243− PropertyToAdditional

244− | -- | consumer requires a property that is not required/allowed in the producer

245− PropertyNowRequired

246− | -- | producer allows a property that is not allowed in the consumer

247− UnexpectedProperty

248− deriving stock (Eq, Ord, Show)

249− issueKind = \case

250− NotSupported _ -> Unsupported

251− OneOfNotDisjoint -> Unsupported

252− InvalidSchema _ -> SchemaInvalid

253− UnguardedRecursion -> Unsupported

254− AdditionalToProperty -> Comment

255− PropertyToAdditional -> Comment

256− TypesRestricted _ -> ProbablyIssue -- TODO: #70

257− _ -> CertainIssue

258− relatedIssues =

259− (==) `withClass` \case

260− AdditionalToProperty -> Just ()

261− PropertyToAdditional -> Just ()

262− _ -> Nothing

263− `withClass` \case

264− PropertyNowRequired -> Just ()

265− UnexpectedProperty -> Just ()

266− _ -> Nothing

267− describeIssue _ (NotSupported i) =

268− para (emph "Encountered a feature that CompaREST does not support: " <> text i <> ".")

269− describeIssue _ OneOfNotDisjoint =

270− para $

271− "Could not deduce that " <> code "oneOf"

272− <> " cases don't overlap. Treating the "

273− <> code "oneOf"

274− <> " as an "

275− <> code "anyOf"

276− <> ". Reported errors might not be accurate."

277− describeIssue _ (InvalidSchema i) =

278− para (emph "The schema is invalid: " <> text i <> ".")

279− describeIssue _ UnguardedRecursion =

280− para "Encountered recursion that is too complex for CompaREST to untangle."

281− describeIssue Forward (TypesRestricted tys) = case tys of

282− [] -> para "No longer has any valid values." -- weird

283− _ -> para "Values are now limited to the following types: " <> bulletList (para . describeJSONType <$> tys)

284− describeIssue Backward (TypesRestricted tys) = case tys of

285− [] -> para "Any value of any type is now allowed." -- weird

286− _ -> para "Values are no longer limited to the following types: " <> bulletList (para . describeJSONType <$> tys)

287− describeIssue Forward AdditionalToProperty = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."

288− describeIssue Backward AdditionalToProperty = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."

289− describeIssue Forward PropertyToAdditional = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."

290− describeIssue Backward PropertyToAdditional = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."

291− describeIssue Forward PropertyNowRequired = para "The property has become required."

292− describeIssue Backward PropertyNowRequired = para "The property may not be present."

293− describeIssue Forward UnexpectedProperty = para "The property has been removed."

294− describeIssue Backward UnexpectedProperty = para "The property has been added."

295−

296−instance Behavable 'SchemaLevel 'TypedSchemaLevel where

297− data Behave 'SchemaLevel 'TypedSchemaLevel

298− = OfType JsonType

299− deriving stock (Eq, Ord, Show)

300−

301− describeBehavior (OfType t) = describeJSONType t

302−

303−instance Behavable 'TypedSchemaLevel 'TypedSchemaLevel where

304− data Behave 'TypedSchemaLevel 'TypedSchemaLevel

305− = InPartition Partition

306− deriving stock (Eq, Ord, Show)

307−

308− describeBehavior (InPartition partition) = "In cases where " <> showPartition partition

309−

310−instance Behavable 'TypedSchemaLevel 'SchemaLevel where

311− data Behave 'TypedSchemaLevel 'SchemaLevel

312− = InItems

313− | InItem Integer

314− | InProperty Text

315− | InAdditionalProperty

316− deriving stock (Eq, Ord, Show)

317−

318− describeBehavior InItems = "Items"

319− describeBehavior (InItem i) = "Item " <> show' i

320− describeBehavior (InProperty p) = "Property " <> code p

321− describeBehavior InAdditionalProperty = "Additional properties"

src/Data/OpenApi/Compare/Validate/Schema/JsonFormula.hsdeleted−236

@@ -1,236 +0,0 @@

1−module Data.OpenApi.Compare.Validate.Schema.JsonFormula

2− ( Bound (..),

3− showBound,

4− Property (..),

5− Condition (..),

6− showCondition,

7− satisfiesTyped,

8− checkStringFormat,

9− checkNumberFormat,

10− SomeCondition (..),

11− JsonFormula (..),

12− satisfiesFormula,

13− satisfies,

14− showJSONValue,

15− showJSONValueInline,

16− )

17−where

18−

19−import Algebra.Lattice

20−import qualified Data.Aeson as A

21−import qualified Data.ByteString.Lazy as BSL

22−import qualified Data.Foldable as F

23−import Data.Functor

24−import qualified Data.HashMap.Strict as HM

25−import Data.Int

26−import Data.Kind

27−import qualified Data.Map as M

28−import Data.Maybe

29−import Data.OpenApi

30−import Data.OpenApi.Compare.Orphans ()

31−import Data.OpenApi.Compare.Subtree

32−import Data.OpenApi.Compare.Validate.Schema.DNF

33−import Data.OpenApi.Compare.Validate.Schema.TypedJson

34−import Data.Ord

35−import Data.Ratio

36−import Data.Scientific

37−import qualified Data.Set as S

38−import Data.Text (Text)

39−import qualified Data.Text as T

40−import qualified Data.Text.Encoding as T

41−import Data.Typeable

42−import Text.Pandoc.Builder hiding (Format, Null)

43−import Text.Regex.Pcre2

44−

45−data Bound a = Exclusive !a | Inclusive !a

46− deriving stock (Eq, Show, Functor)

47−

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

49−instance Ord a => Ord (Bound a) where

50− Exclusive a `compare` Exclusive b = compare a b

51− Exclusive a `compare` Inclusive b = if a <= b then LT else GT

52− Inclusive a `compare` Exclusive b = if a < b then LT else GT

53− Inclusive a `compare` Inclusive b = compare a b

54−

55−showBound :: Show a => Bound a -> Inlines

56−showBound (Inclusive x) = show' x <> " inclusive"

57−showBound (Exclusive x) = show' x <> " exclusive"

58−

59−data Property = Property

60− { propRequired :: Bool

61− , propFormula :: ForeachType JsonFormula

62− , propRefSchema :: Traced (Referenced Schema)

63− }

64− deriving stock (Eq, Ord, Show)

65−

66−-- | A primitive structural condition for the "top level" of a JSON value (of a specific type)

67−data Condition :: JsonType -> Type where

68− Exactly :: TypedValue t -> Condition t

69− Maximum :: !(Bound Scientific) -> Condition 'Number

70− Minimum ::

71− !(Down (Bound (Down Scientific))) ->

72− -- | this has the right Ord

73− Condition 'Number

74− MultipleOf :: !Scientific -> Condition 'Number

75− NumberFormat :: !Format -> Condition 'Number

76− MaxLength :: !Integer -> Condition 'String

77− MinLength :: !Integer -> Condition 'String

78− Pattern :: !Pattern -> Condition 'String

79− StringFormat :: !Format -> Condition 'String

80− Items ::

81− !(ForeachType JsonFormula) ->

82− !(Traced (Referenced Schema)) ->

83− Condition 'Array

84− TupleItems ::

85− ![(ForeachType JsonFormula, Traced (Referenced Schema))] ->

86− Condition 'Array

87− MaxItems :: !Integer -> Condition 'Array

88− MinItems :: !Integer -> Condition 'Array

89− UniqueItems :: Condition 'Array

90− Properties ::

91− !(M.Map Text Property) ->

92− -- | formula for additional properties

93− !(ForeachType JsonFormula) ->

94− -- | schema for additional properties, Nothing means bottom

95− !(Maybe (Traced (Referenced Schema))) ->

96− Condition 'Object

97− MaxProperties :: !Integer -> Condition 'Object

98− MinProperties :: !Integer -> Condition 'Object

99−

100−deriving stock instance Eq (Condition t)

101−

102−deriving stock instance Ord (Condition t)

103−

104−deriving stock instance Show (Condition t)

105−

106−showCondition :: Condition a -> Blocks

107−showCondition = \case

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

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

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

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

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

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

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

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

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

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

118− (TupleItems is) -> para ("There should be " <> show' (length is) <> " items in the array:") <> bulletList (showForEachJsonFormula . fst <$> is)

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

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

121− UniqueItems -> para "The elements in the array should be unique."

122− (Properties props additional _) ->

123− bulletList $

124− ( M.toList props

125− <&> ( \(k, p) ->

126− para (code k)

127− <> para (strong $ if propRequired p then "Required" else "Optional")

128− <> showForEachJsonFormula (propFormula p)

129− )

130− )

131− <> [ para (emph "Additional properties")

132− <> showForEachJsonFormula additional

133− ]

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

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

136− where

137− showForEachJsonFormula :: ForeachType JsonFormula -> Blocks

138− showForEachJsonFormula i =

139− bulletList $

140− foldType

141− ( \t f -> case getJsonFormula $ f i of

142− BottomDNF -> mempty

143− (DNF conds) ->

144− [ para (describeJSONType t)

145− <> bulletList

146− ( S.toList conds <&> \case

147− Disjunct (S.toList -> []) -> para "Empty"

148− Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond)

149− )

150− ]

151− )

152−

153−showJSONValue :: A.Value -> Blocks

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

155−

156−showJSONValueInline :: A.Value -> Inlines

157−showJSONValueInline v = code (T.decodeUtf8 . BSL.toStrict . A.encode $ v)

158−

159−show' :: Show x => x -> Inlines

160−show' = str . T.pack . show

161−

162−satisfiesTyped :: TypedValue t -> Condition t -> Bool

163−satisfiesTyped e (Exactly e') = e == e'

164−satisfiesTyped (TNumber n) (Maximum (Exclusive m)) = n < m

165−satisfiesTyped (TNumber n) (Maximum (Inclusive m)) = n <= m

166−satisfiesTyped (TNumber n) (Minimum (Down (Exclusive (Down m)))) = n > m

167−satisfiesTyped (TNumber n) (Minimum (Down (Inclusive (Down m)))) = n >= m

168−satisfiesTyped (TNumber n) (MultipleOf m) = denominator (toRational n / toRational m) == 1 -- TODO: could be better #36

169−satisfiesTyped (TNumber n) (NumberFormat f) = checkNumberFormat f n

170−satisfiesTyped (TString s) (MaxLength m) = fromIntegral (T.length s) <= m

171−satisfiesTyped (TString s) (MinLength m) = fromIntegral (T.length s) >= m

172−satisfiesTyped (TString s) (Pattern p) = isJust $ match p s -- TODO: regex stuff #32

173−satisfiesTyped (TString s) (StringFormat f) = checkStringFormat f s

174−satisfiesTyped (TArray a) (Items f _) = all (`satisfies` f) a

175−satisfiesTyped (TArray a) (TupleItems fs) = length fs == F.length a && and (zipWith satisfies (F.toList a) (fst <$> fs))

176−satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m

177−satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m

178−satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36

179−satisfiesTyped (TObject o) (Properties props additional _) =

180− all (`HM.member` o) (M.keys (M.filter propRequired props))

181− && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)

182−satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m

183−satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m

184−

185−checkNumberFormat :: Format -> Scientific -> Bool

186−checkNumberFormat "int32" (toRational -> n) =

187− denominator n == 1

188− && n >= toRational (minBound :: Int32)

189− && n <= toRational (maxBound :: Int32)

190−checkNumberFormat "int64" (toRational -> n) =

191− denominator n == 1

192− && n >= toRational (minBound :: Int64)

193− && n <= toRational (maxBound :: Int64)

194−checkNumberFormat "float" _n = True

195−checkNumberFormat "double" _n = True

196−checkNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f

197−

198−checkStringFormat :: Format -> Text -> Bool

199−checkStringFormat "byte" _s = True -- TODO: regex stuff #32

200−checkStringFormat "binary" _s = True

201−checkStringFormat "date" _s = True

202−checkStringFormat "date-time" _s = True

203−checkStringFormat "password" _s = True

204−checkStringFormat "uuid" _s = True

205−checkStringFormat f _s = error $ "Invalid string format: " <> T.unpack f

206−

207−data SomeCondition where

208− SomeCondition :: Typeable t => Condition t -> SomeCondition

209−

210−instance Eq SomeCondition where

211− SomeCondition x == SomeCondition y = case cast x of

212− Just x' -> x' == y

213− Nothing -> False

214−

215−instance Ord SomeCondition where

216− compare (SomeCondition x) (SomeCondition y) = case cast x of

217− Just x' -> compare x' y

218− Nothing -> compare (typeRep x) (typeRep y)

219−

220−deriving stock instance Show SomeCondition

221−

222−newtype JsonFormula t = JsonFormula {getJsonFormula :: DNF (Condition t)}

223− deriving stock (Eq, Ord, Show)

224− deriving newtype (Lattice, BoundedJoinSemiLattice, BoundedMeetSemiLattice)

225−

226−satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool

227−satisfiesFormula val = foldDNF (satisfiesTyped val) . getJsonFormula

228−

229−satisfies :: A.Value -> ForeachType JsonFormula -> Bool

230−satisfies val p = case val of

231− A.Null -> satisfiesFormula TNull $ forNull p

232− A.Bool b -> satisfiesFormula (TBool b) $ forBoolean p

233− A.Number n -> satisfiesFormula (TNumber n) $ forNumber p

234− A.String s -> satisfiesFormula (TString s) $ forString p

235− A.Array a -> satisfiesFormula (TArray a) $ forArray p

236− A.Object o -> satisfiesFormula (TObject o) $ forObject p

src/Data/OpenApi/Compare/Validate/Schema/Partition.hsdeleted−317

@@ -1,317 +0,0 @@

1−module Data.OpenApi.Compare.Validate.Schema.Partition

2− ( partitionSchema,

3− partitionRefSchema,

4− selectPartition,

5− runPartitionM,

6− tryPartition,

7− showPartition,

8− intersectSchema,

9− intersectRefSchema,

10− IntersectionResult (..),

11− runIntersectionM,

12− Partition,

13− )

14−where

15−

16−import Algebra.Lattice

17−import Algebra.Lattice.Lifted

18−import Control.Applicative

19−import Control.Monad.Reader hiding (ask)

20−import qualified Control.Monad.Reader as R

21−import Control.Monad.State

22−import qualified Control.Monad.Trans.Reader as R (liftCatch)

23−import qualified Control.Monad.Trans.Writer as W (liftCatch)

24−import Control.Monad.Writer

25−import qualified Data.Aeson as A

26−import Data.Foldable

27−import Data.Functor.Identity

28−import qualified Data.HashMap.Strict.InsOrd as IOHM

29−import Data.List (sortBy)

30−import qualified Data.List as L

31−import qualified Data.List.NonEmpty as NE

32−import qualified Data.Map as M

33−import Data.Maybe

34−import Data.OpenApi

35−import Data.OpenApi.Compare.Memo

36−import Data.OpenApi.Compare.References

37−import Data.OpenApi.Compare.Subtree

38−import Data.OpenApi.Compare.Validate.Schema.DNF

39−import Data.OpenApi.Compare.Validate.Schema.JsonFormula

40−import Data.OpenApi.Compare.Validate.Schema.Traced

41−import Data.OpenApi.Compare.Validate.Schema.TypedJson

42−import Data.Ord

43−import qualified Data.Set as S

44−import Data.Text (Text)

45−import qualified Data.Text as T

46−import Text.Pandoc.Builder hiding (Format, Null)

47−

48−data PartitionData

49− = DByEnumValue (DNF (S.Set A.Value))

50− | DByProperties (DNF (S.Set Text, S.Set Text)) -- optional, required

51− deriving stock (Eq, Ord, Show)

52−

53−conjPart :: PartitionData -> PartitionData -> Maybe PartitionData

54−conjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss /\ yss

55−conjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss /\ yss

56−conjPart _ _ = Nothing

57−

58−disjPart :: PartitionData -> PartitionData -> Maybe PartitionData

59−disjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss \/ yss

60−disjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss \/ yss

61−disjPart _ _ = Nothing

62−

63−newtype Partitions = Partitions (M.Map PartitionLocation (S.Set PartitionData))

64− deriving stock (Eq, Ord, Show)

65−

66−instance Lattice Partitions where

67− Partitions xss /\ Partitions yss = Partitions $ M.unionWith conj xss yss

68− where

69− conj xs ys = S.fromList . catMaybes $ liftA2 conjPart (S.toList xs) (S.toList ys)

70− Partitions xss \/ Partitions yss = Partitions $ M.intersectionWith disj xss yss

71− where

72− disj xs ys = S.fromList . catMaybes $ liftA2 disjPart (S.toList xs) (S.toList ys)

73−

74−instance BoundedMeetSemiLattice Partitions where

75− top = Partitions M.empty

76−

77−-- The lattice has no bottom, but we use 'Lifted' to adjoin a free bottom element

78−

79−type PartitionM = ReaderT (Traced (Definitions Schema)) (State (MemoState ()))

80−

81−ignoreKnot :: KnotTier (Lifted Partitions) () PartitionM

82−ignoreKnot =

83− KnotTier

84− { onKnotFound = pure ()

85− , onKnotUsed = \_ -> pure bottom

86− , tieKnot = \_ -> pure

87− }

88−

89−singletonPart :: PartitionData -> Lifted Partitions

90−singletonPart = Lift . Partitions . M.singleton PHere . S.singleton

91−

92−partitionSchema :: Traced Schema -> PartitionM (Lifted Partitions)

93−partitionSchema sch = do

94− allClauses <- case tracedAllOf sch of

95− Nothing -> pure []

96− Just xs -> mapM partitionRefSchema xs

97−

98− anyClause <- case tracedAnyOf sch of

99− Nothing -> pure top

100− Just xs -> joins <$> mapM partitionRefSchema xs

101−

102− oneClause <- case tracedOneOf sch of

103− Nothing -> pure top

104− Just xs -> joins <$> mapM partitionRefSchema xs

105−

106− byEnumClause <- case _schemaEnum $ extract sch of

107− Nothing -> pure top

108− Just xs ->

109− pure . singletonPart $

110− DByEnumValue $ LiteralDNF (S.fromList xs)

111−

112− -- We can only partition by presence of a property if additional properties

113− -- are disallowed, and the property is not optional

114− let reqd = S.fromList $ _schemaRequired $ extract sch

115− byPropertiesClause <- case _schemaAdditionalProperties $ extract sch of

116− Just (AdditionalPropertiesAllowed False) -> do

117− let props = S.fromList . IOHM.keys . _schemaProperties $ extract sch

118− pure . singletonPart $

119− DByProperties $ LiteralDNF (props S.\\ reqd, props `S.intersection` reqd)

120− _ -> pure top

121−

122− -- We can partition on something nested in a property only if the property is

123− -- required

124− let reqdProps = IOHM.filterWithKey (\k _ -> k `S.member` reqd) $ tracedProperties sch

125− inPropertiesClauses <- forM (IOHM.toList reqdProps) $ \(k, rs) -> do

126− f <- partitionRefSchema rs

127− pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f

128−

129− pure $ meets $ allClauses <> [anyClause, oneClause, byEnumClause, byPropertiesClause] <> inPropertiesClauses

130−

131−partitionRefSchema :: Traced (Referenced Schema) -> PartitionM (Lifted Partitions)

132−partitionRefSchema x = do

133− defs <- R.ask

134− memoWithKnot ignoreKnot (partitionSchema $ dereference defs x) (ask x)

135−

136−partitionCondition :: Condition t -> PartitionM (Lifted Partitions)

137−partitionCondition = \case

138− Exactly x ->

139− pure . singletonPart $

140− DByEnumValue $ LiteralDNF (S.singleton $ untypeValue x)

141− Properties props _ madd -> do

142− let byProps = case madd of

143− Just _ -> top

144− Nothing ->

145− singletonPart $

146− DByProperties $

147− LiteralDNF

148− ( M.keysSet $ M.filter (not . propRequired) props

149− , M.keysSet $ M.filter propRequired props

150− )

151− inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do

152− f <- partitionRefSchema $ propRefSchema prop

153− pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f

154− pure $ byProps /\ meets inProps

155− _ -> pure top

156−

157−runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a

158−runPartitionM defs = runIdentity . runMemo () . (`runReaderT` defs)

159−

160−partitionJsonFormulas ::

161− ProdCons (Traced (Definitions Schema)) ->

162− ProdCons (JsonFormula t) ->

163− Lifted Partitions

164−partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart

165− where

166− pcPart = partitionFormula <$> defs <*> pc

167− partitionFormula def (JsonFormula xss) = runPartitionM def $ forDNF partitionCondition xss

168−

169−selectPartition :: Lifted Partitions -> Maybe (PartitionLocation, S.Set PartitionChoice)

170−selectPartition Bottom = Nothing

171−selectPartition (Lift (Partitions m)) =

172− go [(loc, part) | (loc, parts) <- sortBy (comparing $ locLength . fst) $ M.toList m, part <- S.toList parts]

173− where

174− locLength :: PartitionLocation -> Int

175− locLength = walk 0

176− where

177− walk !n PHere = n

178− walk !n (PInProperty _ l) = walk (n + 1) l

179− go [] = Nothing

180− -- Skip partitioning by property for now

181− go ((_, DByProperties _) : ps) = go ps

182− -- Don't partition by enum value at the root (this reports removed enum values as contradictions in their respective partitions)

183− go ((PHere, DByEnumValue _) : ps) = go ps

184− go ((loc, DByEnumValue (DNF xss)) : ps)

185− -- Check that no disjunction branches are unresticted

186− | Just enums <- traverse (\(Disjunct xs) -> fmap (foldr1 S.intersection) . NE.nonEmpty . S.toList $ xs) . S.toList $ xss =

187− -- TODO: improve

188− Just (loc, S.map (CByEnumValue . S.singleton) $ S.unions enums)

189− | otherwise = go ps

190−

191−-- This essentially has 3 cases:

192−-- Nothing -- we have produced a bottom schema

193−-- Just (False, _) -- there's been no change to the schema

194−-- Just (True, x) -- x is a new schema

195−type IntersectionM = ReaderT (Traced (Definitions Schema)) (WriterT Any Maybe)

196−

197−mBottom :: IntersectionM a

198−mBottom = lift . lift $ Nothing

199−

200−catchBottom :: IntersectionM a -> IntersectionM a -> IntersectionM a

201−catchBottom act handler = R.liftCatch (W.liftCatch (\a h -> a <|> h ())) act (\_ -> handler)

202−

203−mChange :: IntersectionM ()

204−mChange = tell $ Any True

205−

206−data IntersectionResult a = Disjoint | Same a | New a

207− deriving stock (Eq, Ord, Show)

208−

209−runIntersectionM :: Traced (Definitions Schema) -> IntersectionM a -> IntersectionResult a

210−runIntersectionM defs act = case runWriterT $ runReaderT act defs of

211− Nothing -> Disjoint

212− Just (x, Any False) -> Same x

213− Just (x, Any True) -> New x

214−

215−intersectSchema ::

216− PartitionLocation ->

217− PartitionChoice ->

218− Traced Schema ->

219− IntersectionM Schema

220−intersectSchema loc part sch = do

221− allOf' <- forM (tracedAllOf sch) $ \rss ->

222− -- Assuming i ranges over a nonempty set (checked in processSchema)

223− -- (⋂_i A[i]) ∩ X = ⋂_i (A[i] ∩ X)

224− -- If any intersections are empty, the result is empty. If any intersections are a change, the result is a change.

225− traverse (intersectRefSchema loc part) rss

226− anyOf' <- forM (tracedAnyOf sch) $ \rss -> do

227− -- (⋃_i A[i]) ∩ X = ⋃_i (A[i] ∩ X)

228− -- Collect only the nonempty A[i] ∩ X, unless there are none, in which case the result is empty.

229− -- If any schema is empty, we remove it from the list which constitutes a change.

230− mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)

231− case catMaybes mSchemas of

232− [] -> mBottom

233− schs -> pure schs

234− oneOf' <- forM (tracedOneOf sch) $ \rss -> do

235− -- Same as anyOf'. By intersecting we're only making them more disjoint if anything.

236− mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)

237− case catMaybes mSchemas of

238− [] -> mBottom

239− schs -> pure schs

240− let sch' = (extract sch) {_schemaAllOf = allOf', _schemaAnyOf = anyOf', _schemaOneOf = oneOf'}

241− -- Now the local changes:

242− case loc of

243− PInProperty k loc' -> case IOHM.lookup k $ tracedProperties sch of

244− Nothing -> error $ "Partitioning via absent property: " <> T.unpack k

245− Just prop -> do

246− prop' <- intersectRefSchema loc' part prop

247− pure $ sch' {_schemaProperties = IOHM.adjust (const prop') k $ _schemaProperties sch'}

248− PHere -> case part of

249− CByEnumValue vals -> do

250− enum' <- case _schemaEnum sch' of

251− Nothing -> do

252− mChange

253− pure $ S.toList vals

254− Just xs -> do

255− when (any (`S.notMember` vals) xs) mChange

256− case filter (`S.member` vals) xs of

257− [] -> mBottom

258− xs' -> pure xs'

259− pure $ sch' {_schemaEnum = Just enum'}

260− CByProperties {} -> error "CByProperties not implemented"

261−

262−intersectRefSchema ::

263− PartitionLocation ->

264− PartitionChoice ->

265− Traced (Referenced Schema) ->

266− IntersectionM (Referenced Schema)

267−intersectRefSchema loc part rs = do

268− defs <- R.ask

269− Inline <$> intersectSchema loc part (dereference defs rs)

270−

271−intersectCondition :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> Condition t -> DNF (Condition t)

272−intersectCondition _defs PHere (CByEnumValue values) cond@(Exactly x) =

273− if untypeValue x `S.member` values then LiteralDNF cond else bottom

274−intersectCondition defs (PInProperty k loc) part cond@(Properties props add madd) = case M.lookup k props of

275− Nothing -> LiteralDNF cond -- shouldn't happen

276− Just prop -> case runIntersectionM defs $ intersectRefSchema loc part $ propRefSchema prop of

277− New rs' ->

278− let trs' = traced (ask (propRefSchema prop) >>> step (Partitioned (loc, part))) rs'

279− in LiteralDNF $ Properties (M.insert k prop {propRefSchema = trs'} props) add madd

280− Same _ -> LiteralDNF cond

281− Disjoint -> bottom

282−intersectCondition _defs _loc _part cond = LiteralDNF cond

283−

284−intersectFormula :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> JsonFormula t -> JsonFormula t

285−intersectFormula defs loc part = JsonFormula . foldDNF (intersectCondition defs loc part) . getJsonFormula

286−

287−tryPartition :: ProdCons (Traced (Definitions Schema)) -> ProdCons (JsonFormula t) -> [(Maybe Partition, ProdCons (JsonFormula t))]

288−tryPartition defs pc = case selectPartition $ partitionJsonFormulas defs pc of

289− Nothing -> [(Nothing, pc)]

290− Just (loc, parts) -> [(Just (loc, part), intersectFormula <$> defs <*> pure loc <*> pure part <*> pc) | part <- S.toList parts]

291−

292−showPartition :: Partition -> Inlines

293−showPartition = \case

294− (partition, CByEnumValue (S.toList -> [v])) ->

295− renderPartitionLocation partition <> " is " <> showJSONValueInline v

296− (partition, CByEnumValue (S.toList -> vs)) ->

297− renderPartitionLocation partition <> " has values: "

298− <> (fold . L.intersperse ", " . fmap showJSONValueInline $ vs)

299− (partition, CByProperties (S.toList -> incl) (S.toList -> [])) ->

300− renderPartitionLocation partition <> " contains the properties: " <> listCodes incl

301− (partition, CByProperties (S.toList -> []) (S.toList -> excl)) ->

302− renderPartitionLocation partition <> " does not contain the properties: " <> listCodes excl

303− (partition, CByProperties (S.toList -> incl) (S.toList -> excl)) ->

304− renderPartitionLocation partition

305− <> " contains the properties "

306− <> listCodes incl

307− <> " and does not contain the properties "

308− <> listCodes excl

309− where

310− listCodes :: [Text] -> Inlines

311− listCodes = fold . L.intersperse ", " . fmap code

312− renderPartitionLocation :: PartitionLocation -> Inlines

313− renderPartitionLocation p = code $ "$" <> renderPartitionLocation' p

314− where

315− renderPartitionLocation' :: PartitionLocation -> Text

316− renderPartitionLocation' PHere = mempty

317− renderPartitionLocation' (PInProperty prop rest) = "." <> prop <> renderPartitionLocation' rest

src/Data/OpenApi/Compare/Validate/Schema/Process.hsdeleted−377

@@ -1,377 +0,0 @@

1−module Data.OpenApi.Compare.Validate.Schema.Process

2− ( schemaToFormula,

3− )

4−where

5−

6−import Algebra.Lattice

7−import Control.Monad.Reader hiding (ask)

8−import qualified Control.Monad.Reader as R

9−import Control.Monad.State

10−import Control.Monad.Writer

11−import qualified Data.Aeson as A

12−import Data.Functor.Identity

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

14−import qualified Data.Map as M

15−import Data.Maybe

16−import Data.OpenApi hiding (get)

17−import Data.OpenApi.Compare.Behavior

18−import Data.OpenApi.Compare.Memo

19−import Data.OpenApi.Compare.Paths

20−import qualified Data.OpenApi.Compare.PathsPrefixTree as P

21−import Data.OpenApi.Compare.References

22−import Data.OpenApi.Compare.Subtree

23−import Data.OpenApi.Compare.Validate.Schema.DNF

24−import Data.OpenApi.Compare.Validate.Schema.Issues

25−import Data.OpenApi.Compare.Validate.Schema.JsonFormula

26−import Data.OpenApi.Compare.Validate.Schema.Partition

27−import Data.OpenApi.Compare.Validate.Schema.Traced

28−import Data.OpenApi.Compare.Validate.Schema.TypedJson

29−import Data.Ord

30−import qualified Data.Set as S

31−

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

33−newtype Silent w a = Silent {runSilent :: a}

34− deriving stock (Functor)

35− deriving (Applicative, Monad) via Identity

36−

37−instance Monoid w => MonadWriter w (Silent w) where

38− tell _ = Silent ()

39− listen (Silent x) = Silent (x, mempty)

40− pass (Silent (x, _)) = Silent x

41−

42−instance MonadState (MemoState ()) (Silent w) where

43− get = Silent $ runIdentity $ runMemo () get

44− put _ = pure ()

45−

46−type ProcessM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))

47−

48−type SilentM = ReaderT (Traced (Definitions Schema)) (Silent (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))

49−

50−-- Either SilentM or ProcessM

51−type MonadProcess m =

52− ( MonadReader (Traced (Definitions Schema)) m

53− , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m

54− , MonadState (MemoState ()) m

55− )

56−

57−warn :: MonadProcess m => Issue 'SchemaLevel -> m ()

58−warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue

59−

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

61−silently :: MonadProcess m => SilentM a -> m a

62−silently m = do

63− defs <- R.ask

64− pure . runSilent $ runReaderT m defs

65−

66−warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m

67−warnKnot =

68− KnotTier

69− { onKnotFound = warn UnguardedRecursion

70− , onKnotUsed = \_ -> pure bottom

71− , tieKnot = \_ -> pure

72− }

73−

74−processRefSchema ::

75− MonadProcess m =>

76− Traced (Referenced Schema) ->

77− m (ForeachType JsonFormula)

78−processRefSchema x = do

79− defs <- R.ask

80− memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)

81−

82−-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition

83−-- for every possible type of a JSON value. The conditions are independent, and

84−-- are thus checked independently.

85−processSchema ::

86− MonadProcess m =>

87− Traced Schema ->

88− m (ForeachType JsonFormula)

89−processSchema sch@(extract -> Schema {..}) = do

90− let singletonFormula :: Condition t -> JsonFormula t

91− singletonFormula = JsonFormula . LiteralDNF

92−

93− allClauses <- case tracedAllOf sch of

94− Nothing -> pure []

95− Just [] -> [] <$ warn (InvalidSchema "no items in allOf")

96− Just xs -> mapM processRefSchema xs

97−

98− anyClause <- case tracedAnyOf sch of

99− Nothing -> pure top

100− Just [] -> bottom <$ warn (InvalidSchema "no items in anyOf")

101− Just xs -> joins <$> mapM processRefSchema xs

102−

103− oneClause <- case tracedOneOf sch of

104− Nothing -> pure top

105− Just [] -> bottom <$ warn (InvalidSchema "no items in oneOf")

106− Just xs -> do

107− checkOneOfDisjoint xs >>= \case

108− True -> pure ()

109− False -> warn OneOfNotDisjoint

110− joins <$> mapM processRefSchema xs

111−

112− case _schemaNot of

113− Nothing -> pure ()

114− Just _ -> warn (NotSupported "not clause is unsupported")

115−

116− let typeClause = case _schemaType of

117− Nothing -> top

118− Just OpenApiNull ->

119− bottom

120− { forNull = top

121− }

122− Just OpenApiBoolean ->

123− bottom

124− { forBoolean = top

125− }

126− Just OpenApiNumber ->

127− bottom

128− { forNumber = top

129− }

130− Just OpenApiInteger ->

131− bottom

132− { forNumber = singletonFormula $ MultipleOf 1

133− }

134− Just OpenApiString ->

135− bottom

136− { forString = top

137− }

138− Just OpenApiArray ->

139− bottom

140− { forArray = top

141− }

142− Just OpenApiObject ->

143− bottom

144− { forObject = top

145− }

146−

147− let valueEnum A.Null =

148− bottom

149− { forNull = singletonFormula $ Exactly TNull

150− }

151− valueEnum (A.Bool b) =

152− bottom

153− { forBoolean = singletonFormula $ Exactly $ TBool b

154− }

155− valueEnum (A.Number n) =

156− bottom

157− { forNumber = singletonFormula $ Exactly $ TNumber n

158− }

159− valueEnum (A.String s) =

160− bottom

161− { forString = singletonFormula $ Exactly $ TString s

162− }

163− valueEnum (A.Array a) =

164− bottom

165− { forArray = singletonFormula $ Exactly $ TArray a

166− }

167− valueEnum (A.Object o) =

168− bottom

169− { forObject = singletonFormula $ Exactly $ TObject o

170− }

171− enumClause <- case _schemaEnum of

172− Nothing -> pure top

173− Just [] -> bottom <$ warn (InvalidSchema "no items in enum")

174− Just xs -> pure $ joins (valueEnum <$> xs)

175−

176− let maximumClause = case _schemaMaximum of

177− Nothing -> top

178− Just n ->

179− top

180− { forNumber = singletonFormula $

181− Maximum $

182− case _schemaExclusiveMaximum of

183− Just True -> Exclusive n

184− _ -> Inclusive n

185− }

186−

187− minimumClause = case _schemaMinimum of

188− Nothing -> top

189− Just n ->

190− top

191− { forNumber = singletonFormula $

192− Minimum $

193− Down $

194− case _schemaExclusiveMinimum of

195− Just True -> Exclusive $ Down n

196− _ -> Inclusive $ Down n

197− }

198−

199− multipleOfClause = case _schemaMultipleOf of

200− Nothing -> top

201− Just n ->

202− top

203− { forNumber = singletonFormula $ MultipleOf n

204− }

205−

206− formatClause <- case _schemaFormat of

207− Nothing -> pure top

208− Just f

209− | f `elem` ["int32", "int64", "float", "double"] ->

210− pure

211− top

212− { forNumber = singletonFormula $ NumberFormat f

213− }

214− Just f

215− | f `elem` ["byte", "binary", "date", "date-time", "password", "uuid"] ->

216− pure

217− top

218− { forString = singletonFormula $ StringFormat f

219− }

220− Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)

221−

222− let maxLengthClause = case _schemaMaxLength of

223− Nothing -> top

224− Just n ->

225− top

226− { forString = singletonFormula $ MaxLength n

227− }

228−

229− minLengthClause = case _schemaMinLength of

230− Nothing -> top

231− Just n ->

232− top

233− { forString = singletonFormula $ MinLength n

234− }

235−

236− patternClause = case _schemaPattern of

237− Nothing -> top

238− Just p ->

239− top

240− { forString = singletonFormula $ Pattern p

241− }

242−

243− itemsClause <- case tracedItems sch of

244− Nothing -> pure top

245− Just (Left rs) -> do

246− f <- silently $ processRefSchema rs

247− pure top {forArray = singletonFormula $ Items f rs}

248− Just (Right rss) -> do

249− fsrs <- forM rss $ \rs -> do

250− f <- silently $ processRefSchema rs

251− pure (f, rs)

252− pure top {forArray = singletonFormula $ TupleItems fsrs}

253−

254− let maxItemsClause = case _schemaMaxItems of

255− Nothing -> top

256− Just n ->

257− top

258− { forArray = singletonFormula $ MaxItems n

259− }

260−

261− minItemsClause = case _schemaMinItems of

262− Nothing -> top

263− Just n ->

264− top

265− { forArray = singletonFormula $ MinItems n

266− }

267−

268− uniqueItemsClause = case _schemaUniqueItems of

269− Just True ->

270− top

271− { forArray = singletonFormula UniqueItems

272− }

273− _ -> top

274−

275− (addProps, addPropSchema) <- case tracedAdditionalProperties sch of

276− Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)

277− Just (Left False) -> pure (bottom, Nothing)

278− _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)

279− propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do

280− (f, psch) <- case IOHM.lookup k $ tracedProperties sch of

281− Just rs -> (,rs) <$> silently (processRefSchema rs)

282− Nothing ->

283− let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty

284− in -- The mempty here is incorrect, but if addPropSchema was Nothing, then

285− -- addProps is bottom, and k is in _schemaRequired. We handle this situation

286− -- below and short-circuit the entire Properties condition to bottom

287− pure (addProps, fromMaybe fakeSchema addPropSchema)

288− pure (k, Property (k `elem` _schemaRequired) f psch)

289− let allBottom f = getAll $

290− foldType $ \_ ty -> case getJsonFormula $ ty f of

291− BottomDNF -> All True

292− _ -> All False

293− allTop f = getAll $

294− foldType $ \_ ty -> case getJsonFormula $ ty f of

295− TopDNF -> All True

296− _ -> All False

297− -- remove optional fields whose schemata match that of additional props

298− propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList

299− propertiesClause

300− | any (\p -> propRequired p && allBottom (propFormula p)) propMap =

301− bottom -- if any required field has unsatisfiable schema

302− | M.null propMap

303− , allTop addProps =

304− top -- if all fields are optional and have trivial schemata

305− | otherwise =

306− top

307− { forObject = singletonFormula $ Properties propMap addProps addPropSchema

308− }

309−

310− maxPropertiesClause = case _schemaMaxProperties of

311− Nothing -> top

312− Just n ->

313− top

314− { forObject = singletonFormula $ MaxProperties n

315− }

316−

317− minPropertiesClause = case _schemaMinProperties of

318− Nothing -> top

319− Just n ->

320− top

321− { forObject = singletonFormula $ MinProperties n

322− }

323−

324− nullableClause

325− | Just True <- _schemaNullable =

326− bottom

327− { forNull = singletonFormula $ Exactly TNull

328− }

329− | otherwise = bottom

330−

331− pure $

332− nullableClause

333− \/ meets

334− ( allClauses

335− <> [ anyClause

336− , oneClause

337− , typeClause

338− , enumClause

339− , maximumClause

340− , minimumClause

341− , multipleOfClause

342− , formatClause

343− , maxLengthClause

344− , minLengthClause

345− , patternClause

346− , itemsClause

347− , maxItemsClause

348− , minItemsClause

349− , uniqueItemsClause

350− , propertiesClause

351− , maxPropertiesClause

352− , minPropertiesClause

353− ]

354− )

355−

356−{- TODO: ReadOnly/WriteOnly #68 -}

357−

358−checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool

359−checkOneOfDisjoint schs = do

360− defs <- R.ask

361− pure $ case selectPartition $ joins $ runPartitionM defs $ traverse partitionRefSchema schs of

362− Nothing -> False

363− Just (loc, parts) ->

364− let intersects part sch = case runIntersectionM defs $ intersectRefSchema loc part sch of

365− Disjoint -> False

366− _ -> True

367− in all (\part -> 1 >= length (filter (intersects part) schs)) parts

368− where

369−

370−runProcessM :: Traced (Definitions Schema) -> ProcessM a -> (a, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

371−runProcessM defs = runWriter . (`runReaderT` defs) . runMemo ()

372−

373−schemaToFormula ::

374− Traced (Definitions Schema) ->

375− Traced Schema ->

376− (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

377−schemaToFormula defs rs = runProcessM defs $ processSchema rs

src/Data/OpenApi/Compare/Validate/Schema/Traced.hsdeleted−115

@@ -1,115 +0,0 @@

1−{-# OPTIONS_GHC -Wno-orphans #-}

2−

3−module Data.OpenApi.Compare.Validate.Schema.Traced

4− ( Step (..),

5− tracedAllOf,

6− tracedAnyOf,

7− tracedOneOf,

8− tracedItems,

9− tracedAdditionalProperties,

10− tracedDiscriminator,

11− tracedProperties,

12− tracedConjunct,

13− PartitionLocation (..),

14− PartitionChoice (..),

15− Partition,

16− )

17−where

18−

19−import qualified Data.Aeson as A

20−import Data.Functor

21−import qualified Data.HashMap.Strict.InsOrd as IOHM

22−import qualified Data.List.NonEmpty as NE

23−import Data.OpenApi

24−import Data.OpenApi.Compare.Subtree

25−import qualified Data.Set as S

26−import Data.Text (Text)

27−

28−data PartitionChoice

29− = CByEnumValue (S.Set A.Value)

30− | CByProperties (S.Set Text) (S.Set Text) -- included, excluded

31− deriving stock (Eq, Ord, Show)

32−

33−data PartitionLocation

34− = PHere

35− | PInProperty Text PartitionLocation

36− deriving stock (Eq, Ord, Show)

37−

38−type Partition = (PartitionLocation, PartitionChoice)

39−

40−instance Steppable Schema (Referenced Schema) where

41− data Step Schema (Referenced Schema)

42− = AllOfStep Int

43− | OneOfStep Int

44− | AnyOfStep Int

45− | ItemsObjectStep

46− | ItemsArrayStep Int

47− | AdditionalPropertiesStep

48− | NotStep

49− | ImplicitTopSchema

50− deriving stock (Eq, Ord, Show)

51−

52−instance Steppable (Referenced Schema) (Referenced Schema) where

53− data Step (Referenced Schema) (Referenced Schema)

54− = -- | Invariant (for better memoization only): the "tail" of the trace is

55− -- the "least" of the traces of the conjuncted schemata

56− ConjunctedWith (NE.NonEmpty (Trace (Referenced Schema)))

57− | Partitioned Partition

58− deriving stock (Eq, Ord, Show)

59−

60−instance Steppable Schema (Definitions (Referenced Schema)) where

61− data Step Schema (Definitions (Referenced Schema)) = PropertiesStep

62− deriving stock (Eq, Ord, Show)

63−

64−instance Steppable Schema Discriminator where

65− data Step Schema Discriminator = DiscriminatorStep

66− deriving stock (Eq, Ord, Show)

67−

68−instance Steppable Discriminator (Definitions (Referenced Schema)) where

69− data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping

70− deriving stock (Eq, Ord, Show)

71−

72−tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

73−tracedAllOf sch =

74− _schemaAllOf (extract sch) <&> \xs ->

75− [traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0 ..] xs]

76−

77−tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

78−tracedAnyOf sch =

79− _schemaAnyOf (extract sch) <&> \xs ->

80− [traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0 ..] xs]

81−

82−tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

83−tracedOneOf sch =

84− _schemaOneOf (extract sch) <&> \xs ->

85− [traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0 ..] xs]

86−

87−tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])

88−tracedItems sch =

89− _schemaItems (extract sch) <&> \case

90− OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x

91− OpenApiItemsArray xs ->

92− Right

93− [traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0 ..] xs]

94−

95−tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))

96−tracedAdditionalProperties sch =

97− _schemaAdditionalProperties (extract sch) <&> \case

98− AdditionalPropertiesAllowed b -> Left b

99− AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x

100−

101−tracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)

102−tracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator

103−

104−tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))

105−tracedProperties sch =

106− IOHM.mapWithKey

107− (\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))

108− (_schemaProperties $ extract sch)

109−

110−tracedConjunct :: NE.NonEmpty (Traced (Referenced Schema)) -> Traced (Referenced Schema)

111−tracedConjunct refSchemas = case NE.sortWith ask refSchemas of

112− (rs NE.:| []) -> rs

113− (rs1 NE.:| rs2 : rss) ->

114− traced (ask rs1 >>> step (ConjunctedWith $ ask <$> rs2 NE.:| rss)) $

115− Inline mempty {_schemaAllOf = Just $ extract <$> rs1 : rs2 : rss}

src/Data/OpenApi/Compare/Validate/Schema/TypedJson.hsdeleted−120

@@ -1,120 +0,0 @@

1−module Data.OpenApi.Compare.Validate.Schema.TypedJson

2− ( JsonType (..),

3− describeJSONType,

4− TypedValue (..),

5− untypeValue,

6− ForeachType (..),

7− foldType,

8− forType_,

9− )

10−where

11−

12−import Algebra.Lattice

13−import qualified Data.Aeson as A

14−import Data.Kind

15−import Data.Monoid

16−import Data.Scientific

17−import Data.String

18−import Data.Text (Text)

19−import Data.Typeable

20−

21−-- | Type of a JSON value

22−data JsonType

23− = Null

24− | Boolean

25− | Number

26− | String

27− | Array

28− | Object

29− deriving stock (Eq, Ord, Show)

30−

31−describeJSONType :: IsString s => JsonType -> s

32−describeJSONType = \case

33− Null -> "Null"

34− Boolean -> "Boolean"

35− Number -> "Number"

36− String -> "String"

37− Array -> "Array"

38− Object -> "Object"

39−

40−-- | A 'A.Value' whose type we know

41−data TypedValue :: JsonType -> Type where

42− TNull :: TypedValue 'Null

43− TBool :: !Bool -> TypedValue 'Boolean

44− TNumber :: !Scientific -> TypedValue 'Number

45− TString :: !Text -> TypedValue 'String

46− TArray :: !A.Array -> TypedValue 'Array

47− TObject :: !A.Object -> TypedValue 'Object

48−

49−deriving stock instance Eq (TypedValue t)

50−

51−deriving stock instance Ord (TypedValue t)

52−

53−deriving stock instance Show (TypedValue t)

54−

55−untypeValue :: TypedValue t -> A.Value

56−untypeValue TNull = A.Null

57−untypeValue (TBool b) = A.Bool b

58−untypeValue (TNumber n) = A.Number n

59−untypeValue (TString s) = A.String s

60−untypeValue (TArray a) = A.Array a

61−untypeValue (TObject o) = A.Object o

62−

63−data ForeachType (f :: JsonType -> Type) = ForeachType

64− { forNull :: f 'Null

65− , forBoolean :: f 'Boolean

66− , forNumber :: f 'Number

67− , forString :: f 'String

68− , forArray :: f 'Array

69− , forObject :: f 'Object

70− }

71−

72−deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)

73−

74−deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)

75−

76−deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)

77−

78−foldType :: Monoid m => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m) -> m

79−foldType k =

80− k Null forNull

81− <> k Boolean forBoolean

82− <> k Number forNumber

83− <> k String forString

84− <> k Array forArray

85− <> k Object forObject

86−

87−forType_ :: Applicative m => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ()) -> m ()

88−forType_ k = getAp $ foldType (\ty proj -> Ap $ k ty proj)

89−

90−broadcastType :: (forall x. Typeable x => f x) -> ForeachType f

91−broadcastType k =

92− ForeachType

93− { forNull = k

94− , forBoolean = k

95− , forNumber = k

96− , forString = k

97− , forArray = k

98− , forObject = k

99− }

100−

101−zipType :: (forall x. Typeable x => f x -> g x -> h x) -> ForeachType f -> ForeachType g -> ForeachType h

102−zipType k f1 f2 =

103− ForeachType

104− { forNull = k (forNull f1) (forNull f2)

105− , forBoolean = k (forBoolean f1) (forBoolean f2)

106− , forNumber = k (forNumber f1) (forNumber f2)

107− , forString = k (forString f1) (forString f2)

108− , forArray = k (forArray f1) (forArray f2)

109− , forObject = k (forObject f1) (forObject f2)

110− }

111−

112−instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where

113− (\/) = zipType (\/)

114− (/\) = zipType (/\)

115−

116−instance (forall x. BoundedJoinSemiLattice (f x)) => BoundedJoinSemiLattice (ForeachType f) where

117− bottom = broadcastType bottom

118−

119−instance (forall x. BoundedMeetSemiLattice (f x)) => BoundedMeetSemiLattice (ForeachType f) where

120− top = broadcastType top

src/Data/OpenApi/Compare/Validate/Sums.hsdeleted−25

@@ -1,25 +0,0 @@

1−module Data.OpenApi.Compare.Validate.Sums

2− ( checkSums,

3− )

4−where

5−

6−import Data.Foldable

7−import Data.Map.Strict (Map)

8−import qualified Data.Map.Strict as M

9−import Data.OpenApi.Compare.Behavior

10−import Data.OpenApi.Compare.Paths

11−import Data.OpenApi.Compare.Subtree

12−

13−checkSums ::

14− (Ord k, Issuable l) =>

15− Paths q r l ->

16− (k -> Issue l) ->

17− (k -> ProdCons t -> CompatFormula' q AnIssue r ()) ->

18− ProdCons (Map k t) ->

19− CompatFormula' q AnIssue r ()

20−checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

21− case M.lookup key c of

22− Nothing -> issueAt xs $ noElt key

23− Just consElt ->

24− let sumElts = ProdCons prodElt consElt

25− in check key sumElts

src/Data/OpenUnion/Extra.hs+5−5

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

11module Data.OpenUnion.Extra

2− ( (@@>),

3− TryLiftUnion (..),

4− pattern SingletonUnion,

2+ ( (@@>)

3+ , TryLiftUnion (..)

4+ , pattern SingletonUnion

55 )

66where

77

@@ -18,8 +18,8 @@ instance TryLiftUnion '[] where

1818 tryLiftUnion _ = empty

1919

2020instance

21− (Typeable y, SubList ys (y : ys), TryLiftUnion ys) =>

22− TryLiftUnion (y ': ys)

21+ (Typeable y, SubList ys (y : ys), TryLiftUnion ys)

22+ => TryLiftUnion (y ': ys)

2323 where

2424 tryLiftUnion (x :: x) = case eqT @x @y of

2525 Nothing -> reUnion <$> tryLiftUnion @ys x

src/Data/OpenApi/Compare/Behavior.hs → src/OpenAPI/Checker/Behavior.hsrenamed+11−49

@@ -1,22 +1,18 @@

1−module Data.OpenApi.Compare.Behavior

2− ( BehaviorLevel (..),

3− Behavable (..),

4− IssueKind (..),

5− Issuable (..),

6− Orientation (..),

7− toggleOrientation,

8− Behavior,

9− AnIssue (..),

10− withClass,

11− anIssueKind,

12− relatedAnIssues,

1+module OpenAPI.Checker.Behavior

2+ ( BehaviorLevel (..)

3+ , Behavable (..)

4+ , Issuable (..)

5+ , Orientation (..)

6+ , toggleOrientation

7+ , Behavior

8+ , AnIssue (..)

139 )

1410where

1511

1612import Data.Aeson

1713import Data.Kind

18−import Data.OpenApi.Compare.Paths

1914import Data.Typeable

15+import OpenAPI.Checker.Paths

2016import Text.Pandoc.Builder

2117

2218-- | Kind

@@ -43,23 +39,10 @@ class

4339 Behavable (a :: BehaviorLevel) (b :: BehaviorLevel)

4440 where

4541 data Behave a b

46− describeBehavior :: Behave a b -> Inlines

42+ describeBehaviour :: Behave a b -> Inlines

4743

4844type instance AdditionalQuiverConstraints Behave a b = Behavable a b

4945

50−data IssueKind

51− = -- | This is certainly an issue, we can demonstrate a "counterexample"

52− CertainIssue

53− | -- | Change looks breaking but we don't have a complete comprehension of the problem

54− ProbablyIssue

55− | -- | We don't really support this feature at all, outside structural comparison

56− Unsupported

57− | -- | This is not an issue in itself, but a clarifying comment providing context for some other issues

58− Comment

59− | -- | We detected an issue with one of the input schemata itself

60− SchemaInvalid

61− deriving stock (Eq, Ord, Show)

62−

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

6447 data Issue l :: Type

6548

@@ -75,22 +58,7 @@ class (Typeable l, Ord (Issue l), Show (Issue l)) => Issuable (l :: BehaviorLeve

7558 -- If _producer_ doesn't have something, the element was "added".

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

7760

78− issueKind :: Issue l -> IssueKind

79−

80− -- | An equivalence relation designating whether two issues are talking about the aspect of the schema. This is used

81− -- to remove duplicates from the "reverse" error tree we get when we look for non-breaking changes.

82− -- Generally if checking X->Y raises issue I, and checking Y->X raises issue J, I and J should be related.

83− relatedIssues :: Issue l -> Issue l -> Bool

84− relatedIssues = (==)

85−

86−-- Utility function for 'relatedIssues'. In @withClass eq f@, @f@ attempts to partition inputs into equivalence classes,

87−-- and two items in the same equivalence class are related. If both items aren't assigned to a class by @f@, instead

88−-- @eq@ is used to compare them.

89−withClass :: Eq b => (a -> a -> Bool) -> (a -> Maybe b) -> a -> a -> Bool

90−withClass eq f = \x y -> case (f x, f y) of

91− (Just fx, Just fy) -> fx == fy

92− (Nothing, Nothing) -> eq x y

93− (_, _) -> False

61+ issueIsUnsupported :: Issue l -> Bool

9462

9563data Orientation = Forward | Backward

9664 deriving stock (Eq, Ord, Show)

@@ -116,9 +84,3 @@ deriving stock instance Ord (AnIssue l)

11684

11785instance ToJSON (AnIssue l) where

11886 toJSON (AnIssue _ issue) = toJSON issue

119−

120−anIssueKind :: AnIssue l -> IssueKind

121−anIssueKind (AnIssue _ i) = issueKind i

122−

123−relatedAnIssues :: AnIssue l -> AnIssue l -> Bool

124−relatedAnIssues (AnIssue _ x) (AnIssue _ y) = relatedIssues x y

src/Data/OpenApi/Compare/Common.hs → src/OpenAPI/Checker/Common.hsrenamed+2−2

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

1−module Data.OpenApi.Compare.Common

2− ( zipAll,

1+module OpenAPI.Checker.Common

2+ ( zipAll

33 )

44where

55

src/Data/OpenApi/Compare/Formula.hs → src/OpenAPI/Checker/Formula.hsrenamed+25−35

@@ -1,21 +1,20 @@

1−module Data.OpenApi.Compare.Formula

2− ( FormulaF,

3− VarRef,

4− variable,

5− eitherOf,

6− anError,

7− errors,

8− calculate,

9− maxFixpoint,

10− mapErrors,

11− )

12−where

1+module OpenAPI.Checker.Formula

2+ ( FormulaF

3+ , VarRef

4+ , variable

5+ , eitherOf

6+ , anError

7+ , errors

8+ , calculate

9+ , maxFixpoint

10+ , mapErrors

11+ ) where

1312

1413import Data.Kind

15−import qualified Data.List.NonEmpty as NE

1614import Data.Monoid

17−import Data.OpenApi.Compare.Paths

18−import qualified Data.OpenApi.Compare.PathsPrefixTree as P

15+import qualified Data.List.NonEmpty as NE

16+import OpenAPI.Checker.Paths

17+import qualified OpenAPI.Checker.PathsPrefixTree as P

1918

2019type VarRef = Int

2120

@@ -25,24 +24,15 @@ type VarRef = Int

2524-- fixpoints always exist, i.e. that @x = f x@ has at least one solution.

2625data FormulaF (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: Type) where

2726 Result :: a -> FormulaF q f r a

28− Errors ::

29− !(P.PathsPrefixTree q f r) ->

30− -- | invariant: never empty

31− FormulaF q f r a

32− Apply ::

33− FormulaF q f r (b -> c) ->

34− FormulaF q f r b ->

35− (c -> a) ->

36− -- | invariant: at least one of LHS and RHS is not 'Errors', and they are

27+ Errors :: !(P.PathsPrefixTree q f r) -> FormulaF q f r a

28+ -- ^ invariant: never empty

29+ Apply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a

30+ -- ^ invariant: at least one of LHS and RHS is not 'Errors', and they are

3731 -- both not 'Result'

38− FormulaF q f r a

39− SelectFirst ::

40− NE.NonEmpty (SomeFormulaF b) ->

41− !(P.PathsPrefixTree q f r) ->

42− (b -> a) ->

43− -- | invariant: the list doesn't contain any 'Result's, 'Errors' or

32+ SelectFirst :: NE.NonEmpty (SomeFormulaF b)

33+ -> !(P.PathsPrefixTree q f r) -> (b -> a) -> FormulaF q f r a

34+ -- ^ invariant: the list doesn't contain any 'Result's, 'Errors' or

4435 -- 'SelectFirst'

45− FormulaF q f r a

4636 Variable :: !VarRef -> a -> FormulaF q f r a

4737

4838mkApply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a

@@ -54,13 +44,13 @@ mkApply f x h = Apply f x h

5444mkSelectFirst :: [SomeFormulaF b] -> P.PathsPrefixTree q f r -> (b -> a) -> FormulaF q f r a

5545mkSelectFirst fs allE h = case foldMap check fs of

5646 (First (Just x), _) -> Result (h x)

57− (First Nothing, x : xs) -> SelectFirst (x NE.:| xs) allE h

47+ (First Nothing, x:xs) -> SelectFirst (x NE.:| xs) allE h

5848 (First Nothing, []) -> Errors allE

5949 where

6050 check (SomeFormulaF (Result x)) = (First (Just x), mempty)

6151 check (SomeFormulaF (Errors _)) = (mempty, mempty)

62− check (SomeFormulaF (SelectFirst xs _ h')) =

63− (mempty, NE.toList (fmap (fmap h') xs))

52+ check (SomeFormulaF (SelectFirst xs _ h'))

53+ = (mempty, NE.toList (fmap (fmap h') xs))

6454 check x = (mempty, [x])

6555

6656data SomeFormulaF (a :: Type) where

@@ -106,7 +96,7 @@ calculate (Apply f x h) = case calculate f of

10696 Right x' -> Right (h (f' x'))

10797calculate (SelectFirst xs e h) = go (NE.toList xs)

10898 where

109− go (SomeFormulaF r : rs) = case calculate r of

99+ go (SomeFormulaF r:rs) = case calculate r of

110100 Left _ -> go rs

111101 Right x -> Right (h x)

112102 go [] = Left e

src/OpenAPI/Checker/Memo.hsnew file+126

@@ -0,0 +1,126 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+-- | Utilities for effectfully memoizing other, more effectful functions.

3+module OpenAPI.Checker.Memo

4+ ( MonadMemo

5+ , MemoState

6+ , runMemo

7+ , modifyMemoNonce

8+ , KnotTier(..)

9+ , unknot

10+ , memoWithKnot

11+ , memoTaggedWithKnot

12+ ) where

13+

14+import Control.Monad.State

15+import Data.Dynamic

16+import qualified Data.Map as M

17+import Data.Tagged

18+import Data.Void

19+import qualified Data.TypeRepMap as T

20+import Type.Reflection

21+

22+data Progress a = Finished a | Started | TyingKnot Dynamic

23+

24+data MemoMap a where

25+ MemoMap :: !(M.Map k (Progress v)) -> MemoMap (k, v)

26+

27+data MemoState s = MemoState s (T.TypeRepMap MemoMap)

28+

29+-- | An effectful memoization monad.

30+type MonadMemo s m = MonadState (MemoState s) m

31+

32+memoStateLookup

33+ :: forall k v s. (Typeable k, Typeable v, Ord k)

34+ => k -> MemoState s -> Maybe (Progress v)

35+memoStateLookup k (MemoState _ t) = case T.lookup @(k, v) t of

36+ Just (MemoMap m) -> M.lookup k m

37+ Nothing -> Nothing

38+

39+memoStateInsert

40+ :: forall k v s. (Typeable k, Typeable v, Ord k)

41+ => k -> Progress v -> MemoState s -> MemoState s

42+memoStateInsert k x (MemoState s t) = MemoState s $ T.insert (MemoMap m'') t

43+ where

44+ m'' = M.insert k x m'

45+ m' = case T.lookup @(k, v) t of

46+ Just (MemoMap m) -> m

47+ Nothing -> M.empty

48+

49+modifyMemoNonce :: MonadMemo s m => (s -> s) -> m s

50+modifyMemoNonce f = do

51+ MemoState s t <- get

52+ put $ MemoState (f s) t

53+ pure s

54+

55+-- | Run a memoized computation.

56+runMemo :: Monad m => s -> StateT (MemoState s) m a -> m a

57+runMemo s = (`evalStateT` MemoState s T.empty)

58+

59+-- | A description of how to effectfully tie knots in type @v@, using the @m@

60+-- monad, and by sharing some @d@ data among the recursive instances.

61+data KnotTier v d m = KnotTier

62+ { onKnotFound :: m d -- ^ Create some data that will be connected to this knot

63+ , onKnotUsed :: d -> m v -- ^ This is what the knot will look like as a value

64+ -- to the inner computations

65+ , tieKnot :: d -> v -> m v -- ^ Once we're done and we're outside, tie the

66+ -- knot using the datum

67+ }

68+

69+unknot :: KnotTier v Void m

70+unknot = KnotTier

71+ { onKnotFound = error "Recursion detected"

72+ , onKnotUsed = absurd

73+ , tieKnot = absurd

74+ }

75+

76+-- | Run a potentially recursive computation. The provided key will be used to

77+-- refer to the result of this computation. If during the computation, another

78+-- attempt to run the computation with the same key is made, we run a

79+-- tying-the-knot procedure.

80+--

81+-- If another attempt to run the computation with the same key is made

82+-- *after we're done*, we will return the memoized value.

83+memoWithKnot

84+ :: forall k v d m s.

85+ (Typeable k, Typeable v, Typeable d, Ord k, MonadMemo s m)

86+ => KnotTier v d m

87+ -> m v -- ^ the computation to memoize

88+ -> k -- ^ key for memoization

89+ -> m v

90+memoWithKnot tier f k = memoStateLookup @k @v k <$> get >>= \case

91+ Just (Finished v) -> pure v

92+ Just Started -> do

93+ d <- onKnotFound tier

94+ modify $ memoStateInsert @k @v k (TyingKnot $ toDyn d)

95+ onKnotUsed tier d

96+ Just (TyingKnot dyn) -> case fromDynamic dyn of

97+ Just d -> onKnotUsed tier d

98+ Nothing -> error $ "Type mismatch when examining the knot of "

99+ <> show (typeRep @(k -> v)) <> ": expected " <> show (typeRep @d)

100+ <> ", got " <> show (dynTypeRep dyn)

101+ Nothing -> do

102+ modify $ memoStateInsert @k @v k Started

103+ v <- f

104+ v' <- memoStateLookup @k @v k <$> get >>= \case

105+ Just Started -> pure v

106+ Just (TyingKnot dyn) -> case fromDynamic dyn of

107+ Just d -> tieKnot tier d v

108+ Nothing -> error $ "Type mismatch when tying the knot of "

109+ <> show (typeRep @(k -> v)) <> ": expected " <> show (typeRep @d)

110+ <> ", got " <> show (dynTypeRep dyn)

111+ Just (Finished _) -> error $ "Unexpected Finished when memoizing "

112+ <> show (typeRep @(k -> v))

113+ Nothing -> pure v

114+ -- Normally this would be an error, but the underlying monad can refuse

115+ -- to remember memoization state

116+ modify $ memoStateInsert @k @v k (Finished v')

117+ pure v'

118+

119+-- | Disambiguate memoized computations with an arbitrary tag.

120+memoTaggedWithKnot

121+ :: forall t k v d m s.

122+ ( Typeable t, Typeable k, Typeable v, Typeable d

123+ , Ord k, MonadMemo s m )

124+ => KnotTier v d m -> m v -> k -> m v

125+memoTaggedWithKnot tier f k = withTypeable (typeRepKind $ typeRep @t) $

126+ memoWithKnot tier f (Tagged @t k)

src/Data/OpenApi/Compare/Orphans.hs → src/OpenAPI/Checker/Orphans.hsrenamed+1−1

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

3−module Data.OpenApi.Compare.Orphans () where

3+module OpenAPI.Checker.Orphans () where

44

55import Control.Comonad.Env

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

src/Data/OpenApi/Compare/Paths.hs → src/OpenAPI/Checker/Paths.hsrenamed+10−10

@@ -1,18 +1,18 @@

11-- | Utilities for traversing heterogeneous trees. A heterogeneous tree is a

22-- collection of datatypes that "contain" eachother in some form of tree

33-- structure.

4−module Data.OpenApi.Compare.Paths

5− ( NiceQuiver,

6− AdditionalQuiverConstraints,

7− Paths (..),

8− DiffPaths (..),

9− catDiffPaths,

10− AnItem (..),

11− step,

4+module OpenAPI.Checker.Paths

5+ ( NiceQuiver

6+ , AdditionalQuiverConstraints

7+ , Paths (..)

8+ , DiffPaths (..)

9+ , catDiffPaths

10+ , AnItem (..)

11+ , step

1212

1313 -- * Reexports

14− (>>>),

15− (<<<),

14+ , (>>>)

15+ , (<<<)

1616 )

1717where

1818

src/Data/OpenApi/Compare/PathsPrefixTree.hs → src/OpenAPI/Checker/PathsPrefixTree.hsrenamed+38−60

@@ -1,22 +1,20 @@

11{-# LANGUAGE QuantifiedConstraints #-}

22

3−module Data.OpenApi.Compare.PathsPrefixTree

4− ( PathsPrefixTree (PathsPrefixNode),

5− AStep (..),

6− empty,

7− singleton,

8− fromList,

9− null,

10− foldWith,

11− toList,

12− filter,

13− filterWithKey,

14− takeSubtree,

15− lookup,

16− embed,

17− size,

18− partition,

19− map,

3+module OpenAPI.Checker.PathsPrefixTree

4+ ( PathsPrefixTree (PathsPrefixNode)

5+ , AStep (..)

6+ , empty

7+ , singleton

8+ , fromList

9+ , null

10+ , foldWith

11+ , toList

12+ , filter

13+ , takeSubtree

14+ , embed

15+ , size

16+ , partition

17+ , map

2018 )

2119where

2220

@@ -27,15 +25,15 @@ import qualified Data.HashMap.Strict as HM

2725import Data.Kind

2826import qualified Data.Map as M

2927import Data.Monoid

30−import Data.OpenApi.Compare.Paths

3128import qualified Data.Set as S

3229import qualified Data.Text as T

3330import Data.Type.Equality

3431import qualified Data.TypeRepMap as TRM

3532import qualified Data.Vector as V

3633import qualified GHC.Exts as Exts

34+import OpenAPI.Checker.Paths

3735import Type.Reflection

38−import Prelude hiding (filter, lookup, map, null)

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

3937

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

4139data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPrefixTree

@@ -58,27 +56,10 @@ filter f (PathsPrefixTree roots branches) = PathsPrefixTree roots' branches'

5856 roots' = filterASet f roots

5957 branches' =

6058 Exts.fromList

61− . fmap (\(TRM.WrapTypeable (AStep x)) -> TRM.WrapTypeable . AStep . M.mapMaybe (maybeNonEmpty . filter f) $ x)

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

6260 . Exts.toList

6361 $ branches

6462

65− maybeNonEmpty = mfilter (not . null) . Just

66−

67−filterWithKey :: (forall a. Paths q r a -> f a -> Bool) -> PathsPrefixTree q f r -> PathsPrefixTree q f r

68−filterWithKey = go Root

69− where

70− go :: Paths q r b -> (forall a. Paths q r a -> f a -> Bool) -> PathsPrefixTree q f b -> PathsPrefixTree q f b

71− go xs f (PathsPrefixTree roots branches) = PathsPrefixTree roots' branches'

72− where

73− roots' = filterASet (f xs) roots

74− branches' =

75− Exts.fromList

76− . fmap (\(TRM.WrapTypeable (AStep x)) -> TRM.WrapTypeable . AStep . M.mapMaybeWithKey (\k -> maybeNonEmpty . go (xs `Snoc` k) f) $ x)

77− . Exts.toList

78− $ branches

79−

80− maybeNonEmpty = mfilter (not . null) . Just

81−

8263-- | The number of leaves.

8364size :: PathsPrefixTree q f r -> Int

8465size (PathsPrefixTree root branches) =

@@ -102,11 +83,11 @@ deriving stock instance Eq (PathsPrefixTree q f a)

10283

10384-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where

10485-- the components are ordered by the @SomeTypeRep@ of the @a@.

105−compareTRM ::

106− (forall a. Typeable a => Ord (f a)) =>

107− TRM.TypeRepMap f ->

108− TRM.TypeRepMap f ->

109− Ordering

86+compareTRM

87+ :: (forall a. Typeable a => Ord (f a))

88+ => TRM.TypeRepMap f

89+ -> TRM.TypeRepMap f

90+ -> Ordering

11091compareTRM s1 s2 =

11192 foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys

11293 where

@@ -116,11 +97,11 @@ compareTRM s1 s2 =

11697 compareMaybe _ Nothing (Just _) = LT

11798 compareMaybe _ (Just _) Nothing = GT

11899 compareMaybe cmp (Just x) (Just y) = cmp x y

119− compareW ::

120− (forall a. Typeable a => Ord (f a)) =>

121− TRM.WrapTypeable f ->

122− TRM.WrapTypeable f ->

123− Ordering

100+ compareW

101+ :: (forall a. Typeable a => Ord (f a))

102+ => TRM.WrapTypeable f

103+ -> TRM.WrapTypeable f

104+ -> Ordering

124105 compareW (TRM.WrapTypeable (x :: f a)) (TRM.WrapTypeable (y :: f b))

125106 | Just Refl <- testEquality (typeRep @a) (typeRep @b) = compare x y

126107 | otherwise = EQ -- unreachable

@@ -172,10 +153,10 @@ instance Monoid (ASet a) where

172153 mempty = AnEmptySet

173154

174155data AStep (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: k) where

175− AStep ::

176− NiceQuiver q r a =>

177− !(M.Map (q r a) (PathsPrefixTree q f a)) ->

178− AStep q f r a

156+ AStep

157+ :: NiceQuiver q r a =>

158+ !(M.Map (q r a) (PathsPrefixTree q f a))

159+ -> AStep q f r a

179160

180161mapAStep :: (forall x. f x -> f x) -> AStep q f r a -> AStep q f r a

181162mapAStep f (AStep m) = AStep $ M.map (map f) m

@@ -215,12 +196,12 @@ null :: PathsPrefixTree q f r -> Bool

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

216197null _ = False

217198

218−foldWith ::

219− forall q f m r.

220− Monoid m =>

221− (forall a. Ord (f a) => Paths q r a -> f a -> m) ->

222− PathsPrefixTree q f r ->

223− m

199+foldWith

200+ :: forall q f m r.

201+ Monoid m

202+ => (forall a. Ord (f a) => Paths q r a -> f a -> m)

203+ -> PathsPrefixTree q f r

204+ -> m

224205foldWith k = goTPT Root

225206 where

226207 goTPT :: forall a. Paths q r a -> PathsPrefixTree q f a -> m

@@ -244,9 +225,6 @@ takeSubtree (Snoc xs x) t =

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

245226 TRM.lookup @a $ snocItems $ takeSubtree xs t

246227

247−lookup :: Paths q r a -> PathsPrefixTree q f r -> S.Set (f a)

248−lookup xs = toSet . rootItems . takeSubtree xs

249−

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

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

252230embed Root t = t

src/Data/OpenApi/Compare/References.hs → src/OpenAPI/Checker/References.hsrenamed+12−11

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

3−module Data.OpenApi.Compare.References

4− ( Step (..),

5− dereference,

6− Typeable,

3+module OpenAPI.Checker.References

4+ ( Step (..)

5+ , dereference

6+ , Typeable

77 )

88where

99

@@ -11,18 +11,19 @@ import Data.HList

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

1212import Data.Maybe

1313import Data.OpenApi

14−import Data.OpenApi.Compare.Orphans ()

15−import Data.OpenApi.Compare.Subtree

14+import Data.Typeable

15+import OpenAPI.Checker.Orphans ()

16+import OpenAPI.Checker.Subtree

1617

1718instance Typeable a => Steppable (Referenced a) a where

1819 data Step (Referenced a) a = InlineStep

1920 deriving stock (Eq, Ord, Show)

2021

21−dereference ::

22− Typeable a =>

23− Traced (Definitions a) ->

24− Traced (Referenced a) ->

25− Traced a

22+dereference

23+ :: Typeable a

24+ => Traced (Definitions a)

25+ -> Traced (Referenced a)

26+ -> Traced a

2627dereference defs x = case extract x of

2728 Inline a ->

2829 traced (ask x >>> step InlineStep) a

src/Data/OpenApi/Compare/Report.hs → src/OpenAPI/Checker/Report.hsrenamed+118−178

@@ -1,13 +1,11 @@

1−module Data.OpenApi.Compare.Report

2− ( generateReport,

3− CheckerOutput (..),

4− ReportInput (..),

5− segregateIssues,

6− ReportStatus (..),

7− Pandoc,

8− ReportConfig (..),

9− ReportTreeStyle (..),

10− ReportMode (..),

1+module OpenAPI.Checker.Report

2+ ( generateReport

3+ , ReportInput (..)

4+ , ReportStatus (..)

5+ , Pandoc

6+ , ReportConfig (..)

7+ , ReportTreeStyle (..)

8+ , ReportMode (..)

119 )

1210where

1311

@@ -23,15 +21,6 @@ import qualified Data.Map as M

2321import Data.Map.Ordered (OMap)

2422import qualified Data.Map.Ordered as OM

2523import Data.Maybe

26−import Data.OpenApi.Compare.Behavior

27−import Data.OpenApi.Compare.Paths

28−import Data.OpenApi.Compare.PathsPrefixTree hiding (empty)

29−import qualified Data.OpenApi.Compare.PathsPrefixTree as P hiding (empty)

30−import Data.OpenApi.Compare.Report.Jet

31−import Data.OpenApi.Compare.Subtree (invertIssueOrientationP)

32−import Data.OpenApi.Compare.Validate.OpenApi

33−import Data.OpenApi.Compare.Validate.Schema.Issues

34−import Data.OpenApi.Compare.Validate.Schema.TypedJson

3524import Data.OpenUnion

3625import Data.OpenUnion.Extra

3726import Data.Set

@@ -41,47 +30,26 @@ import qualified Data.Text as T

4130import Data.TypeRepMap hiding (empty)

4231import Data.Typeable

4332import Generic.Data

33+import OpenAPI.Checker.Behavior

34+import OpenAPI.Checker.Paths

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

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

37+import OpenAPI.Checker.Report.Jet

38+import OpenAPI.Checker.Subtree (invertIssueOrientationP)

39+import OpenAPI.Checker.Validate.OpenApi

40+import OpenAPI.Checker.Validate.Schema

4441import Text.Pandoc.Builder

4542

4643type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel

4744

48−data CheckerOutput = CheckerOutput

49− { forwardChanges :: Changes

50− , backwardChanges :: Changes

51− }

52− deriving stock (Generic)

53− deriving (Semigroup, Monoid) via (Generically CheckerOutput)

54− deriving anyclass (ToJSON)

55−

5645data ReportInput = ReportInput

57− { -- | forward 'CertainIssue', 'ProbablyIssue' and 'Comment'

58− breakingChanges :: Changes

59− , -- | backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'

60− nonBreakingChanges :: Changes

61− , -- | forward and backward 'Unsupported' (assumed to be the same anyway)

62− unsupportedChanges :: Changes

63− , -- | forward and backward 'SchemaInvalid' (assumed to be the same anyway)

64− schemaIssues :: Changes

46+ { breakingChanges :: Changes

47+ , nonBreakingChanges :: Changes

6548 }

6649 deriving stock (Generic)

6750 deriving (Semigroup, Monoid) via (Generically ReportInput)

6851 deriving anyclass (ToJSON)

6952

70−segregateIssues :: CheckerOutput -> ReportInput

71−segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} =

72− ReportInput

73− { breakingChanges = P.filter isBreaking fwd

74− , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck

75− , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck

76− , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck

77− }

78− where

79− isBreaking i = anIssueKind i `elem` [CertainIssue, ProbablyIssue, Comment]

80− isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool

81− isNonBreaking xs i = isBreaking i && all (\j -> not $ relatedAnIssues i j) (P.lookup xs fwd)

82− isUnsupported i = anIssueKind i == Unsupported

83− isSchemaIssue i = anIssueKind i == SchemaInvalid

84−

8553data ReportStatus

8654 = BreakingChanges

8755 | NoBreakingChanges

@@ -109,66 +77,49 @@ data ReportTreeStyle = HeadersTreeStyle | FoldingBlockquotesTreeStyle

10977twoRowTable :: [(Inlines, Inlines)] -> Blocks

11078twoRowTable x = simpleTable (para . fst <$> x) [para . snd <$> x]

11179

112−generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)

80+generateReport :: ReportConfig -> ReportInput -> (Pandoc, ReportStatus)

11381generateReport cfg inp =

114− let schemaIssuesPresent = not $ P.null $ schemaIssues inp

115− breakingChangesPresent = not $ P.null $ breakingChanges inp

116− nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp

117− unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp

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

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

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

85+ unsupported = bUnsupported <> nbUnsupported

86+ breakingChangesPresent = not $ P.null breaking

87+ nonBreakingChangesPresent = not $ P.null nonBreaking

88+ unsupportedChangesPresent = not $ P.null unsupported

11889 nonBreakingChangesShown = case reportMode cfg of

11990 All -> True

12091 OnlyErrors -> False

12192 builder = buildReport cfg

12293 report =

123− header 1 "Summary"

124− <> twoRowTable

125− ( when'

126− schemaIssuesPresent

127− [

128− ( refOpt schemaIssuesPresent schemaIssuesId "‼️ Schema issues"

129− , show' $ P.size $ schemaIssues inp

130− )

131− ]

132− ++ [

133− ( refOpt breakingChangesPresent breakingChangesId "❌ Breaking changes"

134− , show' $ P.size $ breakingChanges inp

94+ doc $

95+ header 1 "Summary"

96+ <> twoRowTable

97+ ([ ( refOpt breakingChangesPresent breakingChangesId "⚠️ Breaking changes"

98+ , show' $ P.size breaking

99+ )

100+ ]

101+ ++ when'

102+ nonBreakingChangesShown

103+ [ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "🙆 Non-breaking changes"

104+ , show' $ P.size nonBreaking

135105 )

136106 ]

137− ++ when'

138− nonBreakingChangesShown

139− [

140− ( refOpt nonBreakingChangesPresent nonBreakingChangesId "⚠️ Non-breaking changes"

141− , show' $ P.size $ nonBreakingChanges inp

142− )

143− ]

144− ++ when'

145− unsupportedChangesPresent

146− [

147− ( refOpt unsupportedChangesPresent unsupportedChangesId "❓ Unsupported feature changes"

148− , show' $ P.size $ unsupportedChanges inp

149− )

150− ]

151− )

152− <> when'

153− schemaIssuesPresent

154− ( header 1 (anchor schemaIssuesId <> "‼️ Schema issues")

155− <> builder (showErrs $ schemaIssues inp)

156− )

157− <> when'

158− breakingChangesPresent

159− ( header 1 (anchor breakingChangesId <> "❌ Breaking changes")

160− <> builder (showErrs $ breakingChanges inp)

161− )

162− <> when'

163− (nonBreakingChangesPresent && nonBreakingChangesShown)

164− ( header 1 (anchor nonBreakingChangesId <> "⚠️ Non-breaking changes")

165− <> builder (showErrs $ nonBreakingChanges inp)

166− )

167− <> when'

168− unsupportedChangesPresent

169− ( header 1 (anchor unsupportedChangesId <> "❓ Unsupported feature changes")

170− <> builder (showErrs $ unsupportedChanges inp)

171− )

107+ ++ [ ( refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"

108+ , show' $ P.size unsupported

109+ )

110+ ])

111+ <> when'

112+ breakingChangesPresent

113+ (header 1 (anchor breakingChangesId <> "⚠️ Breaking changes")

114+ <> builder (showErrs breaking))

115+ <> when'

116+ (nonBreakingChangesPresent && nonBreakingChangesShown)

117+ (header 1 (anchor nonBreakingChangesId <> "🙆 Non-breaking changes")

118+ <> builder (showErrs nonBreaking))

119+ <> when'

120+ unsupportedChangesPresent

121+ (header 1 (anchor unsupportedChangesId <> "🤷 Unsupported feature changes")

122+ <> builder (showErrs unsupported))

172123 status =

173124 if

174125 | breakingChangesPresent -> BreakingChanges

@@ -183,11 +134,10 @@ generateReport cfg inp =

183134 refOpt False _ i = i

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

185136

186− breakingChangesId, nonBreakingChangesId, unsupportedChangesId, schemaIssuesId :: Text

137+ breakingChangesId, nonBreakingChangesId, unsupportedChangesId :: Text

187138 breakingChangesId = "breaking-changes"

188139 unsupportedChangesId = "unsupported-changes"

189140 nonBreakingChangesId = "non-breaking-changes"

190− schemaIssuesId = "schema-issues"

191141

192142 when' :: Monoid m => Bool -> m -> m

193143 when' True m = m

@@ -198,14 +148,13 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =

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

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

200150 , otherIssues :: Set (AnIssue a)

201− ) = case eqT @a @ 'APILevel of

151+ ) = case eqT @a @'APILevel of

202152 Just Refl

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

204154 S.partition

205− ( \((AnIssue _ u)) -> case u of

206− NoPathsMatched {} -> True

207− AllPathsFailed {} -> True

208− )

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

156+ NoPathsMatched {} -> True

157+ AllPathsFailed {} -> True)

209158 currentIssues ->

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

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

@@ -216,10 +165,9 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =

216165 paths = case removedPaths of

217166 Just (ori, ps) -> do

218167 singletonHeader

219− ( case ori of

220− Forward -> "Removed paths"

221− Backward -> "Added paths"

222− )

168+ (case ori of

169+ Forward -> "Removed paths"

170+ Backward -> "Added paths")

223171 $ singletonBody $

224172 bulletList $

225173 ps <&> \case

@@ -231,7 +179,7 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =

231179 flip foldMap (M.toList m) $ \(bhv, subErrors) ->

232180 if P.null subErrors

233181 then mempty

234− else singletonHeader (describeBehavior bhv) $ showErrs subErrors

182+ else singletonHeader (describeBehaviour bhv) $ showErrs subErrors

235183 in issues <> paths <> rest

236184

237185unfoldFunctions :: forall m a. (Monoid m, Eq a) => a -> [a -> (m, a)] -> (a -> m) -> m

@@ -249,68 +197,64 @@ jets =

249197 unwrapReportJetResult

250198 <$> [ constructReportJet $

251199 curry $ \case

252− (OfType Object, p@(InPartition _)) -> Just $ describeBehavior p :: Maybe Inlines

200+ (OfType Object, p@(InPartition _)) -> Just $ describeBehaviour p :: Maybe Inlines

253201 _ -> Nothing

254202 , constructReportJet jsonPathJet

255203 , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->

256− strong (describeBehavior op) <> " " <> describeBehavior p :: Inlines

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

257205 , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->

258− "⬅️☁️ JSON Response – " <> str (T.pack . show $ c) :: Inlines

259− , constructReportJet $ \InRequest InPayload PayloadSchema -> "➡️☁️ JSON Request" :: Inlines

206+ "📱⬅️ JSON Response – " <> str (T.pack . show $ c) :: Inlines

207+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "📱➡️ JSON Request" :: Inlines

260208 ]

261209 where

262210 unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x

263211 unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."

264212 unwrapReportJetResult (Free f) = f

265213

266− jsonPathJet ::

267− NonEmpty

268− ( Union

269− '[ Behave 'SchemaLevel 'TypedSchemaLevel

270− , Behave 'TypedSchemaLevel 'SchemaLevel

271− ]

272− ) ->

273− Inlines

214+ jsonPathJet

215+ :: NonEmpty

216+ ( Union

217+ '[ Behave 'SchemaLevel 'TypedSchemaLevel

218+ , Behave 'TypedSchemaLevel 'SchemaLevel

219+ ]

220+ )

221+ -> Inlines

274222 jsonPathJet x = code $ "$" <> showParts (NE.toList x)

275223 where

276− showParts ::

277− [ Union

278− '[ Behave 'SchemaLevel 'TypedSchemaLevel

279− , Behave 'TypedSchemaLevel 'SchemaLevel

280− ]

281− ] ->

282− Text

224+ showParts

225+ :: [ Union

226+ '[ Behave 'SchemaLevel 'TypedSchemaLevel

227+ , Behave 'TypedSchemaLevel 'SchemaLevel

228+ ]

229+ ]

230+ -> Text

283231 showParts [] = mempty

284232 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs

285233 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs

286234 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs

287− showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs

288235 showParts (y : ys) =

289− ( (\(OfType t) -> "(" <> describeJSONType t <> ")")

290− @@> ( \case

291− InItems -> "[*]"

292− InItem i -> "[" <> T.pack (show i) <> "]"

293− InProperty p -> "." <> p

294− InAdditionalProperty -> ".*"

295− )

296− @@> typesExhausted

297− )

236+ ((\(OfType t) -> "(" <> describeJSONType t <> ")")

237+ @@> (\case

238+ InItems -> "[*]"

239+ InProperty p -> "." <> p

240+ InAdditionalProperty -> ".*")

241+ @@> typesExhausted)

298242 y

299243 <> showParts ys

300244

301−observeJetShowErrs ::

302− ReportJet' Behave (Maybe Inlines) ->

303− P.PathsPrefixTree Behave AnIssue a ->

304− (Report, P.PathsPrefixTree Behave AnIssue a)

245+observeJetShowErrs

246+ :: ReportJet' Behave (Maybe Inlines)

247+ -> P.PathsPrefixTree Behave AnIssue a

248+ -> (Report, P.PathsPrefixTree Behave AnIssue a)

305249observeJetShowErrs jet p = case observeJetShowErrs' jet p of

306250 Just m -> m

307251 Nothing -> (mempty, p)

308252

309−observeJetShowErrs' ::

310− forall a.

311− ReportJet' Behave (Maybe Inlines) ->

312− P.PathsPrefixTree Behave AnIssue a ->

313− Maybe (Report, P.PathsPrefixTree Behave AnIssue a)

253+observeJetShowErrs'

254+ :: forall a.

255+ ReportJet' Behave (Maybe Inlines)

256+ -> P.PathsPrefixTree Behave AnIssue a

257+ -> Maybe (Report, P.PathsPrefixTree Behave AnIssue a)

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

315259 let results =

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

@@ -318,23 +262,21 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)

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

319263 jet @_ @_ @[] bhv

320264 & mapMaybe

321− ( \case

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

323− Pure (Just h) ->

324− if P.null subErrs

325− then Just mempty

326− else Just (singletonHeader h (showErrs subErrs), mempty)

327− Pure Nothing -> Nothing

328− )

265+ (\case

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

267+ Pure (Just h) ->

268+ if P.null subErrs

269+ then Just mempty

270+ else Just (singletonHeader h (showErrs subErrs), mempty)

271+ Pure Nothing -> Nothing)

329272 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $

330273 if any isRight results

331274 then

332275 Just $

333276 foldMap

334− ( \case

335− Left e -> (mempty, e)

336− Right m -> m

337− )

277+ (\case

278+ Left e -> (mempty, e)

279+ Right m -> m)

338280 results

339281 else Nothing

340282

@@ -357,9 +299,8 @@ buildReport cfg = case treeStyle cfg of

357299 body rprt

358300 <> foldOMapWithKey

359301 (headers rprt)

360− ( \k v ->

361− header level k <> subBuilder v

362− )

302+ (\k v ->

303+ header level k <> subBuilder v)

363304 where

364305 subBuilder = headerStyleBuilder (level + 1)

365306

@@ -368,17 +309,16 @@ buildReport cfg = case treeStyle cfg of

368309 body rprt

369310 <> foldOMapWithKey

370311 (headers rprt)

371− ( \k v ->

372− if (OM.size . headers $ rprt) < 2

373− then para k <> blockQuote (subBuilder v)

374− else

375− rawHtml "<details>"

376− <> rawHtml "<summary>"

377− <> plain k

378− <> rawHtml "</summary>"

379− <> blockQuote (subBuilder v)

380− <> rawHtml "</details>"

381− )

312+ (\k v ->

313+ if (OM.size . headers $ rprt) < 2

314+ then para k <> blockQuote (subBuilder v)

315+ else

316+ rawHtml "<details>"

317+ <> rawHtml "<summary>"

318+ <> plain k

319+ <> rawHtml "</summary>"

320+ <> blockQuote (subBuilder v)

321+ <> rawHtml "</details>")

382322 where

383323 subBuilder = foldingStyleBuilder

384324

src/Data/OpenApi/Compare/Report/Html/Template.hs → src/OpenAPI/Checker/Report/Html/Template.hsrenamed+4−4

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

11{-# LANGUAGE TemplateHaskell #-}

22

3−module Data.OpenApi.Compare.Report.Html.Template

4− ( template,

3+module OpenAPI.Checker.Report.Html.Template

4+ ( template

55 )

66where

77

@@ -24,11 +24,11 @@ template =

2424 \<meta charset=\"utf-8\">\

2525 \<title></title>\

2626 \<meta name=\"description\" content=\"\">\

27− \<meta name=\"generator\" content=\"CompaREST\" />\

27+ \<meta name=\"generator\" content=\"OpenApi Diff\" />\

2828 \<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0, user-scalable=yes\" />\

2929 \</head>\

3030 \<body>\

31− \<header><h1>CompaREST</h1></header>\

31+ \<header><h1>⛄ OpenApi Diff</h1></header>\

3232 \<main>\

3333 \$body$\

3434 \</main>\

src/Data/OpenApi/Compare/Report/Jet.hs → src/OpenAPI/Checker/Report/Jet.hsrenamed+6−6

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

1−module Data.OpenApi.Compare.Report.Jet

2− ( ReportJet (..),

3− ReportJet',

4− ConstructReportJet (..),

5− ReportJetResult,

1+module OpenAPI.Checker.Report.Jet

2+ ( ReportJet (..)

3+ , ReportJet'

4+ , ConstructReportJet (..)

5+ , ReportJetResult

66 )

77where

88

@@ -23,7 +23,7 @@ import Text.Pandoc.Builder

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

2424-- https://urbit.org/docs/vere/jetting/

2525--

26−-- The pattern fits well for simplifying 'Behavior' tree paths.

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

2727class ConstructReportJet x f where

2828 constructReportJet :: x -> ReportJetResult f (Maybe Inlines)

2929

src/OpenAPI/Checker/Run.hsnew file+30

@@ -0,0 +1,30 @@

1+module OpenAPI.Checker.Run

2+ ( runChecker

3+ , runReport

4+ , module OpenAPI.Checker.Report

5+ )

6+where

7+

8+import Data.HList

9+import Data.OpenApi (OpenApi)

10+import OpenAPI.Checker.Paths

11+import OpenAPI.Checker.Report

12+import OpenAPI.Checker.Subtree

13+import OpenAPI.Checker.Validate.OpenApi ()

14+

15+runChecker :: (OpenApi, OpenApi) -> ReportInput

16+runChecker (client, server) =

17+ ReportInput

18+ { breakingChanges = run client server

19+ , nonBreakingChanges = run server client

20+ }

21+ where

22+ toPC p c =

23+ ProdCons

24+ { producer = traced (step ClientSchema) p

25+ , consumer = traced (step ServerSchema) c

26+ }

27+ run p c = either id mempty . runCompatFormula . checkCompatibility Root HNil $ toPC p c

28+

29+runReport :: ReportConfig -> (OpenApi, OpenApi) -> (Pandoc, ReportStatus)

30+runReport cfg = generateReport cfg . runChecker

src/Data/OpenApi/Compare/Subtree.hs → src/OpenAPI/Checker/Subtree.hsrenamed+125−132

@@ -1,52 +1,51 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

22

3−module Data.OpenApi.Compare.Subtree

4− ( Steppable (..),

5− Step (..),

6− TraceRoot,

7− Trace,

8− Traced,

9− Traced',

10− pattern Traced,

11− traced,

12− retraced,

13− stepTraced,

14− Subtree (..),

15− checkCompatibility,

16− checkSubstructure,

17− CompatM (..),

18− CompatFormula',

19− SemanticCompatFormula,

20− ProdCons (..),

21− orientProdCons,

22− swapProdCons,

23− runCompatFormula,

24− issueAt,

25− anItem,

26− anIssue,

27− invertIssueOrientation,

28− invertIssueOrientationP,

29− embedFormula,

30− anyOfAt,

31− clarifyIssue,

32− structuralIssue,

3+module OpenAPI.Checker.Subtree

4+ ( Steppable (..)

5+ , Step (..)

6+ , TraceRoot

7+ , Trace

8+ , Traced

9+ , Traced'

10+ , pattern Traced

11+ , traced

12+ , retraced

13+ , stepTraced

14+ , Subtree (..)

15+ , checkCompatibility

16+ , checkSubstructure

17+ , CompatM (..)

18+ , CompatFormula'

19+ , SemanticCompatFormula

20+ , ProdCons (..)

21+ , swapProdCons

22+ , runCompatFormula

23+ , issueAt

24+ , anItem

25+ , anIssue

26+ , invertIssueOrientation

27+ , invertIssueOrientationP

28+ , embedFormula

29+ , anyOfAt

30+ , clarifyIssue

31+ , structuralIssue

3332

3433 -- * Structural helpers

35− structuralMaybe,

36− structuralMaybeWith,

37− structuralEq,

38− iohmStructural,

39− iohmStructuralWith,

40− structuralList,

34+ , structuralMaybe

35+ , structuralMaybeWith

36+ , structuralEq

37+ , iohmStructural

38+ , iohmStructuralWith

39+ , structuralList

4140

4241 -- * Reexports

43− (>>>),

44− (<<<),

45− extract,

46− ask,

47− local,

48− step,

49− Typeable,

42+ , (>>>)

43+ , (<<<)

44+ , extract

45+ , ask

46+ , local

47+ , step

48+ , Typeable

5049 )

5150where

5251

@@ -60,13 +59,13 @@ import qualified Data.HashMap.Strict.InsOrd as IOHM

6059import Data.Hashable

6160import Data.Kind

6261import Data.OpenApi

63−import Data.OpenApi.Compare.Behavior

64−import Data.OpenApi.Compare.Formula

65−import Data.OpenApi.Compare.Memo

66−import Data.OpenApi.Compare.Paths

67−import qualified Data.OpenApi.Compare.PathsPrefixTree as P

6862import qualified Data.Set as S

6963import Data.Typeable

64+import OpenAPI.Checker.Behavior

65+import OpenAPI.Checker.Formula

66+import OpenAPI.Checker.Memo

67+import OpenAPI.Checker.Paths

68+import qualified OpenAPI.Checker.PathsPrefixTree as P

7069

7170class

7271 (Typeable Step, Typeable a, Typeable b, Ord (Step a b), Show (Step a b)) =>

@@ -111,14 +110,10 @@ data ProdCons a = ProdCons

111110 }

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

113112

114−orientProdCons :: Orientation -> ProdCons x -> ProdCons x

115−orientProdCons Forward x = x

116−orientProdCons Backward (ProdCons p c) = ProdCons c p

117−

118−swapProdCons ::

119− SwapEnvRoles xs =>

120− (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a) ->

121− (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

113+swapProdCons

114+ :: SwapEnvRoles xs

115+ => (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

116+ -> (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

122117swapProdCons f e (ProdCons p c) =

123118 invertIssueOrientation $

124119 f (swapEnvRoles e) (ProdCons c p)

@@ -153,8 +148,8 @@ instance Applicative ProdCons where

153148 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)

154149

155150newtype CompatM a = CompatM

156− { unCompatM ::

157− StateT (MemoState VarRef) Identity a

151+ { unCompatM

152+ :: StateT (MemoState VarRef) Identity a

158153 }

159154 deriving newtype

160155 ( Functor

@@ -183,64 +178,64 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where

183178 type CheckEnv t :: [Type]

184179 type SubtreeLevel t :: BehaviorLevel

185180

186− checkStructuralCompatibility ::

187− HList (CheckEnv t) ->

188− ProdCons (Traced t) ->

189− StructuralCompatFormula ()

181+ checkStructuralCompatibility

182+ :: HList (CheckEnv t)

183+ -> ProdCons (Traced t)

184+ -> StructuralCompatFormula ()

190185

191− checkSemanticCompatibility ::

192− HList (CheckEnv t) ->

193− Behavior (SubtreeLevel t) ->

194− ProdCons (Traced t) ->

195− SemanticCompatFormula ()

186+ checkSemanticCompatibility

187+ :: HList (CheckEnv t)

188+ -> Behavior (SubtreeLevel t)

189+ -> ProdCons (Traced t)

190+ -> SemanticCompatFormula ()

196191

197192{-# WARNING checkStructuralCompatibility "You should not be calling this directly. Use 'checkSubstructure'" #-}

198193

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

200195

201−checkCompatibility ::

202− forall t xs.

203− (ReassembleHList xs (CheckEnv t), Subtree t) =>

204− Behavior (SubtreeLevel t) ->

205− HList xs ->

206− ProdCons (Traced t) ->

207− SemanticCompatFormula ()

196+checkCompatibility

197+ :: forall t xs.

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

199+ => Behavior (SubtreeLevel t)

200+ -> HList xs

201+ -> ProdCons (Traced t)

202+ -> SemanticCompatFormula ()

208203checkCompatibility bhv e = memo bhv SemanticMemoKey $ \pc ->

209204 case runCompatFormula $ checkSubstructure e pc of

210205 Left _ -> checkSemanticCompatibility (reassemble e) bhv pc

211206 Right () -> pure ()

212207{-# INLINE checkCompatibility #-}

213208

214−checkSubstructure ::

215− (ReassembleHList xs (CheckEnv t), Subtree t) =>

216− HList xs ->

217− ProdCons (Traced t) ->

218− StructuralCompatFormula ()

209+checkSubstructure

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

211+ => HList xs

212+ -> ProdCons (Traced t)

213+ -> StructuralCompatFormula ()

219214checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility (reassemble e)

220215{-# INLINE checkSubstructure #-}

221216

222−structuralMaybe ::

223− (Subtree a, ReassembleHList xs (CheckEnv a)) =>

224− HList xs ->

225− ProdCons (Maybe (Traced a)) ->

226− StructuralCompatFormula ()

217+structuralMaybe

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

219+ => HList xs

220+ -> ProdCons (Maybe (Traced a))

221+ -> StructuralCompatFormula ()

227222structuralMaybe e = structuralMaybeWith (checkSubstructure e)

228223{-# INLINE structuralMaybe #-}

229224

230−structuralMaybeWith ::

231− (ProdCons a -> StructuralCompatFormula ()) ->

232− ProdCons (Maybe a) ->

233− StructuralCompatFormula ()

225+structuralMaybeWith

226+ :: (ProdCons a -> StructuralCompatFormula ())

227+ -> ProdCons (Maybe a)

228+ -> StructuralCompatFormula ()

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

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

236231structuralMaybeWith _ _ = structuralIssue

237232{-# INLINE structuralMaybeWith #-}

238233

239−structuralList ::

240− (Subtree a, ReassembleHList xs (CheckEnv a)) =>

241− HList xs ->

242− ProdCons [Traced a] ->

243− StructuralCompatFormula ()

234+structuralList

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

236+ => HList xs

237+ -> ProdCons [Traced a]

238+ -> StructuralCompatFormula ()

244239structuralList _ (ProdCons [] []) = pure ()

245240structuralList e (ProdCons (a : aa) (b : bb)) = do

246241 checkSubstructure e $ ProdCons a b

@@ -253,11 +248,11 @@ structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula (

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

254249{-# INLINE structuralEq #-}

255250

256−iohmStructural ::

257− (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k) =>

258− HList xs ->

259− ProdCons (Traced (IOHM.InsOrdHashMap k v)) ->

260− StructuralCompatFormula ()

251+iohmStructural

252+ :: (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k)

253+ => HList xs

254+ -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

255+ -> StructuralCompatFormula ()

261256iohmStructural e =

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

263258{-# INLINE iohmStructural #-}

@@ -266,26 +261,25 @@ instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMa

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

267262 deriving stock (Eq, Ord, Show)

268263

269−iohmStructuralWith ::

270− (Ord k, Hashable k, Typeable k, Typeable v, Show k) =>

271− (k -> ProdCons (Traced v) -> StructuralCompatFormula ()) ->

272− ProdCons (Traced (IOHM.InsOrdHashMap k v)) ->

273− StructuralCompatFormula ()

264+iohmStructuralWith

265+ :: (Ord k, Hashable k, Typeable k, Typeable v, Show k)

266+ => (k -> ProdCons (Traced v) -> StructuralCompatFormula ())

267+ -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

268+ -> StructuralCompatFormula ()

274269iohmStructuralWith f pc = do

275270 let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys . extract <$> pc

276271 if pEKeys == cEKeys

277272 then

278273 for_

279274 pEKeys

280− ( \eKey ->

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

282− )

275+ (\eKey ->

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

283277 else structuralIssue

284278{-# INLINE iohmStructuralWith #-}

285279

286−runCompatFormula ::

287− CompatFormula' q f r a ->

288− Either (P.PathsPrefixTree q f r) a

280+runCompatFormula

281+ :: CompatFormula' q f r a

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

289283runCompatFormula (Compose f) =

290284 calculate . runIdentity . runMemo 0 . unCompatM $ f

291285{-# INLINE runCompatFormula #-}

@@ -315,27 +309,27 @@ invertIssueOrientationP = P.map (\(AnIssue ori i) -> AnIssue (toggleOrientation

315309structuralIssue :: StructuralCompatFormula a

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

317311

318−anyOfAt ::

319− Issuable l =>

320− Paths q r l ->

321− Issue l ->

322− [CompatFormula' q AnIssue r a] ->

323− CompatFormula' q AnIssue r a

312+anyOfAt

313+ :: Issuable l

314+ => Paths q r l

315+ -> Issue l

316+ -> [CompatFormula' q AnIssue r a]

317+ -> CompatFormula' q AnIssue r a

324318anyOfAt _ _ [x] = x

325319anyOfAt xs issue fs =

326320 Compose $ (`eitherOf` AnItem xs (anIssue issue)) <$> traverse getCompose fs

327321

328322-- | If the given formula contains any issues, add another issue on top. Otherwise succeed.

329−clarifyIssue ::

330− AnItem q AnIssue r ->

331− CompatFormula' q AnIssue r a ->

332− CompatFormula' q AnIssue r a

323+clarifyIssue

324+ :: AnItem q AnIssue r

325+ -> CompatFormula' q AnIssue r a

326+ -> CompatFormula' q AnIssue r a

333327clarifyIssue item f =

334328 Compose ((`eitherOf` item) <$> pure <$> getCompose f) *> f

335329

336−fixpointKnot ::

337− MonadState (MemoState VarRef) m =>

338− KnotTier (FormulaF q f r ()) VarRef m

330+fixpointKnot

331+ :: MonadState (MemoState VarRef) m

332+ => KnotTier (FormulaF q f r ()) VarRef m

339333fixpointKnot =

340334 KnotTier

341335 { onKnotFound = modifyMemoNonce succ

@@ -343,20 +337,19 @@ fixpointKnot =

343337 , tieKnot = \i x -> pure $ maxFixpoint i x

344338 }

345339

346−memo ::

347− (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a) =>

348− Paths q r l ->

349− MemoKey ->

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

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

340+memo

341+ :: (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a)

342+ => Paths q r l

343+ -> MemoKey

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

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

352346memo bhv k f pc = Compose $ do

353347 formula' <-

354348 memoWithKnot

355349 fixpointKnot

356− ( do

357− formula <- getCompose $ f pc

358− pure $ mapErrors (P.takeSubtree bhv) formula

359− )

350+ (do

351+ formula <- getCompose $ f pc

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

360353 (k, ask <$> pc)

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

362355

src/Data/OpenApi/Compare/Validate/Header.hs → src/OpenAPI/Checker/Validate/Header.hsrenamed+7−9

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

3−module Data.OpenApi.Compare.Validate.Header

3+module OpenAPI.Checker.Validate.Header

44 (

55 )

66where

@@ -9,10 +9,10 @@ import Data.Foldable

99import Data.Functor

1010import Data.Maybe

1111import Data.OpenApi

12−import Data.OpenApi.Compare.Behavior

13−import Data.OpenApi.Compare.References ()

14−import Data.OpenApi.Compare.Subtree

15−import Data.OpenApi.Compare.Validate.Schema ()

12+import OpenAPI.Checker.Behavior

13+import OpenAPI.Checker.References ()

14+import OpenAPI.Checker.Subtree

15+import OpenAPI.Checker.Validate.Schema ()

1616import Text.Pandoc.Builder

1717

1818instance Subtree Header where

@@ -50,9 +50,7 @@ instance Issuable 'HeaderLevel where

5050 | NonEmptyHeaderRequired

5151 | HeaderSchemaRequired

5252 deriving stock (Eq, Ord, Show)

53− issueKind = \case

54− HeaderSchemaRequired -> ProbablyIssue -- catch-all schema?

55− _ -> CertainIssue

53+ issueIsUnsupported _ = False

5654 describeIssue Forward RequiredHeaderMissing = para "Header has become required."

5755 describeIssue Backward RequiredHeaderMissing = para "Header is no longer required."

5856 describeIssue Forward NonEmptyHeaderRequired = para "The header does not allow empty values anymore."

@@ -63,4 +61,4 @@ instance Behavable 'HeaderLevel 'SchemaLevel where

6361 data Behave 'HeaderLevel 'SchemaLevel

6462 = InSchema

6563 deriving stock (Eq, Ord, Show)

66− describeBehavior InSchema = "JSON Schema"

64+ describeBehaviour InSchema = "JSON Schema"

src/Data/OpenApi/Compare/Validate/Link.hs → src/OpenAPI/Checker/Validate/Link.hsrenamed+6−6

@@ -1,10 +1,10 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

22

3−module Data.OpenApi.Compare.Validate.Link () where

3+module OpenAPI.Checker.Validate.Link () where

44

55import Data.OpenApi

6−import Data.OpenApi.Compare.Behavior

7−import Data.OpenApi.Compare.Subtree

6+import OpenAPI.Checker.Behavior

7+import OpenAPI.Checker.Subtree

88import Text.Pandoc.Builder

99

1010instance Subtree Link where

@@ -17,6 +17,6 @@ instance Issuable 'LinkLevel where

1717 data Issue 'LinkLevel

1818 = LinksUnsupported

1919 deriving stock (Eq, Ord, Show)

20− issueKind = \case

21− LinksUnsupported -> Unsupported

22− describeIssue _ LinksUnsupported = para "CompaREST does not currently support Link Objects."

20+ issueIsUnsupported = \case

21+ LinksUnsupported -> True

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

src/Data/OpenApi/Compare/Validate/MediaTypeObject.hs → src/OpenAPI/Checker/Validate/MediaTypeObject.hsrenamed+17−17

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

3−module Data.OpenApi.Compare.Validate.MediaTypeObject

4− ( Issue (..),

5− Behave (..),

3+module OpenAPI.Checker.Validate.MediaTypeObject

4+ ( Issue (..)

5+ , Behave (..)

66 )

77where

88

@@ -12,15 +12,15 @@ import Data.HList

1212import Data.HashMap.Strict.InsOrd as IOHM

1313import Data.Map.Strict as M

1414import Data.OpenApi

15−import Data.OpenApi.Compare.Behavior

16−import Data.OpenApi.Compare.Subtree

17−import Data.OpenApi.Compare.Validate.Header ()

18−import Data.OpenApi.Compare.Validate.Products

19−import Data.OpenApi.Compare.Validate.Schema ()

2015import Data.String

2116import Data.Text (Text)

2217import qualified Data.Text as T

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

19+import OpenAPI.Checker.Behavior

20+import OpenAPI.Checker.Subtree

21+import OpenAPI.Checker.Validate.Header ()

22+import OpenAPI.Checker.Validate.Products

23+import OpenAPI.Checker.Validate.Schema ()

2424import Text.Pandoc.Builder

2525

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

@@ -38,20 +38,20 @@ instance Issuable 'PayloadLevel where

3838 | MediaEncodingMissing Text

3939 | EncodingNotSupported

4040 deriving stock (Eq, Ord, Show)

41− issueKind = \case

42− EncodingNotSupported -> Unsupported

43− _ -> CertainIssue

41+ issueIsUnsupported = \case

42+ EncodingNotSupported -> True

43+ _ -> False

4444

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

4646 describeIssue Forward (MediaEncodingMissing enc) = para $ "Media encoding " <> str enc <> " has been removed."

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

48− describeIssue _ EncodingNotSupported = para "CompaREST does not currently support media encodings other than JSON."

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

4949

5050instance Behavable 'PayloadLevel 'SchemaLevel where

5151 data Behave 'PayloadLevel 'SchemaLevel

5252 = PayloadSchema

5353 deriving stock (Eq, Ord, Show)

54− describeBehavior PayloadSchema = "JSON Schema"

54+ describeBehaviour PayloadSchema = "JSON Schema"

5555

5656instance Subtree MediaTypeObject where

5757 type SubtreeLevel MediaTypeObject = 'PayloadLevel

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

119119

120120 -- FIXME: Support only JSON body for now. Then Encoding is checked only for

121121 -- multipart/form-url-encoded

122− -- #54

122+ -- https://github.com/typeable/openapi-diff/issues/54

123123 checkSemanticCompatibility _env beh _pc =

124124 issueAt beh EncodingNotSupported

125125

@@ -143,7 +143,7 @@ instance Behavable 'OperationLevel 'ResponseLevel where

143143 data Behave 'OperationLevel 'ResponseLevel

144144 = WithStatusCode HttpStatusCode

145145 deriving stock (Eq, Ord, Show)

146− describeBehavior (WithStatusCode c) = "Response code " <> (fromString . show $ c)

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

147147

148148instance Issuable 'OperationLevel where

149149 data Issue 'OperationLevel

@@ -152,8 +152,8 @@ instance Issuable 'OperationLevel where

152152 | PathFragmentNotMatched Int

153153 | NoRequestBody

154154 deriving stock (Eq, Ord, Show)

155− issueKind = \case

156− _ -> CertainIssue

155+ issueIsUnsupported = \case

156+ _ -> False

157157 describeIssue Forward (ConsumerDoesntHaveResponseCode c) =

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

159159 describeIssue Backward (ConsumerDoesntHaveResponseCode c) =

src/Data/OpenApi/Compare/Validate/OAuth2Flows.hs → src/OpenAPI/Checker/Validate/OAuth2Flows.hsrenamed+21−26

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

3−module Data.OpenApi.Compare.Validate.OAuth2Flows

4− ( Step (..),

5− Issue (..),

6− Behave (..),

3+module OpenAPI.Checker.Validate.OAuth2Flows

4+ ( Step (..)

5+ , Issue (..)

6+ , Behave (..)

77 )

88where

99

@@ -12,13 +12,13 @@ import Data.Function

1212import Data.Functor

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

1414import Data.OpenApi

15−import Data.OpenApi.Compare.Behavior

16−import Data.OpenApi.Compare.Orphans ()

17−import Data.OpenApi.Compare.Subtree

1815import Data.Proxy

1916import Data.Set (Set)

2017import qualified Data.Set as S

2118import Data.Text (Text)

19+import OpenAPI.Checker.Behavior

20+import OpenAPI.Checker.Orphans ()

21+import OpenAPI.Checker.Subtree

2222import Text.Pandoc.Builder

2323

2424instance Subtree OAuth2Flows where

@@ -26,11 +26,11 @@ instance Subtree OAuth2Flows where

2626 type SubtreeLevel OAuth2Flows = 'SecuritySchemeLevel

2727 checkStructuralCompatibility _ = structuralEq

2828 checkSemanticCompatibility env bhv pc = do

29− let supportFlow ::

30− (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t) =>

31− Issue 'SecuritySchemeLevel ->

32− ProdCons (Maybe (Traced t)) ->

33− SemanticCompatFormula ()

29+ let supportFlow

30+ :: (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t)

31+ => Issue 'SecuritySchemeLevel

32+ -> ProdCons (Maybe (Traced t))

33+ -> SemanticCompatFormula ()

3434 supportFlow i x = case x of

3535 -- producer will not attempt this flow

3636 (ProdCons Nothing _) -> pure ()

@@ -38,11 +38,11 @@ instance Subtree OAuth2Flows where

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

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

4040 checkCompatibility bhv env $ ProdCons p c

41− getFlow ::

42− Typeable x =>

43− (OAuth2Flows -> Maybe (OAuth2Flow x)) ->

44− Traced OAuth2Flows ->

45− Maybe (Traced (OAuth2Flow x))

41+ getFlow

42+ :: Typeable x

43+ => (OAuth2Flows -> Maybe (OAuth2Flow x))

44+ -> Traced OAuth2Flows

45+ -> Maybe (Traced (OAuth2Flow x))

4646 getFlow f (Traced t a) = Traced (t >>> step (OAuth2FlowsFlow Proxy)) <$> f a

4747 supportFlow ConsumerDoesNotSupportImplicitFlow $ getFlow _oAuth2FlowsImplicit <$> pc

4848 supportFlow ConsumerDoesNotSupportPasswordFlow $ getFlow _oAuth2FlowsPassword <$> pc

@@ -103,9 +103,7 @@ instance Issuable 'SecurityRequirementLevel where

103103 = SecurityRequirementNotMet

104104 | UndefinedSecurityScheme Text

105105 deriving stock (Eq, Ord, Show)

106− issueKind = \case

107− SecurityRequirementNotMet -> CertainIssue

108− UndefinedSecurityScheme _ -> SchemaInvalid

106+ issueIsUnsupported _ = False

109107 describeIssue Forward SecurityRequirementNotMet = para "Security scheme has been removed."

110108 describeIssue Backward SecurityRequirementNotMet = para "Security scheme was added."

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

@@ -131,14 +129,11 @@ instance Issuable 'SecuritySchemeLevel where

131129 | CanNotHaveScopes

132130 | ScopeNotDefined Text

133131 deriving stock (Eq, Ord, Show)

134− issueKind = \case

135− CanNotHaveScopes -> SchemaInvalid

136− ScopeNotDefined _ -> SchemaInvalid

137− _ -> CertainIssue

132+ issueIsUnsupported _ = False

138133 describeIssue _ RefreshUrlsDontMatch = para "Refresh URL changed."

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

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

141− describeIssue _ (OpenIdConnectUrlsDontMatch _ _) = para "OpenID Connect URL changed."

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

142137 describeIssue _ (CustomHttpSchemesDontMatch e a) =

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

144139 describeIssue Forward ConsumerDoesNotSupportImplicitFlow = para "Implicit flow support has been removed."

@@ -167,4 +162,4 @@ instance Behavable 'SecurityRequirementLevel 'SecuritySchemeLevel where

167162 data Behave 'SecurityRequirementLevel 'SecuritySchemeLevel

168163 = SecuritySchemeStep Text

169164 deriving stock (Eq, Ord, Show)

170− describeBehavior (SecuritySchemeStep s) = text s

165+ describeBehaviour (SecuritySchemeStep s) = text s

src/Data/OpenApi/Compare/Validate/OpenApi.hs → src/OpenAPI/Checker/Validate/OpenApi.hsrenamed+17−18

@@ -2,19 +2,19 @@

22-- Does not compiles otherwise

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

44

5−module Data.OpenApi.Compare.Validate.OpenApi

6− ( Behave (..),

7− Issue (..),

5+module OpenAPI.Checker.Validate.OpenApi

6+ ( Behave (..)

7+ , Issue (..)

88 )

99where

1010

1111import Data.HList

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

1313import Data.OpenApi

14−import Data.OpenApi.Compare.Behavior

15−import Data.OpenApi.Compare.Paths

16−import Data.OpenApi.Compare.Subtree

17−import Data.OpenApi.Compare.Validate.Operation

14+import OpenAPI.Checker.Behavior

15+import OpenAPI.Checker.Paths

16+import OpenAPI.Checker.Subtree

17+import OpenAPI.Checker.Validate.Operation

1818

1919tracedPaths :: Traced OpenApi -> Traced ProcessedPathItems

2020tracedPaths oa =

@@ -79,17 +79,16 @@ instance Subtree OpenApi where

7979 checkSemanticCompatibility _ beh prodCons = do

8080 checkCompatibility @ProcessedPathItems

8181 beh

82− ( (tracedRequestBodies <$> prodCons)

83− `HCons` (tracedParameters <$> prodCons)

84− `HCons` (tracedSecuritySchemes <$> prodCons)

85− `HCons` (tracedResponses <$> prodCons)

86− `HCons` (tracedHeaders <$> prodCons)

87− `HCons` (tracedSchemas <$> prodCons)

88− `HCons` (_openApiServers . extract <$> prodCons)

89− `HCons` (tracedLinks <$> prodCons)

90− `HCons` (tracedCallbacks <$> prodCons)

91− `HCons` HNil

92− )

82+ ((tracedRequestBodies <$> prodCons)

83+ `HCons` (tracedParameters <$> prodCons)

84+ `HCons` (tracedSecuritySchemes <$> prodCons)

85+ `HCons` (tracedResponses <$> prodCons)

86+ `HCons` (tracedHeaders <$> prodCons)

87+ `HCons` (tracedSchemas <$> prodCons)

88+ `HCons` (_openApiServers . extract <$> prodCons)

89+ `HCons` (tracedLinks <$> prodCons)

90+ `HCons` (tracedCallbacks <$> prodCons)

91+ `HCons` HNil)

9392 (tracedPaths <$> prodCons)

9493

9594instance Steppable OpenApi ProcessedPathItems where

src/Data/OpenApi/Compare/Validate/Operation.hs → src/OpenAPI/Checker/Validate/Operation.hsrenamed+50−57

@@ -2,19 +2,19 @@

22{-# OPTIONS_GHC -Wno-orphans #-}

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

44

5−module Data.OpenApi.Compare.Validate.Operation

5+module OpenAPI.Checker.Validate.Operation

66 ( -- * Operation

7− MatchedOperation (..),

8− OperationMethod (..),

9− pathItemMethod,

7+ MatchedOperation (..)

8+ , OperationMethod (..)

9+ , pathItemMethod

1010

1111 -- * ProcessedPathItem

12− ProcessedPathItem (..),

13− ProcessedPathItems (..),

14− processPathItems,

15− Step (..),

16− Behave (..),

17− Issue (..),

12+ , ProcessedPathItem (..)

13+ , ProcessedPathItems (..)

14+ , processPathItems

15+ , Step (..)

16+ , Behave (..)

17+ , Issue (..)

1818 )

1919where

2020

@@ -29,21 +29,21 @@ import qualified Data.List as L

2929import Data.Map.Strict as M

3030import Data.Maybe

3131import Data.OpenApi

32−import Data.OpenApi.Compare.Behavior

33−import Data.OpenApi.Compare.References

34−import Data.OpenApi.Compare.Subtree

35−import Data.OpenApi.Compare.Validate.MediaTypeObject

36−import Data.OpenApi.Compare.Validate.OAuth2Flows

37−import Data.OpenApi.Compare.Validate.PathFragment

38−import Data.OpenApi.Compare.Validate.Products

39−import Data.OpenApi.Compare.Validate.RequestBody

40−import Data.OpenApi.Compare.Validate.Responses

41−import Data.OpenApi.Compare.Validate.SecurityRequirement ()

42−import Data.OpenApi.Compare.Validate.Server ()

43−import Data.OpenApi.Compare.Validate.Sums

4432import Data.String

4533import Data.Text (Text)

4634import qualified Data.Text as T

35+import OpenAPI.Checker.Behavior

36+import OpenAPI.Checker.References

37+import OpenAPI.Checker.Subtree

38+import OpenAPI.Checker.Validate.MediaTypeObject

39+import OpenAPI.Checker.Validate.OAuth2Flows

40+import OpenAPI.Checker.Validate.PathFragment

41+import OpenAPI.Checker.Validate.Products

42+import OpenAPI.Checker.Validate.RequestBody

43+import OpenAPI.Checker.Validate.Responses

44+import OpenAPI.Checker.Validate.SecurityRequirement ()

45+import OpenAPI.Checker.Validate.Server ()

46+import OpenAPI.Checker.Validate.Sums

4747import Text.Pandoc.Builder

4848

4949data MatchedOperation = MatchedOperation

@@ -86,12 +86,11 @@ tracedCallbacks (Traced t oper) =

8686 | (k, v) <- IOHM.toList . _operationCallbacks . operation $ oper

8787 ]

8888

89−-- FIXME: #28

90−getServers ::

91− -- | Servers from env

92− [Server] ->

93− MatchedOperation ->

94− [Server]

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

90+getServers

91+ :: [Server] -- ^ Servers from env

92+ -> MatchedOperation

93+ -> [Server]

9594getServers env oper =

9695 case _operationServers . operation $ oper of

9796 [] -> env

@@ -102,21 +101,21 @@ instance Behavable 'OperationLevel 'PathFragmentLevel where

102101 = InParam Text

103102 | InFragment (PathFragment Text)

104103 deriving stock (Eq, Ord, Show)

105− describeBehavior (InParam p) = "Parameter " <> text p

106− describeBehavior (InFragment (StaticPath p)) = "Static fragment " <> code p

107− describeBehavior (InFragment (DynamicPath p)) = "Dynamic fragment " <> code p

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

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

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

108107

109108instance Behavable 'OperationLevel 'RequestLevel where

110109 data Behave 'OperationLevel 'RequestLevel

111110 = InRequest

112111 deriving stock (Eq, Ord, Show)

113− describeBehavior InRequest = "Request"

112+ describeBehaviour InRequest = "Request"

114113

115114instance Behavable 'OperationLevel 'SecurityRequirementLevel where

116115 data Behave 'OperationLevel 'SecurityRequirementLevel

117116 = SecurityRequirementStep Int

118117 deriving stock (Eq, Ord, Show)

119− describeBehavior (SecurityRequirementStep i) =

118+ describeBehaviour (SecurityRequirementStep i) =

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

121120

122121instance Subtree MatchedOperation where

@@ -242,7 +241,7 @@ instance Subtree MatchedOperation where

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

243242 checkResponses =

244243 swapProdCons (checkCompatibility beh) env $ tracedResponses <$> prodCons

245− -- FIXME: #27

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

246245 checkCallbacks = do

247246 let ProdCons pCallbacks cCallbacks = tracedCallbacks <$> prodCons

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

@@ -251,7 +250,7 @@ instance Subtree MatchedOperation where

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

252251 swapProdCons (checkCompatibility beh') env $ ProdCons pCallback cCallback

253252 pure ()

254− -- FIXME: #28

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

255254 checkOperationSecurity = do

256255 let ProdCons pSecs cSecs = tracedSecurity <$> prodCons

257256 for_ pSecs $ \(i, pSec) -> do

@@ -336,12 +335,7 @@ instance Issuable 'APILevel where

336335 | AllPathsFailed FilePath

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

338337 deriving stock (Eq, Ord, Show)

339− issueKind = \case

340− _ -> CertainIssue

341− relatedIssues =

342− (==) `withClass` \case

343− NoPathsMatched fp -> Just fp

344− AllPathsFailed fp -> Just fp

338+ issueIsUnsupported _ = False

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

346340 describeIssue Backward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been added."

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

@@ -352,7 +346,7 @@ instance Behavable 'APILevel 'PathLevel where

352346 = AtPath FilePath

353347 deriving stock (Eq, Ord, Show)

354348

355− describeBehavior (AtPath p) = str (T.pack p)

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

356350

357351instance Subtree ProcessedPathItems where

358352 type SubtreeLevel ProcessedPathItems = 'APILevel

@@ -436,18 +430,17 @@ tracedFragments mpi =

436430 | (i, x) <- L.zip [0 ..] $ pathFragments $ extract mpi

437431 ]

438432

439−tracedMethod ::

440− OperationMethod ->

441− Traced MatchedPathItem ->

442− Maybe (Traced' MatchedOperation Operation)

433+tracedMethod

434+ :: OperationMethod

435+ -> Traced MatchedPathItem

436+ -> Maybe (Traced' MatchedOperation Operation)

443437tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)

444438

445439instance Issuable 'PathLevel where

446440 data Issue 'PathLevel

447441 = OperationMissing OperationMethod

448442 deriving stock (Eq, Ord, Show)

449− issueKind = \case

450− OperationMissing _ -> CertainIssue

443+ issueIsUnsupported _ = False

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

452445 describeIssue Backward (OperationMissing op) = para $ "Method " <> strong (showMethod op) <> " has been added."

453446

@@ -456,7 +449,7 @@ instance Behavable 'PathLevel 'OperationLevel where

456449 = InOperation OperationMethod

457450 deriving stock (Eq, Ord, Show)

458451

459− describeBehavior (InOperation method) = showMethod method

452+ describeBehaviour (InOperation method) = showMethod method

460453

461454showMethod :: IsString s => OperationMethod -> s

462455showMethod = \case

@@ -487,10 +480,10 @@ instance Subtree MatchedPathItem where

487480 checkSemanticCompatibility env beh prodCons = do

488481 let paramDefs = getH @(ProdCons (Traced (Definitions Param))) env

489482 pathTracedParams = getPathParams <$> paramDefs <*> prodCons

490− getPathParams ::

491− Traced (Definitions Param) ->

492− Traced MatchedPathItem ->

493− [Traced Param]

483+ getPathParams

484+ :: Traced (Definitions Param)

485+ -> Traced MatchedPathItem

486+ -> [Traced Param]

494487 getPathParams defs mpi = do

495488 paramRef <- tracedMatchedPathItemParameters mpi

496489 pure $ dereference defs paramRef

@@ -564,9 +557,9 @@ instance Issuable 'CallbackLevel where

564557 data Issue 'CallbackLevel

565558 = CallbacksUnsupported

566559 deriving stock (Eq, Ord, Show)

567− issueKind = \case

568− CallbacksUnsupported -> Unsupported

569− describeIssue _ CallbacksUnsupported = para "CompaREST does not currently support callbacks."

560+ issueIsUnsupported = \case

561+ CallbacksUnsupported -> True

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

570563

571564tracedCallbackPathItems :: Traced Callback -> Traced ProcessedPathItems

572565tracedCallbackPathItems (Traced t (Callback x)) =

@@ -580,4 +573,4 @@ instance Behavable 'OperationLevel 'CallbackLevel where

580573 data Behave 'OperationLevel 'CallbackLevel = OperationCallback Text

581574 deriving stock (Eq, Ord, Show)

582575

583− describeBehavior (OperationCallback key) = "Operation " <> code key

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

src/Data/OpenApi/Compare/Validate/Param.hs → src/OpenAPI/Checker/Validate/Param.hsrenamed+15−20

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

11{-# OPTIONS_GHC -Wno-orphans #-}

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

33

4−module Data.OpenApi.Compare.Validate.Param

5− ( Behave (..),

6− Issue (..),

4+module OpenAPI.Checker.Validate.Param

5+ ( Behave (..)

6+ , Issue (..)

77 )

88where

99

@@ -11,11 +11,11 @@ import Control.Monad

1111import Data.Functor

1212import Data.Maybe

1313import Data.OpenApi

14−import Data.OpenApi.Compare.Behavior

15−import Data.OpenApi.Compare.Orphans ()

16−import Data.OpenApi.Compare.Subtree

17−import Data.OpenApi.Compare.Validate.Schema ()

1814import Data.Text as T

15+import OpenAPI.Checker.Behavior

16+import OpenAPI.Checker.Orphans ()

17+import OpenAPI.Checker.Subtree

18+import OpenAPI.Checker.Validate.Schema ()

1919import Text.Pandoc.Builder

2020

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

@@ -66,11 +66,9 @@ instance Issuable 'PathFragmentLevel where

6666 ParamStyleMismatch

6767 | -- | One of schemas not presented

6868 ParamSchemaMismatch

69− | PathFragmentsDontMatch (ProdCons Text)

69+ | PathFragmentsDontMatch Text Text

7070 deriving stock (Eq, Ord, Show)

71− issueKind = \case

72− ParamSchemaMismatch -> ProbablyIssue -- the schema could be catch-all (?)

73− _ -> CertainIssue

71+ issueIsUnsupported _ = False

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

7573 describeIssue Forward ParamEmptinessIncompatible = para "The parameter can no longer be empty."

7674 describeIssue Backward ParamEmptinessIncompatible = para "The parameter can now be empty."

@@ -79,15 +77,14 @@ instance Issuable 'PathFragmentLevel where

7977 describeIssue _ ParamPlaceIncompatible = para "Parameters in incompatible locations."

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

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

82− describeIssue ori (PathFragmentsDontMatch (orientProdCons ori -> ProdCons e a)) =

83− para $ "Parameter changed from " <> code e <> " to " <> code a <> "."

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

8481

8582instance Behavable 'PathFragmentLevel 'SchemaLevel where

8683 data Behave 'PathFragmentLevel 'SchemaLevel

8784 = InParamSchema

8885 deriving stock (Eq, Ord, Show)

8986

90− describeBehavior InParamSchema = "JSON Schema"

87+ describeBehaviour InParamSchema = "JSON Schema"

9188

9289instance Subtree Param where

9390 type SubtreeLevel Param = 'PathFragmentLevel

@@ -106,17 +103,15 @@ instance Subtree Param where

106103 when (_paramName (extract p) /= _paramName (extract c)) $

107104 issueAt beh ParamNameMismatch

108105 when

109− ( (fromMaybe False . _paramRequired . extract $ c)

110− && not (fromMaybe False . _paramRequired . extract $ p)

111− )

106+ ((fromMaybe False . _paramRequired . extract $ c)

107+ && not (fromMaybe False . _paramRequired . extract $ p))

112108 $ issueAt beh ParamRequired

113109 case (_paramIn . extract $ p, _paramIn . extract $ c) of

114110 (ParamQuery, ParamQuery) -> do

115111 -- Emptiness is only for query params

116112 when

117− ( (fromMaybe False . _paramAllowEmptyValue . extract $ p)

118− && not (fromMaybe False . _paramAllowEmptyValue . extract $ c)

119− )

113+ ((fromMaybe False . _paramAllowEmptyValue . extract $ p)

114+ && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))

120115 $ issueAt beh ParamEmptinessIncompatible

121116 (a, b) | a == b -> pure ()

122117 _ -> issueAt beh ParamPlaceIncompatible

src/Data/OpenApi/Compare/Validate/PathFragment.hs → src/OpenAPI/Checker/Validate/PathFragment.hsrenamed+10−9

@@ -1,20 +1,21 @@

1−module Data.OpenApi.Compare.Validate.PathFragment

2− ( parsePath,

3− PathFragment (..),

4− PathFragmentParam,

1+module OpenAPI.Checker.Validate.PathFragment

2+ ( parsePath

3+ , PathFragment (..)

4+ , PathFragmentParam

55 )

66where

77

88import qualified Data.Aeson as A

99import Data.OpenApi

10−import Data.OpenApi.Compare.Behavior

11−import Data.OpenApi.Compare.Subtree

12−import Data.OpenApi.Compare.Validate.Param

1310import Data.Text (Text)

1411import qualified Data.Text as T

12+import Data.Typeable

13+import OpenAPI.Checker.Behavior

14+import OpenAPI.Checker.Subtree

15+import OpenAPI.Checker.Validate.Param

1516

1617-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.

17−-- #23

18+-- https://github.com/typeable/openapi-diff/issues/23

1819parsePath :: FilePath -> [PathFragment Text]

1920parsePath = fmap partition . T.splitOn "/" . T.pack

2021 where

@@ -73,6 +74,6 @@ instance Subtree PathFragmentParam where

7374 checkSemanticCompatibility _ beh (ProdCons (extract -> StaticPath x) (extract -> StaticPath y)) =

7475 if x == y

7576 then pure ()

76− else issueAt beh (PathFragmentsDontMatch (ProdCons x y))

77+ else issueAt beh (PathFragmentsDontMatch x y)

7778 checkSemanticCompatibility env beh prodCons = do

7879 checkCompatibility beh env (tracedPathFragmentParam <$> prodCons)

src/OpenAPI/Checker/Validate/Products.hsnew file+49

@@ -0,0 +1,49 @@

1+{- | Checks product-like entities. The key is some identificator for the product

2+element. Each element may be required or optional.

3+

4+One example of product is request parameters. There are optional and required

5+parameters. The client and server have possibly different set of

6+parameters. What we must check is if server requires some request parameter,

7+then this parameter must be presented by client and their schemas must match.

8+

9+So when we checking products we are checking from the server's (consumer)

10+perspective, ensuring that all parameters are provided by the client (producer)

11+and their schemas match.

12+

13+This module abstracts this logic for arbitrary elements -}

14+

15+module OpenAPI.Checker.Validate.Products

16+ ( checkProducts

17+ , ProductLike(..)

18+ ) where

19+

20+import Data.Foldable

21+import Data.Map.Strict (Map)

22+import qualified Data.Map.Strict as M

23+import OpenAPI.Checker.Behavior

24+import OpenAPI.Checker.Paths

25+import OpenAPI.Checker.Subtree

26+

27+-- | Some entity which is product-like

28+data ProductLike a = ProductLike

29+ { productValue :: a

30+ , required :: Bool

31+ }

32+

33+checkProducts

34+ :: (Ord k, Issuable l)

35+ => Paths q r l

36+ -> (k -> Issue l)

37+ -- ^ No required element found

38+ -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())

39+ -> ProdCons (Map k (ProductLike t))

40+ -> CompatFormula' q AnIssue r ()

41+checkProducts xs noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->

42+ case M.lookup key p of

43+ Nothing -> case required consElt of

44+ True -> issueAt xs $ noElt key

45+ False -> pure ()

46+ Just prodElt -> do

47+ let

48+ elts = ProdCons prodElt consElt

49+ check key (productValue <$> elts)

src/Data/OpenApi/Compare/Validate/RequestBody.hs → src/OpenAPI/Checker/Validate/RequestBody.hsrenamed+9−10

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

3−module Data.OpenApi.Compare.Validate.RequestBody

4− ( Issue (..),

5− Behave (..),

3+module OpenAPI.Checker.Validate.RequestBody

4+ ( Issue (..)

5+ , Behave (..)

66 )

77where

88

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

1111import Data.Map.Strict as M

1212import Data.Maybe

1313import Data.OpenApi

14−import Data.OpenApi.Compare.Behavior

15−import Data.OpenApi.Compare.Subtree

16−import Data.OpenApi.Compare.Validate.MediaTypeObject

17−import Data.OpenApi.Compare.Validate.Sums

1814import qualified Data.Text as T

1915import Network.HTTP.Media (MediaType)

16+import OpenAPI.Checker.Behavior

17+import OpenAPI.Checker.Subtree

18+import OpenAPI.Checker.Validate.MediaTypeObject

19+import OpenAPI.Checker.Validate.Sums

2020import Text.Pandoc.Builder

2121

2222-- TODO: Use RequestMediaTypeObjectMapping

@@ -30,8 +30,7 @@ instance Issuable 'RequestLevel where

3030 = RequestBodyRequired

3131 | RequestMediaTypeNotFound MediaType

3232 deriving stock (Eq, Ord, Show)

33− issueKind = \case

34− _ -> CertainIssue

33+ issueIsUnsupported _ = False

3534 describeIssue Forward RequestBodyRequired =

3635 para "Request body has become required."

3736 describeIssue Backward RequestBodyRequired =

@@ -45,7 +44,7 @@ instance Behavable 'RequestLevel 'PayloadLevel where

4544 data Behave 'RequestLevel 'PayloadLevel

4645 = InPayload

4746 deriving stock (Eq, Ord, Show)

48− describeBehavior InPayload = "Payload"

47+ describeBehaviour InPayload = "Payload"

4948

5049instance Subtree RequestBody where

5150 type SubtreeLevel RequestBody = 'RequestLevel

src/Data/OpenApi/Compare/Validate/Responses.hs → src/OpenAPI/Checker/Validate/Responses.hsrenamed+14−15

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

11{-# OPTIONS_GHC -Wno-orphans #-}

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

33

4−module Data.OpenApi.Compare.Validate.Responses

5− ( Behave (..),

4+module OpenAPI.Checker.Validate.Responses

5+ ( Behave (..)

66 )

77where

88

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

1111import Data.Map.Strict as M

1212import Data.Maybe

1313import Data.OpenApi

14−import Data.OpenApi.Compare.Behavior

15−import Data.OpenApi.Compare.References

16−import Data.OpenApi.Compare.Subtree

17−import Data.OpenApi.Compare.Validate.Header ()

18−import Data.OpenApi.Compare.Validate.Link ()

19−import Data.OpenApi.Compare.Validate.MediaTypeObject

20−import Data.OpenApi.Compare.Validate.Products

21−import Data.OpenApi.Compare.Validate.Schema ()

22−import Data.OpenApi.Compare.Validate.Sums

2314import qualified Data.Text as T

2415import Network.HTTP.Media (MediaType)

16+import OpenAPI.Checker.Behavior

17+import OpenAPI.Checker.References

18+import OpenAPI.Checker.Subtree

19+import OpenAPI.Checker.Validate.Header ()

20+import OpenAPI.Checker.Validate.Link ()

21+import OpenAPI.Checker.Validate.MediaTypeObject

22+import OpenAPI.Checker.Validate.Products

23+import OpenAPI.Checker.Validate.Schema ()

24+import OpenAPI.Checker.Validate.Sums

2525import Text.Pandoc.Builder

2626

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

@@ -71,8 +71,7 @@ instance Issuable 'ResponseLevel where

7171 = ConsumerDoesntHaveMediaType MediaType

7272 | ProducerDoesntHaveResponseHeader HeaderName

7373 deriving stock (Eq, Ord, Show)

74− issueKind = \case

75− _ -> CertainIssue

74+ issueIsUnsupported _ = False

7675 describeIssue Forward (ConsumerDoesntHaveMediaType t) =

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

7877 describeIssue Backward (ConsumerDoesntHaveMediaType t) =

@@ -87,14 +86,14 @@ instance Behavable 'ResponseLevel 'PayloadLevel where

8786 = ResponsePayload

8887 deriving stock (Eq, Ord, Show)

8988

90− describeBehavior ResponsePayload = "Payload"

89+ describeBehaviour ResponsePayload = "Payload"

9190

9291instance Behavable 'ResponseLevel 'HeaderLevel where

9392 data Behave 'ResponseLevel 'HeaderLevel

9493 = InHeader HeaderName

9594 deriving stock (Eq, Ord, Show)

9695

97− describeBehavior (InHeader name) = "Header " <> code name

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

9897

9998instance Subtree Response where

10099 type SubtreeLevel Response = 'ResponseLevel

src/OpenAPI/Checker/Validate/Schema.hsnew file+1627

@@ -0,0 +1,1627 @@

1+{-# OPTIONS_GHC -fno-warn-orphans #-}

2+

3+module OpenAPI.Checker.Validate.Schema

4+ ( JsonType (..)

5+ , ForeachType (..)

6+ , foldType

7+ , forType_

8+ , TypedValue (..)

9+ , untypeValue

10+ , Bound (..)

11+ , schemaToFormula

12+ , foldLattice

13+ , Behave (..)

14+ , describeJSONType

15+ )

16+where

17+

18+import Algebra.Lattice

19+import Algebra.Lattice.Lifted

20+import Control.Applicative

21+import Control.Arrow

22+import Control.Comonad.Env hiding (env)

23+import Control.Monad.Reader hiding (ask)

24+import qualified Control.Monad.Reader as R

25+import Control.Monad.State

26+import qualified Control.Monad.Trans.Reader as R (liftCatch)

27+import qualified Control.Monad.Trans.Writer as W (liftCatch)

28+import Control.Monad.Writer

29+import qualified Data.Aeson as A

30+import qualified Data.ByteString.Lazy as BSL

31+import Data.Coerce

32+import Data.Foldable

33+import qualified Data.Foldable as F

34+import Data.Functor

35+import Data.Functor.Identity

36+import Data.HList

37+import qualified Data.HashMap.Strict as HM

38+import qualified Data.HashMap.Strict.InsOrd as IOHM

39+import Data.Int

40+import Data.Kind

41+import Data.List (sortBy)

42+import qualified Data.List as L

43+import qualified Data.List.NonEmpty as NE

44+import qualified Data.Map as M

45+import Data.Maybe

46+import Data.OpenApi hiding (get)

47+import Data.Ord

48+import Data.Ratio

49+import Data.Scientific

50+import qualified Data.Set as S

51+import Data.String

52+import Data.Text (Text)

53+import qualified Data.Text as T hiding (singleton)

54+import qualified Data.Text.Encoding as T

55+import Data.Typeable

56+import OpenAPI.Checker.Behavior

57+import OpenAPI.Checker.Memo

58+import OpenAPI.Checker.Orphans ()

59+import OpenAPI.Checker.Paths

60+import qualified OpenAPI.Checker.PathsPrefixTree as P

61+import OpenAPI.Checker.References

62+import OpenAPI.Checker.Subtree

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

64+import Text.Regex.Pcre2

65+

66+-- | Type of a JSON value

67+data JsonType

68+ = Null

69+ | Boolean

70+ | Number

71+ | String

72+ | Array

73+ | Object

74+ deriving stock (Eq, Ord, Show)

75+

76+-- | A 'A.Value' whose type we know

77+data TypedValue :: JsonType -> Type where

78+ TNull :: TypedValue 'Null

79+ TBool :: !Bool -> TypedValue 'Boolean

80+ TNumber :: !Scientific -> TypedValue 'Number

81+ TString :: !Text -> TypedValue 'String

82+ TArray :: !A.Array -> TypedValue 'Array

83+ TObject :: !A.Object -> TypedValue 'Object

84+

85+deriving stock instance Eq (TypedValue t)

86+

87+deriving stock instance Ord (TypedValue t)

88+

89+deriving stock instance Show (TypedValue t)

90+

91+untypeValue :: TypedValue t -> A.Value

92+untypeValue TNull = A.Null

93+untypeValue (TBool b) = A.Bool b

94+untypeValue (TNumber n) = A.Number n

95+untypeValue (TString s) = A.String s

96+untypeValue (TArray a) = A.Array a

97+untypeValue (TObject o) = A.Object o

98+

99+data Bound a = Exclusive !a | Inclusive !a

100+ deriving stock (Eq, Show, Functor)

101+

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

103+instance Ord a => Ord (Bound a) where

104+ Exclusive a `compare` Exclusive b = compare a b

105+ Exclusive a `compare` Inclusive b = if a <= b then LT else GT

106+ Inclusive a `compare` Exclusive b = if a < b then LT else GT

107+ Inclusive a `compare` Inclusive b = compare a b

108+

109+data Property = Property

110+ { propRequired :: Bool

111+ , propFormula :: ForeachType JsonFormula

112+ , propRefSchema :: Traced (Referenced Schema)

113+ }

114+ deriving stock (Eq, Ord, Show)

115+

116+-- | A primitive structural condition for the "top level" of a JSON value (of a specific type)

117+data Condition :: JsonType -> Type where

118+ Exactly :: TypedValue t -> Condition t

119+ Maximum :: !(Bound Scientific) -> Condition 'Number

120+ Minimum

121+ :: !(Down (Bound (Down Scientific)))

122+ -> Condition 'Number -- ^ this has the right Ord

123+ MultipleOf :: !Scientific -> Condition 'Number

124+ NumberFormat :: !Format -> Condition 'Number

125+ MaxLength :: !Integer -> Condition 'String

126+ MinLength :: !Integer -> Condition 'String

127+ Pattern :: !Pattern -> Condition 'String

128+ StringFormat :: !Format -> Condition 'String

129+ Items

130+ :: !(ForeachType JsonFormula)

131+ -> !(Traced (Referenced Schema))

132+ -> Condition 'Array

133+ MaxItems :: !Integer -> Condition 'Array

134+ MinItems :: !Integer -> Condition 'Array

135+ UniqueItems :: Condition 'Array

136+ Properties

137+ :: !(M.Map Text Property)

138+ -> !(ForeachType JsonFormula) -- ^ formula for additional properties

139+ -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom

140+ -> Condition 'Object

141+ MaxProperties :: !Integer -> Condition 'Object

142+ MinProperties :: !Integer -> Condition 'Object

143+

144+showCondition :: Condition a -> Blocks

145+showCondition = \case

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

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

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

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

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

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

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

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

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

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

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

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

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

159+ (Properties props additional _) ->

160+ bulletList $

161+ (M.toList props

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

163+ para (code k)

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

165+ <> showForEachJsonFormula (propFormula p)))

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

167+ <> showForEachJsonFormula additional

168+ ]

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

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

171+ where

172+ showForEachJsonFormula :: ForeachType JsonFormula -> Blocks

173+ showForEachJsonFormula i =

174+ bulletList $

175+ foldType

176+ (\t f -> case getJsonFormula $ f i of

177+ BottomFormula -> mempty

178+ (DNF conds') ->

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

180+ in [ para (describeJSONType t)

181+ <> bulletList

182+ (conds <&> \case

183+ [] -> para "Empty"

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

185+ ])

186+

187+satisfiesTyped :: TypedValue t -> Condition t -> Bool

188+satisfiesTyped e (Exactly e') = e == e'

189+satisfiesTyped (TNumber n) (Maximum (Exclusive m)) = n < m

190+satisfiesTyped (TNumber n) (Maximum (Inclusive m)) = n <= m

191+satisfiesTyped (TNumber n) (Minimum (Down (Exclusive (Down m)))) = n > m

192+satisfiesTyped (TNumber n) (Minimum (Down (Inclusive (Down m)))) = n >= m

193+satisfiesTyped (TNumber n) (MultipleOf m) = denominator (toRational n / toRational m) == 1 -- TODO: could be better #36

194+satisfiesTyped (TNumber n) (NumberFormat f) = checkNumberFormat f n

195+satisfiesTyped (TString s) (MaxLength m) = fromIntegral (T.length s) <= m

196+satisfiesTyped (TString s) (MinLength m) = fromIntegral (T.length s) >= m

197+satisfiesTyped (TString s) (Pattern p) = isJust $ match p s -- TODO: regex stuff #32

198+satisfiesTyped (TString s) (StringFormat f) = checkStringFormat f s

199+satisfiesTyped (TArray a) (Items f _) = all (`satisfies` f) a

200+satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m

201+satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m

202+satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36

203+satisfiesTyped (TObject o) (Properties props additional _) =

204+ all (`HM.member` o) (M.keys (M.filter propRequired props))

205+ && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)

206+satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m

207+satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m

208+

209+checkNumberFormat :: Format -> Scientific -> Bool

210+checkNumberFormat "int32" (toRational -> n) =

211+ denominator n == 1

212+ && n >= toRational (minBound :: Int32)

213+ && n <= toRational (maxBound :: Int32)

214+checkNumberFormat "int64" (toRational -> n) =

215+ denominator n == 1

216+ && n >= toRational (minBound :: Int64)

217+ && n <= toRational (maxBound :: Int64)

218+checkNumberFormat "float" _n = True

219+checkNumberFormat "double" _n = True

220+checkNumberFormat f _n = error $ "Invalid number format: " <> T.unpack f

221+

222+checkStringFormat :: Format -> Text -> Bool

223+checkStringFormat "byte" _s = True -- TODO: regex stuff #32

224+checkStringFormat "binary" _s = True

225+checkStringFormat "date" _s = True

226+checkStringFormat "date-time" _s = True

227+checkStringFormat "password" _s = True

228+checkStringFormat "uuid" _s = True

229+checkStringFormat f _s = error $ "Invalid string format: " <> T.unpack f

230+

231+deriving stock instance Eq (Condition t)

232+

233+deriving stock instance Ord (Condition t)

234+

235+deriving stock instance Show (Condition t)

236+

237+data SomeCondition where

238+ SomeCondition :: Typeable t => Condition t -> SomeCondition

239+

240+instance Eq SomeCondition where

241+ SomeCondition x == SomeCondition y = case cast x of

242+ Just x' -> x' == y

243+ Nothing -> False

244+

245+instance Ord SomeCondition where

246+ compare (SomeCondition x) (SomeCondition y) = case cast x of

247+ Just x' -> compare x' y

248+ Nothing -> compare (typeRep x) (typeRep y)

249+

250+deriving stock instance Show SomeCondition

251+

252+-- | A boolean formula (without "not") represented as a Disjunctive Normal Form:

253+-- the formula is a disjunction of a set of conjuncts, each of which is a

254+-- conjunction of a set of some elementary formulas.

255+newtype DNF a

256+ = DNF (S.Set (S.Set a))

257+ deriving stock (Eq, Ord, Show)

258+

259+disjAdd :: Ord a => DNF a -> S.Set a -> DNF a

260+disjAdd (DNF yss) xs

261+ | any (`S.isSubsetOf` xs) yss = DNF yss

262+ | otherwise = DNF $ S.insert xs $ S.filter (not . S.isSubsetOf xs) yss

263+

264+instance Ord a => Lattice (DNF a) where

265+ xss \/ DNF yss = S.foldl' disjAdd xss yss

266+ DNF xss /\ DNF yss =

267+ F.foldl' disjAdd bottom $

268+ liftA2 S.union (S.toList xss) (S.toList yss)

269+

270+pattern BottomFormula :: DNF a

271+pattern BottomFormula <-

272+ DNF (S.null -> True)

273+ where

274+ BottomFormula = DNF S.empty

275+

276+isSingleton :: S.Set a -> Maybe a

277+isSingleton s

278+ | S.size s == 1 = S.lookupMin s

279+ | otherwise = Nothing

280+

281+pattern Conjunct :: Ord a => [a] -> S.Set a

282+pattern Conjunct xs <-

283+ (S.toList -> xs)

284+ where

285+ Conjunct = S.fromList

286+

287+{-# COMPLETE Conjunct #-}

288+

289+pattern SingleConjunct :: Ord a => [a] -> DNF a

290+pattern SingleConjunct xs <-

291+ DNF (isSingleton -> Just (Conjunct xs))

292+ where

293+ SingleConjunct xs = DNF $ S.singleton $ Conjunct xs

294+

295+pattern TopFormula :: DNF a

296+pattern TopFormula <-

297+ DNF (isSingleton -> Just (S.null -> True))

298+ where

299+ TopFormula = DNF $ S.singleton S.empty

300+

301+instance Ord a => BoundedJoinSemiLattice (DNF a) where

302+ bottom = BottomFormula

303+

304+instance Ord a => BoundedMeetSemiLattice (DNF a) where

305+ top = TopFormula

306+

307+foldLattice

308+ :: BoundedLattice l

309+ => (a -> l)

310+ -> DNF a

311+ -> l

312+foldLattice f (DNF xss) =

313+ S.foldl'

314+ (\z w ->

315+ z \/ S.foldl' (\x y -> x /\ f y) top w)

316+ bottom

317+ xss

318+

319+newtype JsonFormula t = JsonFormula {getJsonFormula :: DNF (Condition t)}

320+ deriving stock (Eq, Ord, Show)

321+ deriving newtype (Lattice, BoundedJoinSemiLattice, BoundedMeetSemiLattice)

322+

323+satisfiesFormula :: TypedValue t -> JsonFormula t -> Bool

324+satisfiesFormula val = foldLattice (satisfiesTyped val) . getJsonFormula

325+

326+data ForeachType (f :: JsonType -> Type) = ForeachType

327+ { forNull :: f 'Null

328+ , forBoolean :: f 'Boolean

329+ , forNumber :: f 'Number

330+ , forString :: f 'String

331+ , forArray :: f 'Array

332+ , forObject :: f 'Object

333+ }

334+

335+satisfies :: A.Value -> ForeachType JsonFormula -> Bool

336+satisfies val p = case val of

337+ A.Null -> satisfiesFormula TNull $ forNull p

338+ A.Bool b -> satisfiesFormula (TBool b) $ forBoolean p

339+ A.Number n -> satisfiesFormula (TNumber n) $ forNumber p

340+ A.String s -> satisfiesFormula (TString s) $ forString p

341+ A.Array a -> satisfiesFormula (TArray a) $ forArray p

342+ A.Object o -> satisfiesFormula (TObject o) $ forObject p

343+

344+deriving stock instance (forall x. Typeable x => Eq (f x)) => Eq (ForeachType f)

345+

346+deriving stock instance (forall x. Typeable x => Ord (f x)) => Ord (ForeachType f)

347+

348+deriving stock instance (forall x. Typeable x => Show (f x)) => Show (ForeachType f)

349+

350+foldType

351+ :: Monoid m

352+ => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m)

353+ -> m

354+foldType k =

355+ k Null forNull

356+ <> k Boolean forBoolean

357+ <> k Number forNumber

358+ <> k String forString

359+ <> k Array forArray

360+ <> k Object forObject

361+

362+forType_

363+ :: Applicative m

364+ => (forall x. Typeable x => JsonType -> (ForeachType f -> f x) -> m ())

365+ -> m ()

366+forType_ k = do

367+ k Null forNull

368+ k Boolean forBoolean

369+ k Number forNumber

370+ k String forString

371+ k Array forArray

372+ k Object forObject

373+ pure ()

374+

375+instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where

376+ f1 \/ f2 =

377+ ForeachType

378+ { forNull = forNull f1 \/ forNull f2

379+ , forBoolean = forBoolean f1 \/ forBoolean f2

380+ , forNumber = forNumber f1 \/ forNumber f2

381+ , forString = forString f1 \/ forString f2

382+ , forArray = forArray f1 \/ forArray f2

383+ , forObject = forObject f1 \/ forObject f2

384+ }

385+ f1 /\ f2 =

386+ ForeachType

387+ { forNull = forNull f1 /\ forNull f2

388+ , forBoolean = forBoolean f1 /\ forBoolean f2

389+ , forNumber = forNumber f1 /\ forNumber f2

390+ , forString = forString f1 /\ forString f2

391+ , forArray = forArray f1 /\ forArray f2

392+ , forObject = forObject f1 /\ forObject f2

393+ }

394+

395+instance

396+ (forall x. BoundedJoinSemiLattice (f x))

397+ => BoundedJoinSemiLattice (ForeachType f)

398+ where

399+ bottom =

400+ ForeachType

401+ { forNull = bottom

402+ , forBoolean = bottom

403+ , forNumber = bottom

404+ , forString = bottom

405+ , forArray = bottom

406+ , forObject = bottom

407+ }

408+

409+instance

410+ (forall x. BoundedMeetSemiLattice (f x))

411+ => BoundedMeetSemiLattice (ForeachType f)

412+ where

413+ top =

414+ ForeachType

415+ { forNull = top

416+ , forBoolean = top

417+ , forNumber = top

418+ , forString = top

419+ , forArray = top

420+ , forObject = top

421+ }

422+

423+instance Steppable Schema (Referenced Schema) where

424+ data Step Schema (Referenced Schema)

425+ = AllOfStep Int

426+ | OneOfStep Int

427+ | AnyOfStep Int

428+ | ItemsObjectStep

429+ | ItemsArrayStep Int

430+ | AdditionalPropertiesStep

431+ | NotStep

432+ deriving stock (Eq, Ord, Show)

433+

434+instance Steppable (Referenced Schema) (Referenced Schema) where

435+ data Step (Referenced Schema) (Referenced Schema)

436+ = -- | Invariant (for better memoization only): the "tail" of the trace is

437+ -- the "least" of the traces of the conjuncted schemata

438+ ConjunctedWith (NE.NonEmpty (Trace (Referenced Schema)))

439+ | Partitioned PartitionLocation PartitionChoice

440+ deriving stock (Eq, Ord, Show)

441+

442+instance Steppable Schema (Definitions (Referenced Schema)) where

443+ data Step Schema (Definitions (Referenced Schema)) = PropertiesStep

444+ deriving stock (Eq, Ord, Show)

445+

446+instance Steppable Schema Discriminator where

447+ data Step Schema Discriminator = DiscriminatorStep

448+ deriving stock (Eq, Ord, Show)

449+

450+instance Steppable Discriminator (Definitions (Referenced Schema)) where

451+ data Step Discriminator (Definitions (Referenced Schema)) = DiscriminatorMapping

452+ deriving stock (Eq, Ord, Show)

453+

454+parseDiscriminatorValue :: Text -> Referenced Schema

455+parseDiscriminatorValue v = case A.fromJSON @(Referenced Schema) $ A.object ["$ref" A..= v] of

456+ A.Success x -> x

457+ A.Error _ -> Ref $ Reference v

458+

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

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

461+ deriving stock (Functor)

462+ deriving (Applicative, Monad) via Identity

463+

464+instance MonadWriter (P.PathsPrefixTree q f r) (Silent q f r) where

465+ tell _ = Silent ()

466+ listen (Silent x) = Silent (x, P.empty)

467+ pass (Silent (x, _)) = Silent x

468+

469+instance MonadState (MemoState ()) (Silent q f r) where

470+ get = Silent $ runIdentity $ runMemo () get

471+ put _ = pure ()

472+

473+type MonadProcess m =

474+ ( MonadReader (Traced (Definitions Schema)) m

475+ , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m

476+ , MonadState (MemoState ()) m

477+ )

478+

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

480+

481+warn :: MonadProcess m => Issue 'SchemaLevel -> m ()

482+warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue

483+

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

485+silently :: MonadProcess m => SilentM a -> m a

486+silently m = do

487+ defs <- R.ask

488+ pure . runSilent $ runReaderT m defs

489+

490+warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m

491+warnKnot =

492+ KnotTier

493+ { onKnotFound = warn UnguardedRecursion

494+ , onKnotUsed = \_ -> pure bottom

495+ , tieKnot = \_ -> pure

496+ }

497+

498+processRefSchema

499+ :: MonadProcess m

500+ => Traced (Referenced Schema)

501+ -> m (ForeachType JsonFormula)

502+processRefSchema x = do

503+ defs <- R.ask

504+ memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)

505+

506+tracedAllOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

507+tracedAllOf sch =

508+ _schemaAllOf (extract sch) <&> \xs ->

509+ [traced (ask sch >>> step (AllOfStep i)) x | (i, x) <- zip [0 ..] xs]

510+

511+tracedAnyOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

512+tracedAnyOf sch =

513+ _schemaAnyOf (extract sch) <&> \xs ->

514+ [traced (ask sch >>> step (AnyOfStep i)) x | (i, x) <- zip [0 ..] xs]

515+

516+tracedOneOf :: Traced Schema -> Maybe [Traced (Referenced Schema)]

517+tracedOneOf sch =

518+ _schemaOneOf (extract sch) <&> \xs ->

519+ [traced (ask sch >>> step (OneOfStep i)) x | (i, x) <- zip [0 ..] xs]

520+

521+tracedItems :: Traced Schema -> Maybe (Either (Traced (Referenced Schema)) [Traced (Referenced Schema)])

522+tracedItems sch =

523+ _schemaItems (extract sch) <&> \case

524+ OpenApiItemsObject x -> Left $ traced (ask sch >>> step ItemsObjectStep) x

525+ OpenApiItemsArray xs ->

526+ Right

527+ [traced (ask sch >>> step (ItemsArrayStep i)) x | (i, x) <- zip [0 ..] xs]

528+

529+tracedAdditionalProperties :: Traced Schema -> Maybe (Either Bool (Traced (Referenced Schema)))

530+tracedAdditionalProperties sch =

531+ _schemaAdditionalProperties (extract sch) <&> \case

532+ AdditionalPropertiesAllowed b -> Left b

533+ AdditionalPropertiesSchema x -> Right $ traced (ask sch >>> step AdditionalPropertiesStep) x

534+

535+tracedDiscriminator :: Traced Schema -> Maybe (Traced Discriminator)

536+tracedDiscriminator = sequence . stepTraced DiscriminatorStep . fmap _schemaDiscriminator

537+

538+tracedProperties :: Traced Schema -> IOHM.InsOrdHashMap Text (Traced (Referenced Schema))

539+tracedProperties sch =

540+ IOHM.mapWithKey

541+ (\k -> traced (ask sch >>> step PropertiesStep >>> step (InsOrdHashMapKeyStep k)))

542+ (_schemaProperties $ extract sch)

543+

544+-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition

545+-- for every possible type of a JSON value. The conditions are independent, and

546+-- are thus checked independently.

547+processSchema

548+ :: MonadProcess m

549+ => Traced Schema

550+ -> m (ForeachType JsonFormula)

551+processSchema sch@(extract -> Schema {..}) = do

552+ let singletonFormula :: Condition t -> JsonFormula t

553+ singletonFormula f = JsonFormula $ SingleConjunct [f]

554+

555+ allClauses <- case tracedAllOf sch of

556+ Nothing -> pure []

557+ Just [] -> [] <$ warn (InvalidSchema "no items in allOf")

558+ Just xs -> mapM processRefSchema xs

559+

560+ anyClause <- case tracedAnyOf sch of

561+ Nothing -> pure top

562+ Just [] -> bottom <$ warn (InvalidSchema "no items in anyOf")

563+ Just xs -> joins <$> mapM processRefSchema xs

564+

565+ oneClause <- case tracedOneOf sch of

566+ Nothing -> pure top

567+ Just [] -> bottom <$ warn (InvalidSchema "no items in oneOf")

568+ Just xs -> do

569+ checkOneOfDisjoint xs >>= \case

570+ True -> pure ()

571+ False -> warn (NotSupported "Could not determine that oneOf branches are disjoint")

572+ joins <$> mapM processRefSchema xs

573+

574+ case _schemaNot of

575+ Nothing -> pure ()

576+ Just _ -> warn (NotSupported "not clause is unsupported")

577+

578+ let typeClause = case _schemaType of

579+ Nothing -> top

580+ Just OpenApiNull ->

581+ bottom

582+ { forNull = top

583+ }

584+ Just OpenApiBoolean ->

585+ bottom

586+ { forBoolean = top

587+ }

588+ Just OpenApiNumber ->

589+ bottom

590+ { forNumber = top

591+ }

592+ Just OpenApiInteger ->

593+ bottom

594+ { forNumber = singletonFormula $ MultipleOf 1

595+ }

596+ Just OpenApiString ->

597+ bottom

598+ { forString = top

599+ }

600+ Just OpenApiArray ->

601+ bottom

602+ { forArray = top

603+ }

604+ Just OpenApiObject ->

605+ bottom

606+ { forObject = top

607+ }

608+

609+ let valueEnum A.Null =

610+ bottom

611+ { forNull = singletonFormula $ Exactly TNull

612+ }

613+ valueEnum (A.Bool b) =

614+ bottom

615+ { forBoolean = singletonFormula $ Exactly $ TBool b

616+ }

617+ valueEnum (A.Number n) =

618+ bottom

619+ { forNumber = singletonFormula $ Exactly $ TNumber n

620+ }

621+ valueEnum (A.String s) =

622+ bottom

623+ { forString = singletonFormula $ Exactly $ TString s

624+ }

625+ valueEnum (A.Array a) =

626+ bottom

627+ { forArray = singletonFormula $ Exactly $ TArray a

628+ }

629+ valueEnum (A.Object o) =

630+ bottom

631+ { forObject = singletonFormula $ Exactly $ TObject o

632+ }

633+ enumClause <- case _schemaEnum of

634+ Nothing -> pure top

635+ Just [] -> bottom <$ warn (InvalidSchema "no items in enum")

636+ Just xs -> pure $ joins (valueEnum <$> xs)

637+

638+ let maximumClause = case _schemaMaximum of

639+ Nothing -> top

640+ Just n ->

641+ top

642+ { forNumber = singletonFormula $

643+ Maximum $

644+ case _schemaExclusiveMaximum of

645+ Just True -> Exclusive n

646+ _ -> Inclusive n

647+ }

648+

649+ minimumClause = case _schemaMinimum of

650+ Nothing -> top

651+ Just n ->

652+ top

653+ { forNumber = singletonFormula $

654+ Minimum $

655+ Down $

656+ case _schemaExclusiveMinimum of

657+ Just True -> Exclusive $ Down n

658+ _ -> Inclusive $ Down n

659+ }

660+

661+ multipleOfClause = case _schemaMultipleOf of

662+ Nothing -> top

663+ Just n ->

664+ top

665+ { forNumber = singletonFormula $ MultipleOf n

666+ }

667+

668+ formatClause <- case _schemaFormat of

669+ Nothing -> pure top

670+ Just f

671+ | f `elem` ["int32", "int64", "float", "double"] ->

672+ pure

673+ top

674+ { forNumber = singletonFormula $ NumberFormat f

675+ }

676+ Just f

677+ | f `elem` ["byte", "binary", "date", "date-time", "password", "uuid"] ->

678+ pure

679+ top

680+ { forString = singletonFormula $ StringFormat f

681+ }

682+ Just f -> top <$ warn (NotSupported $ "Unknown format: " <> f)

683+

684+ let maxLengthClause = case _schemaMaxLength of

685+ Nothing -> top

686+ Just n ->

687+ top

688+ { forString = singletonFormula $ MaxLength n

689+ }

690+

691+ minLengthClause = case _schemaMinLength of

692+ Nothing -> top

693+ Just n ->

694+ top

695+ { forString = singletonFormula $ MinLength n

696+ }

697+

698+ patternClause = case _schemaPattern of

699+ Nothing -> top

700+ Just p ->

701+ top

702+ { forString = singletonFormula $ Pattern p

703+ }

704+

705+ itemsClause <- case tracedItems sch of

706+ Nothing -> pure top

707+ Just (Left rs) -> do

708+ f <- silently $ processRefSchema rs

709+ pure top {forArray = singletonFormula $ Items f rs}

710+ Just (Right _) -> top <$ warn (NotSupported "array in items is not supported")

711+

712+ let maxItemsClause = case _schemaMaxItems of

713+ Nothing -> top

714+ Just n ->

715+ top

716+ { forArray = singletonFormula $ MaxItems n

717+ }

718+

719+ minItemsClause = case _schemaMinItems of

720+ Nothing -> top

721+ Just n ->

722+ top

723+ { forArray = singletonFormula $ MinItems n

724+ }

725+

726+ uniqueItemsClause = case _schemaUniqueItems of

727+ Just True ->

728+ top

729+ { forArray = singletonFormula UniqueItems

730+ }

731+ _ -> top

732+

733+ (addProps, addPropSchema) <- case tracedAdditionalProperties sch of

734+ Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)

735+ Just (Left False) -> pure (bottom, Nothing)

736+ _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)

737+ propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do

738+ (f, psch) <- case IOHM.lookup k $ tracedProperties sch of

739+ Just rs -> (,rs) <$> silently (processRefSchema rs)

740+ Nothing ->

741+ let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty

742+ in -- The mempty here is incorrect, but if addPropSchema was Nothing, then

743+ -- addProps is bottom, and k is in _schemaRequired. We handle this situation

744+ -- below and short-circuit the entire Properties condition to bottom

745+ pure (addProps, fromMaybe fakeSchema addPropSchema)

746+ pure (k, Property (k `elem` _schemaRequired) f psch)

747+ let allBottom f = getAll $

748+ foldType $ \_ ty -> case getJsonFormula $ ty f of

749+ BottomFormula -> All True

750+ _ -> All False

751+ allTop f = getAll $

752+ foldType $ \_ ty -> case getJsonFormula $ ty f of

753+ TopFormula -> All True

754+ _ -> All False

755+ -- remove optional fields whose schemata match that of additional props

756+ propMap = M.filter (\p -> propRequired p || propFormula p /= addProps) $ M.fromList propList

757+ propertiesClause

758+ | any (\p -> propRequired p && allBottom (propFormula p)) propMap =

759+ bottom -- if any required field has unsatisfiable schema

760+ | M.null propMap

761+ , allTop addProps =

762+ top -- if all fields are optional and have trivial schemata

763+ | otherwise =

764+ top

765+ { forObject = singletonFormula $ Properties propMap addProps addPropSchema

766+ }

767+

768+ maxPropertiesClause = case _schemaMaxProperties of

769+ Nothing -> top

770+ Just n ->

771+ top

772+ { forObject = singletonFormula $ MaxProperties n

773+ }

774+

775+ minPropertiesClause = case _schemaMinProperties of

776+ Nothing -> top

777+ Just n ->

778+ top

779+ { forObject = singletonFormula $ MinProperties n

780+ }

781+

782+ nullableClause

783+ | Just True <- _schemaNullable =

784+ bottom

785+ { forNull = singletonFormula $ Exactly TNull

786+ }

787+ | otherwise = bottom

788+

789+ pure $

790+ nullableClause

791+ \/ meets

792+ (allClauses

793+ <> [ anyClause

794+ , oneClause

795+ , typeClause

796+ , enumClause

797+ , maximumClause

798+ , minimumClause

799+ , multipleOfClause

800+ , formatClause

801+ , maxLengthClause

802+ , minLengthClause

803+ , patternClause

804+ , itemsClause

805+ , maxItemsClause

806+ , minItemsClause

807+ , uniqueItemsClause

808+ , propertiesClause

809+ , maxPropertiesClause

810+ , minPropertiesClause

811+ ])

812+

813+{- TODO: ReadOnly/WriteOnly #68 -}

814+

815+checkOneOfDisjoint :: MonadProcess m => [Traced (Referenced Schema)] -> m Bool

816+checkOneOfDisjoint = const $ pure True -- TODO #69

817+

818+schemaToFormula

819+ :: Traced (Definitions Schema)

820+ -> Traced Schema

821+ -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

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

823+

824+checkFormulas

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

826+ => HList xs

827+ -> Behavior 'SchemaLevel

828+ -> ProdCons (Traced (Definitions Schema))

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

830+ -> SemanticCompatFormula ()

831+checkFormulas env beh defs (ProdCons (fp, ep) (fc, ec)) =

832+ case P.toList ep ++ P.toList ec of

833+ issues@(_ : _) -> F.for_ issues $ embedFormula beh . anItem

834+ [] -> do

835+ -- We have the following isomorphisms:

836+ -- (A ⊂ X ∪ Y) = (A ⊂ X) \/ (A ⊂ Y)

837+ -- (A ⊂ X ∩ Y) = (A ⊂ X) /\ (A ⊂ Y)

838+ -- (A ⊂ ⊤) = 1

839+ -- (X ∪ Y ⊂ B) = (X ⊂ B) /\ (Y ⊂ B)

840+ -- (∅ ⊂ B) = 1

841+ -- The remaining cases are, notably, not isomorphisms:

842+ -- 1) (A ⊂ ∅) <= 0

843+ -- 2) (X ∩ Y ⊂ B) <= (X ⊂ B) \/ (Y ⊂ B)

844+ -- 3) (⊤ ⊂ B) <= 0

845+ -- Therefore we have the isomorphisms with (∃ and ∀ being the N-ary

846+ -- versions of \/ and /\ respectively):

847+ -- (⋃_i ⋂_j A[i,j]) ⊂ (⋃_k ⋂_l B[k,l])

848+ -- = ∃k ∀l ∀i, (⋂_j A[i,j]) ⊂ B[k,l]

849+ -- = ∀i ∃k ∀l, (⋂_j A[i,j]) ⊂ B[k,l]

850+ -- with the caveat that the the set over which k ranges is nonempty.

851+ -- This is because 1) is not an isomorphism.

852+ -- Our disjunction loses information, so it makes sense to nest it as

853+ -- deeply as possible, hence we choose the latter representation.

854+ --

855+ -- We delegate the verification of (⋂_j A[j]) ⊂ B to a separate heuristic

856+ -- function, with the understanding that ∃j, A[j] ⊂ B is a sufficient,

857+ -- but not necessary condition (because of 2) and 3)).

858+ --

859+ -- If k ranges over an empty set, we have the isomorphism:

860+ -- (⋃_i ⋂_j A[i,j]) ⊂ ∅ = ∀i, (⋂_j A[i,j]) ⊂ ∅

861+ -- where we again delegate (⋂_j A[j]) ⊂ ∅ to a heuristic, though here the

862+ -- shortcut of ∃j, A[j] ⊂ ∅ hardly helps.

863+ --

864+ -- Disjunctions tend to erase informative error messages, so we may want

865+ -- to avoid them. This can be formally done as follows: if we can

866+ -- partition the universal set into a disjoint union of some parts:

867+ -- ⊤ = ⊔_α P[α]

868+ -- such that the conjuncts in our disjunctive normal form are subordinate

869+ -- to the partition:

870+ -- ∀i ∃α, (⋂_j A[i,j]) ⊂ P[α]

871+ -- ∀k ∃α, (⋂_l B[k,l]) ⊂ P[α]

872+ -- then we can partition the sets over which i and k range into partitions

873+ -- I[α] and K[α], and then in each "bucket" verify the inclusion in the

874+ -- aforementioned way:

875+ -- ∀α, (⋃_i∈I[α] ⋂_j A[i,j]) ⊂ (⋃_k∈K[α] ⋂_l B[k,l])

876+ -- = ∀α ∀i∈I[α] ∃k∈K[α] ∀l, (⋂_j A[i,j]) ⊂ B[k,l]

877+ -- We already somewhat do this by partitioning JSON into types, but we can

878+ -- additionally partition e.g. "enum" fields or existence of particular

879+ -- properties. This works especially well if we manage to ensure K[α] are

880+ -- 1-element sets.

881+ --

882+ -- Since the set:

883+ -- (⋃_i∈I[α] ⋂_j A[i,j]) = (⋃_i ⋂_j A[i,j]) ∩ P[α]

884+ -- does not actually appear in the source schema, we need to construct it

885+ -- ourselves and come up with a name for it.

886+ let typesRestricted = not (anyBottomTypes fp) && anyBottomTypes fc

887+ -- Specifically handle the case when a schema's type has been

888+ -- restricted from "all" to specific types: if all types were allowed

889+ -- in the producer and not all types are allowed in the consumer, it's

890+ -- usually easier to say what's left than what's removed

891+ when typesRestricted $ issueAt beh $ TypesRestricted $ nonBottomTypes fc

892+ forType_ $ \tyName ty -> do

893+ let beh' = beh >>> step (OfType tyName)

894+ case (getJsonFormula $ ty fp, getJsonFormula $ ty fc) of

895+ (DNF pss, BottomFormula) -> unless typesRestricted $ do

896+ -- don't repeat the TypesRestricted issue

897+ F.for_ pss $ \(Conjunct ps) -> checkContradiction beh' ps

898+ (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do

899+ F.for_ cs $ checkImplication env beh' ps -- avoid disjunction if there's only one conjunct

900+ (TopFormula, DNF css) ->

901+ -- producer is "open" (allows any value), but consumer has restrictions.

902+ -- In this case we want to show which restrictions were added. (instead

903+ -- of showing an empty list restrictions that couldn't be satisfied.)

904+ F.for_ css $ \(Conjunct cs) -> F.for_ cs $ checkImplication env beh' []

905+ (pss', css') -> F.for_ (tryPartition defs $ ProdCons (JsonFormula pss') (JsonFormula css')) $ \case

906+ (mPart, ProdCons pf cf) -> do

907+ let beh'' = foldr ((<<<) . step . InPartition) beh' mPart

908+ case (getJsonFormula pf, getJsonFormula cf) of

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

910+ (DNF pss, SingleConjunct cs) -> F.for_ pss $ \(Conjunct ps) -> do

911+ F.for_ cs $ checkImplication env beh'' ps

912+ -- unlucky:

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

914+ anyOfAt

915+ beh'

916+ (issueFromConjunct Nothing ps)

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

918+ pure ()

919+ where

920+ anyBottomTypes f = getAny $

921+ foldType $ \_ ty -> case getJsonFormula $ ty f of

922+ BottomFormula -> Any True

923+ _ -> mempty

924+ nonBottomTypes f = foldType $ \tyName ty -> case getJsonFormula $ ty f of

925+ BottomFormula -> mempty

926+ _ -> [tyName]

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

928+ issueFromConjunct _ ps

929+ | Just e <- findExactly ps

930+ , all (satisfiesTyped e) ps =

931+ EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?

932+ issueFromConjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> ps

933+

934+data PartitionData

935+ = DByEnumValue (DNF (S.Set A.Value))

936+ | DByProperties (DNF (S.Set Text, S.Set Text)) -- optional, required

937+ deriving stock (Eq, Ord, Show)

938+

939+data PartitionChoice

940+ = CByEnumValue (S.Set A.Value)

941+ | CByProperties (S.Set Text) (S.Set Text) -- included, excluded

942+ deriving stock (Eq, Ord, Show)

943+

944+conjPart :: PartitionData -> PartitionData -> Maybe PartitionData

945+conjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss /\ yss

946+conjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss /\ yss

947+conjPart _ _ = Nothing

948+

949+disjPart :: PartitionData -> PartitionData -> Maybe PartitionData

950+disjPart (DByEnumValue xss) (DByEnumValue yss) = Just . DByEnumValue $ xss \/ yss

951+disjPart (DByProperties xss) (DByProperties yss) = Just . DByProperties $ xss \/ yss

952+disjPart _ _ = Nothing

953+

954+data PartitionLocation

955+ = PHere

956+ | PInProperty Text PartitionLocation

957+ deriving stock (Eq, Ord, Show)

958+

959+newtype Partitions = Partitions (M.Map PartitionLocation (S.Set PartitionData))

960+ deriving stock (Eq, Ord, Show)

961+

962+instance Lattice Partitions where

963+ Partitions xss /\ Partitions yss = Partitions $ M.unionWith conj xss yss

964+ where

965+ conj xs ys = S.fromList . catMaybes $ liftA2 conjPart (S.toList xs) (S.toList ys)

966+ Partitions xss \/ Partitions yss = Partitions $ M.intersectionWith disj xss yss

967+ where

968+ disj xs ys = S.fromList . catMaybes $ liftA2 disjPart (S.toList xs) (S.toList ys)

969+

970+instance BoundedMeetSemiLattice Partitions where

971+ top = Partitions M.empty

972+

973+-- The lattice has no bottom, but we use 'Lifted' to adjoin a free bottom element

974+

975+type PartitionM = ReaderT (Traced (Definitions Schema)) (State (MemoState ()))

976+

977+ignoreKnot :: KnotTier (Lifted Partitions) () PartitionM

978+ignoreKnot =

979+ KnotTier

980+ { onKnotFound = pure ()

981+ , onKnotUsed = \_ -> pure bottom

982+ , tieKnot = \_ -> pure

983+ }

984+

985+singletonPart :: PartitionData -> Lifted Partitions

986+singletonPart = Lift . Partitions . M.singleton PHere . S.singleton

987+

988+partitionSchema :: Traced Schema -> PartitionM (Lifted Partitions)

989+partitionSchema sch = do

990+ allClauses <- case tracedAllOf sch of

991+ Nothing -> pure []

992+ Just xs -> mapM partitionRefSchema xs

993+

994+ anyClause <- case tracedAnyOf sch of

995+ Nothing -> pure top

996+ Just xs -> joins <$> mapM partitionRefSchema xs

997+

998+ oneClause <- case tracedOneOf sch of

999+ Nothing -> pure top

1000+ Just xs -> joins <$> mapM partitionRefSchema xs

1001+

1002+ byEnumClause <- case _schemaEnum $ extract sch of

1003+ Nothing -> pure top

1004+ Just xs ->

1005+ pure . singletonPart $

1006+ DByEnumValue $ SingleConjunct [S.fromList xs]

1007+

1008+ -- We can only partition by presence of a property if additional properties

1009+ -- are disallowed, and the property is not optional

1010+ let reqd = S.fromList $ _schemaRequired $ extract sch

1011+ byPropertiesClause <- case _schemaAdditionalProperties $ extract sch of

1012+ Just (AdditionalPropertiesAllowed False) -> do

1013+ let props = S.fromList . IOHM.keys . _schemaProperties $ extract sch

1014+ pure . singletonPart $

1015+ DByProperties $ SingleConjunct [(props S.\\ reqd, props `S.intersection` reqd)]

1016+ _ -> pure top

1017+

1018+ -- We can partition on something nested in a property only if the property is

1019+ -- required

1020+ let reqdProps = IOHM.filterWithKey (\k _ -> k `S.member` reqd) $ tracedProperties sch

1021+ inPropertiesClauses <- forM (IOHM.toList reqdProps) $ \(k, rs) -> do

1022+ f <- partitionRefSchema rs

1023+ pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f

1024+

1025+ pure $ meets $ allClauses <> [anyClause, oneClause, byEnumClause, byPropertiesClause] <> inPropertiesClauses

1026+

1027+partitionRefSchema :: Traced (Referenced Schema) -> PartitionM (Lifted Partitions)

1028+partitionRefSchema x = do

1029+ defs <- R.ask

1030+ memoWithKnot ignoreKnot (partitionSchema $ dereference defs x) (ask x)

1031+

1032+newtype LiftA f a = LiftA {getLiftA :: f a}

1033+ deriving newtype (Functor, Applicative)

1034+

1035+instance (Lattice a, Applicative f) => Lattice (LiftA f a) where

1036+ (/\) = liftA2 (/\)

1037+ (\/) = liftA2 (\/)

1038+

1039+instance (BoundedJoinSemiLattice a, Applicative f) => BoundedJoinSemiLattice (LiftA f a) where

1040+ bottom = pure bottom

1041+

1042+instance (BoundedMeetSemiLattice a, Applicative f) => BoundedMeetSemiLattice (LiftA f a) where

1043+ top = pure top

1044+

1045+partitionCondition :: Condition t -> PartitionM (Lifted Partitions)

1046+partitionCondition = \case

1047+ Exactly x ->

1048+ pure . singletonPart $

1049+ DByEnumValue $ SingleConjunct [S.singleton $ untypeValue x]

1050+ Properties props _ madd -> do

1051+ let byProps = case madd of

1052+ Just _ -> top

1053+ Nothing ->

1054+ singletonPart $

1055+ DByProperties $

1056+ SingleConjunct

1057+ [ ( M.keysSet $ M.filter (not . propRequired) props

1058+ , M.keysSet $ M.filter propRequired props

1059+ )

1060+ ]

1061+ inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do

1062+ f <- partitionRefSchema $ propRefSchema prop

1063+ pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f

1064+ pure $ byProps /\ meets inProps

1065+ _ -> pure top

1066+

1067+partitionJsonFormulas

1068+ :: ProdCons (Traced (Definitions Schema))

1069+ -> ProdCons (JsonFormula t)

1070+ -> Lifted Partitions

1071+partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart

1072+ where

1073+ pcPart = partitionFormula <$> defs <*> pc

1074+ partitionFormula def (JsonFormula xss) = runIdentity . runMemo () . (`runReaderT` def) $ do

1075+ getLiftA . foldLattice (LiftA . partitionCondition) $ xss

1076+

1077+selectPartition :: Lifted Partitions -> Maybe (PartitionLocation, S.Set PartitionChoice)

1078+selectPartition Bottom = Nothing

1079+selectPartition (Lift (Partitions m)) =

1080+ go [(loc, part) | (loc, parts) <- sortBy (comparing $ locLength . fst) $ M.toList m, part <- S.toList parts]

1081+ where

1082+ locLength :: PartitionLocation -> Int

1083+ locLength = walk 0

1084+ where

1085+ walk !n PHere = n

1086+ walk !n (PInProperty _ l) = walk (n + 1) l

1087+ go [] = Nothing

1088+ -- Skip partitioning by property for now

1089+ go ((_, DByProperties _) : ps) = go ps

1090+ -- Don't partition by enum value at the root (this reports removed enum values as contradictions in their respective partitions)

1091+ go ((PHere, DByEnumValue _) : ps) = go ps

1092+ go ((loc, DByEnumValue (DNF xss)) : ps)

1093+ -- Check that no disjunction branches are unresticted

1094+ | Just enums <- traverse (fmap (foldr1 S.intersection) . NE.nonEmpty . S.toList) . S.toList $ xss =

1095+ -- TODO: improve

1096+ Just (loc, S.map (CByEnumValue . S.singleton) $ S.unions enums)

1097+ | otherwise = go ps

1098+

1099+-- This essentially has 3 cases:

1100+-- Nothing -- we have produced a bottom schema

1101+-- Just (False, _) -- there's been no change to the schema

1102+-- Just (True, x) -- x is a new schema

1103+type IntersectionM = ReaderT (Traced (Definitions Schema)) (WriterT Any Maybe)

1104+

1105+mBottom :: IntersectionM a

1106+mBottom = lift . lift $ Nothing

1107+

1108+catchBottom :: IntersectionM a -> IntersectionM a -> IntersectionM a

1109+catchBottom act handler = R.liftCatch (W.liftCatch (\a h -> a <|> h ())) act (\_ -> handler)

1110+

1111+mChange :: IntersectionM ()

1112+mChange = tell $ Any True

1113+

1114+intersectSchema

1115+ :: PartitionLocation

1116+ -> PartitionChoice

1117+ -> Traced Schema

1118+ -> IntersectionM Schema

1119+intersectSchema loc part sch = do

1120+ allOf' <- forM (tracedAllOf sch) $ \rss ->

1121+ -- Assuming i ranges over a nonempty set (checked in processSchema)

1122+ -- (⋂_i A[i]) ∩ X = ⋂_i (A[i] ∩ X)

1123+ -- If any intersections are empty, the result is empty. If any intersections are a change, the result is a change.

1124+ traverse (intersectRefSchema loc part) rss

1125+ anyOf' <- forM (tracedAnyOf sch) $ \rss -> do

1126+ -- (⋃_i A[i]) ∩ X = ⋃_i (A[i] ∩ X)

1127+ -- Collect only the nonempty A[i] ∩ X, unless there are none, in which case the result is empty.

1128+ -- If any schema is empty, we remove it from the list which constitutes a change.

1129+ mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)

1130+ case catMaybes mSchemas of

1131+ [] -> mBottom

1132+ schs -> pure schs

1133+ oneOf' <- forM (tracedOneOf sch) $ \rss -> do

1134+ -- Same as anyOf'. By intersecting we're only making them more disjoint if anything.

1135+ mSchemas <- forM rss $ \rs -> catchBottom (Just <$> intersectRefSchema loc part rs) (mChange >> pure Nothing)

1136+ case catMaybes mSchemas of

1137+ [] -> mBottom

1138+ schs -> pure schs

1139+ let sch' = (extract sch) {_schemaAllOf = allOf', _schemaAnyOf = anyOf', _schemaOneOf = oneOf'}

1140+ -- Now the local changes:

1141+ case loc of

1142+ PInProperty k loc' -> case IOHM.lookup k $ tracedProperties sch of

1143+ Nothing -> error $ "Partitioning via absent property: " <> T.unpack k

1144+ Just prop -> do

1145+ prop' <- intersectRefSchema loc' part prop

1146+ pure $ sch' {_schemaProperties = IOHM.adjust (const prop') k $ _schemaProperties sch'}

1147+ PHere -> case part of

1148+ CByEnumValue vals -> do

1149+ enum' <- case _schemaEnum sch' of

1150+ Nothing -> do

1151+ mChange

1152+ pure $ S.toList vals

1153+ Just xs -> do

1154+ when (any (`S.notMember` vals) xs) mChange

1155+ case filter (`S.member` vals) xs of

1156+ [] -> mBottom

1157+ xs' -> pure xs'

1158+ pure $ sch' {_schemaEnum = Just enum'}

1159+ CByProperties {} -> error "CByProperties not implemented"

1160+

1161+intersectRefSchema

1162+ :: PartitionLocation

1163+ -> PartitionChoice

1164+ -> Traced (Referenced Schema)

1165+ -> IntersectionM (Referenced Schema)

1166+intersectRefSchema loc part rs = do

1167+ defs <- R.ask

1168+ Inline <$> intersectSchema loc part (dereference defs rs)

1169+

1170+intersectCondition :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> Condition t -> DNF (Condition t)

1171+intersectCondition _defs PHere (CByEnumValue values) cond@(Exactly x) =

1172+ if untypeValue x `S.member` values then SingleConjunct [cond] else bottom

1173+intersectCondition defs (PInProperty k loc) part cond@(Properties props add madd) = case M.lookup k props of

1174+ Nothing -> SingleConjunct [cond] -- shouldn't happen

1175+ Just prop -> case runWriterT . (`runReaderT` defs) $ intersectRefSchema loc part $ propRefSchema prop of

1176+ Just (rs', Any True) ->

1177+ let trs' = traced (ask (propRefSchema prop) >>> step (Partitioned loc part)) rs'

1178+ in SingleConjunct [Properties (M.insert k prop {propRefSchema = trs'} props) add madd]

1179+ Just (_, Any False) -> SingleConjunct [cond]

1180+ Nothing -> bottom

1181+intersectCondition _defs _loc _part cond = SingleConjunct [cond]

1182+

1183+intersectFormula :: Traced (Definitions Schema) -> PartitionLocation -> PartitionChoice -> JsonFormula t -> JsonFormula t

1184+intersectFormula defs loc part = JsonFormula . foldLattice (intersectCondition defs loc part) . getJsonFormula

1185+

1186+type Partition = Maybe (PartitionLocation, PartitionChoice)

1187+

1188+tryPartition :: ProdCons (Traced (Definitions Schema)) -> ProdCons (JsonFormula t) -> [(Partition, ProdCons (JsonFormula t))]

1189+tryPartition defs pc = case selectPartition $ partitionJsonFormulas defs pc of

1190+ Nothing -> [(Nothing, pc)]

1191+ Just (loc, parts) -> [(Just (loc, part), intersectFormula <$> defs <*> pure loc <*> pure part <*> pc) | part <- S.toList parts]

1192+

1193+checkContradiction

1194+ :: Behavior 'TypedSchemaLevel

1195+ -> [Condition t]

1196+ -> SemanticCompatFormula ()

1197+checkContradiction beh _ = issueAt beh NoContradiction -- TODO #70

1198+

1199+tracedConjunct :: NE.NonEmpty (Traced (Referenced Schema)) -> Traced (Referenced Schema)

1200+tracedConjunct refSchemas = case NE.sortWith ask refSchemas of

1201+ (rs NE.:| []) -> rs

1202+ (rs1 NE.:| rs2 : rss) ->

1203+ traced (ask rs1 >>> step (ConjunctedWith $ ask <$> rs2 NE.:| rss)) $

1204+ Inline mempty {_schemaAllOf = Just $ extract <$> rs1 : rs2 : rss}

1205+

1206+checkImplication

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

1208+ => HList xs

1209+ -> Behavior 'TypedSchemaLevel

1210+ -> [Condition t]

1211+ -> Condition t

1212+ -> SemanticCompatFormula ()

1213+checkImplication env beh prods cons = case findExactly prods of

1214+ Just e

1215+ | all (satisfiesTyped e) prods ->

1216+ if satisfiesTyped e cons

1217+ then pure ()

1218+ else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

1219+ | otherwise -> pure () -- vacuously true

1220+ Nothing -> case cons of

1221+ -- the above code didn't catch it, so there's no Exactly condition on the lhs

1222+ Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)

1223+ Maximum m -> case findRelevant min (\case Maximum m' -> Just m'; _ -> Nothing) prods of

1224+ Just m' ->

1225+ if m' <= m

1226+ then pure ()

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

1228+ Nothing -> issueAt beh (NoMatchingMaximum m)

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

1230+ Just m' ->

1231+ if m' >= m

1232+ then pure ()

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

1234+ Nothing -> issueAt beh (NoMatchingMinimum (coerce m))

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

1236+ Just m' ->

1237+ if lcmScientific m m' == m'

1238+ then pure ()

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

1240+ Nothing -> issueAt beh (NoMatchingMultipleOf m)

1241+ NumberFormat f ->

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

1243+ then pure ()

1244+ else issueAt beh (NoMatchingFormat f)

1245+ MaxLength m -> case findRelevant min (\case MaxLength m' -> Just m'; _ -> Nothing) prods of

1246+ Just m' ->

1247+ if m' <= m

1248+ then pure ()

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

1250+ Nothing -> issueAt beh (NoMatchingMaxLength m)

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

1252+ Just m' ->

1253+ if m' >= m

1254+ then pure ()

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

1256+ Nothing -> issueAt beh (NoMatchingMinLength m)

1257+ Pattern p ->

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

1259+ then pure ()

1260+ else issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32

1261+ StringFormat f ->

1262+ if any (\case StringFormat f' -> f == f'; _ -> False) prods

1263+ then pure ()

1264+ else issueAt beh (NoMatchingFormat f)

1265+ Items _ cons' -> case findRelevant (<>) (\case Items _ rs -> Just (rs NE.:| []); _ -> Nothing) prods of

1266+ Just (tracedConjunct -> rs) -> checkCompatibility (beh >>> step InItems) env $ ProdCons rs cons'

1267+ Nothing -> issueAt beh NoMatchingItems

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

1269+ Just m' ->

1270+ if m' <= m

1271+ then pure ()

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

1273+ Nothing -> issueAt beh (NoMatchingMaxItems m)

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

1275+ Just m' ->

1276+ if m' >= m

1277+ then pure ()

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

1279+ Nothing -> issueAt beh (NoMatchingMinItems m)

1280+ UniqueItems ->

1281+ if any (== UniqueItems) $ prods

1282+ then pure ()

1283+ else issueAt beh NoMatchingUniqueItems

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

1285+ Just pm ->

1286+ anyOfAt beh NoMatchingProperties $

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

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

1289+ let beh' = beh >>> step (InProperty k)

1290+ go sch sch' = checkCompatibility beh' env (ProdCons sch sch')

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

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

1293+ (False, True) -> issueAt beh' PropertyNowRequired

1294+ _ -> pure ()

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

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

1297+ (Nothing, Nothing, _, _) -> pure () -- vacuously: the producer asserts that this field cannot exist,

1298+ -- and the consumer either doesn't require it, or it does and we've already raised an error about it.

1299+ (_, _, Nothing, Nothing) -> issueAt beh' UnexpectedProperty

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

1301+ (Nothing, Just add', Just p, _) ->

1302+ clarifyIssue (AnItem beh' (anIssue AdditionalToProperty)) $

1303+ go add' (propRefSchema p)

1304+ (Just p', _, Nothing, Just add) ->

1305+ clarifyIssue (AnItem beh' (anIssue PropertyToAdditional)) $

1306+ go (propRefSchema p') add

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

1308+ pure ()

1309+ case (madd', madd) of

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

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

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

1313+ pure ()

1314+ Nothing -> issueAt beh NoMatchingProperties

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

1316+ Just m' ->

1317+ if m' <= m

1318+ then pure ()

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

1320+ Nothing -> issueAt beh (NoMatchingMaxProperties m)

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

1322+ Just m' ->

1323+ if m' >= m

1324+ then pure ()

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

1326+ Nothing -> issueAt beh (NoMatchingMinProperties m)

1327+ where

1328+ findRelevant combine extr =

1329+ fmap (foldr1 combine) . NE.nonEmpty . mapMaybe extr

1330+ lcmScientific (toRational -> a) (toRational -> b) =

1331+ fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

1332+

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

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

1335+findExactly (_ : xs) = findExactly xs

1336+findExactly [] = Nothing

1337+

1338+instance Issuable 'TypedSchemaLevel where

1339+ data Issue 'TypedSchemaLevel

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

1341+ EnumDoesntSatisfy A.Value

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

1343+ NoMatchingEnum A.Value

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

1345+ NoMatchingMaximum (Bound Scientific)

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

1347+ MatchingMaximumWeak (ProdCons (Bound Scientific))

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

1349+ NoMatchingMinimum (Bound Scientific)

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

1351+ MatchingMinimumWeak (ProdCons (Bound Scientific))

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

1353+ NoMatchingMultipleOf Scientific

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

1355+ MatchingMultipleOfWeak (ProdCons Scientific)

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

1357+ NoMatchingFormat Format

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

1359+ NoMatchingMaxLength Integer

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

1361+ MatchingMaxLengthWeak (ProdCons Integer)

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

1363+ NoMatchingMinLength Integer

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

1365+ MatchingMinLengthWeak (ProdCons Integer)

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

1367+ NoMatchingPattern Pattern

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

1369+ NoMatchingItems

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

1371+ NoMatchingMaxItems Integer

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

1373+ MatchingMaxItemsWeak (ProdCons Integer)

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

1375+ NoMatchingMinItems Integer

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

1377+ MatchingMinItemsWeak (ProdCons Integer)

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

1379+ NoMatchingUniqueItems

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

1381+ NoMatchingProperties

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

1383+ NoAdditionalProperties

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

1385+ NoMatchingMaxProperties Integer

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

1387+ MatchingMaxPropertiesWeak (ProdCons Integer)

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

1389+ NoMatchingMinProperties Integer

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

1391+ MatchingMinPropertiesWeak (ProdCons Integer)

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

1393+ NoMatchingCondition Partition [SomeCondition]

1394+ | -- | producer indicates that values of this type are now allowed, but the consumer does not do so (currently we only check immediate contradictions, c.f. #70)

1395+ -- AKA consumer does not have the type

1396+ NoContradiction

1397+ deriving stock (Eq, Ord, Show)

1398+ issueIsUnsupported _ = False

1399+ describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v

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

1401+ describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v

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

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

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

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

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

1407+ describeIssue Backward (NoMatchingMinimum b) = para $ "Lower bound has been removed: " <> showBound b <> "."

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

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

1410+ describeIssue Backward (NoMatchingMultipleOf n) = para $ "Value is no longer a multiple of " <> show' n <> "."

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

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

1413+ describeIssue Backward (NoMatchingFormat f) = para $ "Format removed: " <> code f <> "."

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

1415+ describeIssue Backward (NoMatchingMaxLength n) = para $ "Maximum length removed: " <> show' n <> "."

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

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

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

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

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

1421+ describeIssue Backward (NoMatchingPattern p) = para "Pattern (regular expression) removed: " <> codeBlock p

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

1423+ describeIssue Backward NoMatchingItems = para "Array item schema has been removed."

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

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

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

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

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

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

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

1431+ describeIssue Backward NoMatchingUniqueItems = para "Items are no longer required to be unique."

1432+ describeIssue Forward NoMatchingProperties = para "Property added."

1433+ describeIssue Backward NoMatchingProperties = para "Property removed."

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

1435+ describeIssue Backward NoAdditionalProperties = para "Additional properties have been added."

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

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

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

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

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

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

1442+ describeIssue _ (NoMatchingCondition mPart conds) =

1443+ para

1444+ (case mPart of

1445+ Nothing -> "Could not verify that the following conditions hold (please file a bug if you see this)"

1446+ Just locPart ->

1447+ showPartition locPart

1448+ <> " – could not verify that the following conditions hold (please file a bug if you see this):")

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

1450+ describeIssue Forward NoContradiction = para "The value has been removed."

1451+ describeIssue Backward NoContradiction = para "The value has been added."

1452+

1453+showJSONValue :: A.Value -> Blocks

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

1455+

1456+showJSONValueInline :: A.Value -> Inlines

1457+showJSONValueInline v = code (T.decodeUtf8 . BSL.toStrict . A.encode $ v)

1458+

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

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

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

1462+

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

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

1465+

1466+instance Issuable 'SchemaLevel where

1467+ data Issue 'SchemaLevel

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

1469+ NotSupported Text

1470+ | -- | The schema is actually invalid

1471+ InvalidSchema Text

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

1473+ UnguardedRecursion

1474+ | -- | Producer doesn't place any restrictions on the types, but the consumer does. List what types remain available in the consumer.

1475+ TypesRestricted [JsonType]

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

1477+ AdditionalToProperty

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

1479+ PropertyToAdditional

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

1481+ PropertyNowRequired

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

1483+ UnexpectedProperty

1484+ deriving stock (Eq, Ord, Show)

1485+ issueIsUnsupported = \case

1486+ NotSupported _ -> True

1487+ InvalidSchema _ -> True

1488+ UnguardedRecursion -> True

1489+ _ -> False

1490+

1491+ describeIssue _ (NotSupported i) =

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

1493+ describeIssue _ (InvalidSchema i) =

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

1495+ describeIssue _ UnguardedRecursion =

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

1497+ describeIssue Forward (TypesRestricted tys) = case tys of

1498+ [] -> para "No longer has any valid values." -- weird

1499+ _ -> para "Values are now limited to the following types: " <> bulletList (para . describeJSONType <$> tys)

1500+ describeIssue Backward (TypesRestricted tys) = case tys of

1501+ [] -> para "Any value of any type is now allowed." -- weird

1502+ _ -> para "Values are no longer limited to the following types: " <> bulletList (para . describeJSONType <$> tys)

1503+ describeIssue Forward AdditionalToProperty = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."

1504+ describeIssue Backward AdditionalToProperty = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."

1505+ describeIssue Forward PropertyToAdditional = para "The property was previously explicitly defined. It is now implicitly described by the catch-all \"additional properties\" case."

1506+ describeIssue Backward PropertyToAdditional = para "The property was previously implicitly described by the catch-all \"additional properties\" case. It is now explicitly defined."

1507+ describeIssue Forward PropertyNowRequired = para "The property has become required."

1508+ describeIssue Backward PropertyNowRequired = para "The property may not be present."

1509+ describeIssue Forward UnexpectedProperty = para "The property has been removed."

1510+ describeIssue Backward UnexpectedProperty = para "The property has been added."

1511+

1512+instance Behavable 'SchemaLevel 'TypedSchemaLevel where

1513+ data Behave 'SchemaLevel 'TypedSchemaLevel

1514+ = OfType JsonType

1515+ deriving stock (Eq, Ord, Show)

1516+

1517+ describeBehaviour (OfType t) = describeJSONType t

1518+

1519+describeJSONType :: IsString s => JsonType -> s

1520+describeJSONType = \case

1521+ Null -> "Null"

1522+ Boolean -> "Boolean"

1523+ Number -> "Number"

1524+ String -> "String"

1525+ Array -> "Array"

1526+ Object -> "Object"

1527+

1528+instance Behavable 'TypedSchemaLevel 'TypedSchemaLevel where

1529+ data Behave 'TypedSchemaLevel 'TypedSchemaLevel

1530+ = InPartition (PartitionLocation, PartitionChoice)

1531+ deriving stock (Eq, Ord, Show)

1532+

1533+ describeBehaviour (InPartition partition) = showPartition partition

1534+

1535+showPartition :: (PartitionLocation, PartitionChoice) -> Inlines

1536+showPartition = \case

1537+ (partition, CByEnumValue (S.toList -> [v])) ->

1538+ "In cases where " <> renderPartitionLocation partition <> " is " <> showJSONValueInline v

1539+ (partition, CByEnumValue (S.toList -> vs)) ->

1540+ "In cases where " <> renderPartitionLocation partition <> " has values: "

1541+ <> (fold . L.intersperse ", " . fmap showJSONValueInline $ vs)

1542+ (partition, CByProperties (S.toList -> incl) (S.toList -> [])) ->

1543+ "In cases where " <> renderPartitionLocation partition <> " contains the properties: " <> listCodes incl

1544+ (partition, CByProperties (S.toList -> []) (S.toList -> excl)) ->

1545+ "In cases where " <> renderPartitionLocation partition <> " does not contain the properties: " <> listCodes excl

1546+ (partition, CByProperties (S.toList -> incl) (S.toList -> excl)) ->

1547+ "In cases where " <> renderPartitionLocation partition

1548+ <> " contains the properties "

1549+ <> listCodes incl

1550+ <> " and does not contain the properties "

1551+ <> listCodes excl

1552+ where

1553+ listCodes :: [Text] -> Inlines

1554+ listCodes = fold . L.intersperse ", " . fmap code

1555+ renderPartitionLocation :: PartitionLocation -> Inlines

1556+ renderPartitionLocation p = code $ "$" <> renderPartitionLocation' p

1557+ where

1558+ renderPartitionLocation' :: PartitionLocation -> Text

1559+ renderPartitionLocation' PHere = mempty

1560+ renderPartitionLocation' (PInProperty prop rest) = "." <> prop <> renderPartitionLocation' rest

1561+

1562+instance Behavable 'TypedSchemaLevel 'SchemaLevel where

1563+ data Behave 'TypedSchemaLevel 'SchemaLevel

1564+ = InItems

1565+ | InProperty Text

1566+ | InAdditionalProperty

1567+ deriving stock (Eq, Ord, Show)

1568+

1569+ describeBehaviour InItems = "Items"

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

1571+ describeBehaviour InAdditionalProperty = "Additional properties"

1572+

1573+instance Subtree Schema where

1574+ type SubtreeLevel Schema = 'SchemaLevel

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

1576+ checkStructuralCompatibility env pc = do

1577+ structuralEq $ fmap _schemaRequired <$> pc

1578+ structuralEq $ fmap _schemaNullable <$> pc

1579+ structuralMaybeWith (structuralList env) $ tracedAllOf <$> pc

1580+ structuralMaybeWith (structuralList env) $ tracedOneOf <$> pc

1581+ structuralMaybe env $ sequence . stepTraced NotStep . fmap _schemaNot <$> pc

1582+ structuralMaybeWith (structuralList env) $ tracedAnyOf <$> pc

1583+ iohmStructural env $ stepTraced PropertiesStep . fmap _schemaProperties <$> pc

1584+ structuralMaybeWith structuralAdditionalProperties $ tracedAdditionalProperties <$> pc

1585+ structuralMaybeWith structuralDiscriminator $ tracedDiscriminator <$> pc

1586+ structuralEq $ fmap _schemaReadOnly <$> pc

1587+ structuralEq $ fmap _schemaWriteOnly <$> pc

1588+ structuralEq $ fmap _schemaXml <$> pc

1589+ structuralEq $ fmap _schemaMaxProperties <$> pc

1590+ structuralEq $ fmap _schemaMinProperties <$> pc

1591+ structuralEq $ fmap _schemaDefault <$> pc

1592+ structuralEq $ fmap _schemaType <$> pc

1593+ structuralEq $ fmap _schemaFormat <$> pc

1594+ structuralMaybeWith structuralItems $ tracedItems <$> pc

1595+ structuralEq $ fmap _schemaMaximum <$> pc

1596+ structuralEq $ fmap _schemaExclusiveMaximum <$> pc

1597+ structuralEq $ fmap _schemaMinimum <$> pc

1598+ structuralEq $ fmap _schemaExclusiveMinimum <$> pc

1599+ structuralEq $ fmap _schemaMaxLength <$> pc

1600+ structuralEq $ fmap _schemaMinLength <$> pc

1601+ structuralEq $ fmap _schemaPattern <$> pc

1602+ structuralEq $ fmap _schemaMaxItems <$> pc

1603+ structuralEq $ fmap _schemaMinItems <$> pc

1604+ structuralEq $ fmap _schemaUniqueItems <$> pc

1605+ structuralEq $ fmap _schemaEnum <$> pc

1606+ structuralEq $ fmap _schemaMultipleOf <$> pc

1607+ pure ()

1608+ where

1609+ structuralAdditionalProperties

1610+ (ProdCons (Left x) (Left y)) = unless (x == y) structuralIssue

1611+ structuralAdditionalProperties

1612+ (ProdCons (Right x) (Right y)) =

1613+ checkSubstructure env $ ProdCons x y

1614+ structuralAdditionalProperties _ = structuralIssue

1615+ structuralDiscriminator pc' = do

1616+ structuralEq $ fmap _discriminatorPropertyName <$> pc'

1617+ iohmStructural env $

1618+ stepTraced DiscriminatorMapping . fmap (fmap parseDiscriminatorValue . _discriminatorMapping) <$> pc'

1619+ pure ()

1620+ structuralItems (ProdCons (Left a) (Left b)) =

1621+ checkSubstructure env $ ProdCons a b

1622+ structuralItems (ProdCons (Right a) (Right b)) =

1623+ structuralList env $ ProdCons a b

1624+ structuralItems _ = structuralIssue

1625+ checkSemanticCompatibility env beh schs = do

1626+ let defs = getH env

1627+ checkFormulas env beh defs $ schemaToFormula <$> defs <*> schs

src/Data/OpenApi/Compare/Validate/SecurityRequirement.hs → src/OpenAPI/Checker/Validate/SecurityRequirement.hsrenamed+13−14

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

11{-# LANGUAGE PartialTypeSignatures #-}

22{-# OPTIONS_GHC -Wno-orphans #-}

33

4−module Data.OpenApi.Compare.Validate.SecurityRequirement

5− ( Issue (..),

4+module OpenAPI.Checker.Validate.SecurityRequirement

5+ ( Issue (..)

66 )

77where

88

@@ -17,14 +17,14 @@ import Data.HList

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

1818import qualified Data.List.NonEmpty as NE

1919import Data.OpenApi

20−import Data.OpenApi.Compare.Behavior

21−import Data.OpenApi.Compare.Subtree

22−import Data.OpenApi.Compare.Validate.OAuth2Flows

23−import Data.OpenApi.Compare.Validate.SecurityScheme ()

2420import Data.Set (Set)

2521import qualified Data.Set as S

2622import Data.Text (Text)

2723import Data.Traversable

24+import OpenAPI.Checker.Behavior

25+import OpenAPI.Checker.Subtree

26+import OpenAPI.Checker.Validate.OAuth2Flows

27+import OpenAPI.Checker.Validate.SecurityScheme ()

2828

2929instance Subtree SecurityRequirement where

3030 type SubtreeLevel SecurityRequirement = 'SecurityRequirementLevel

@@ -41,19 +41,18 @@ instance Subtree SecurityRequirement where

4141 for (IOHM.toList $ getSecurityRequirement sec) $ \(key, scopes) ->

4242 (,scopes) <$> lookupScheme key defs

4343 structuralMaybeWith

44− ( \pc' -> do

45− let ProdCons pScopes cScopes = fmap snd <$> pc'

46− unless (pScopes == cScopes) structuralIssue

47− structuralList env $ fmap fst <$> pc'

48− pure ()

49− )

44+ (\pc' -> do

45+ let ProdCons pScopes cScopes = fmap snd <$> pc'

46+ unless (pScopes == cScopes) structuralIssue

47+ structuralList env $ fmap fst <$> pc'

48+ pure ())

5049 normalized

5150 pure ()

5251 checkSemanticCompatibility env bhv' pc = do

5352 let schemes = getH @(ProdCons (Traced (Definitions SecurityScheme))) env

5453 ( ProdCons pErrs cErrs

55− , (ProdCons pSchemes cSchemes) ::

56− ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]

54+ , (ProdCons pSchemes cSchemes)

55+ :: ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]

5756 ) =

5857 NE.unzip $

5958 partitionEithers <$> do

src/Data/OpenApi/Compare/Validate/SecurityScheme.hs → src/OpenAPI/Checker/Validate/SecurityScheme.hsrenamed+5−5

@@ -1,16 +1,16 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

22

3−module Data.OpenApi.Compare.Validate.SecurityScheme

3+module OpenAPI.Checker.Validate.SecurityScheme

44 (

55 )

66where

77

88import Control.Monad

99import Data.OpenApi

10−import Data.OpenApi.Compare.Behavior

11−import Data.OpenApi.Compare.Orphans ()

12−import Data.OpenApi.Compare.Subtree

13−import Data.OpenApi.Compare.Validate.OAuth2Flows

10+import OpenAPI.Checker.Behavior

11+import OpenAPI.Checker.Orphans ()

12+import OpenAPI.Checker.Subtree

13+import OpenAPI.Checker.Validate.OAuth2Flows

1414

1515instance Subtree SecurityScheme where

1616 type CheckEnv SecurityScheme = '[]

src/Data/OpenApi/Compare/Validate/Server.hs → src/OpenAPI/Checker/Validate/Server.hsrenamed+18−21

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

3−module Data.OpenApi.Compare.Validate.Server

4− ( Issue (..),

3+module OpenAPI.Checker.Validate.Server

4+ ( Issue (..)

55 )

66where

77

@@ -19,21 +19,21 @@ import qualified Data.HashSet.InsOrd as IOHM

1919import qualified Data.HashSet.InsOrd as IOHS

2020import Data.Maybe

2121import Data.OpenApi

22−import Data.OpenApi.Compare.Behavior

23−import Data.OpenApi.Compare.Common

24−import Data.OpenApi.Compare.Paths

25−import Data.OpenApi.Compare.Subtree

26−import Data.OpenApi.Compare.Validate.MediaTypeObject

2722import qualified Data.Set as S

2823import Data.Text (Text)

2924import qualified Data.Text as T

3025import Data.Traversable

26+import OpenAPI.Checker.Behavior

27+import OpenAPI.Checker.Common

28+import OpenAPI.Checker.Paths

29+import OpenAPI.Checker.Subtree

30+import OpenAPI.Checker.Validate.MediaTypeObject

3131import Text.Pandoc.Builder

3232import Prelude as P

3333

34−tracedParsedServerUrlParts ::

35− Server ->

36− Either (Issue 'ServerLevel) ProcessedServer

34+tracedParsedServerUrlParts

35+ :: Server

36+ -> Either (Issue 'ServerLevel) ProcessedServer

3737tracedParsedServerUrlParts s =

3838 let parsedUrl = parseServerUrl $ _serverUrl s

3939 lookupVar var = case IOHM.lookup var (_serverVariables s) of

@@ -46,7 +46,7 @@ instance Behavable 'OperationLevel 'ServerLevel where

4646 = InServer Text

4747 deriving stock (Eq, Ord, Show)

4848

49− describeBehavior (InServer n) = "Server " <> code n

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

5050

5151instance Subtree [Server] where

5252 type SubtreeLevel [Server] = 'OperationLevel

@@ -63,12 +63,11 @@ instance Subtree [Server] where

6363 pcServer

6464 <&> partitionEithers

6565 . fmap

66− ( \(Traced t s) ->

67− let bhv = beh >>> step (InServer $ _serverUrl s)

68− in case tracedParsedServerUrlParts s of

69− Left e -> Left $ issueAt bhv e

70− Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u)

71− )

66+ (\(Traced t s) ->

67+ let bhv = beh >>> step (InServer $ _serverUrl s)

68+ in case tracedParsedServerUrlParts s of

69+ Left e -> Left $ issueAt bhv e

70+ Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u))

7271 . sequence

7372 sequenceA_ pErrs

7473 sequenceA_ cErrs

@@ -102,7 +101,7 @@ data ServerUrlPart var

102101 deriving stock (Eq, Show, Functor, Foldable, Traversable)

103102

104103-- | This is super rough. Things like @{a|b}c@ will not match @ac@.

105−-- FIXME: #46

104+-- FIXME: https://github.com/typeable/openapi-diff/issues/46

106105--

107106-- NOTE: syntax is defined vaguely in the spec.

108107parseServerUrl :: Text -> [ServerUrlPart Text]

@@ -134,9 +133,7 @@ instance Issuable 'ServerLevel where

134133 | ServerVariableNotDefined Text

135134 | ServerNotMatched

136135 deriving stock (Eq, Ord, Show)

137− issueKind = \case

138− ServerVariableNotDefined _ -> SchemaInvalid

139− _ -> CertainIssue

136+ issueIsUnsupported _ = False

140137 describeIssue Forward (EnumValueNotConsumed _ v) =

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

142139 describeIssue Backward (EnumValueNotConsumed _ v) =

src/OpenAPI/Checker/Validate/Sums.hsnew file+24

@@ -0,0 +1,24 @@

1+module OpenAPI.Checker.Validate.Sums

2+ ( checkSums

3+ ) where

4+

5+import Data.Foldable

6+import Data.Map.Strict (Map)

7+import qualified Data.Map.Strict as M

8+import OpenAPI.Checker.Behavior

9+import OpenAPI.Checker.Subtree

10+import OpenAPI.Checker.Paths

11+

12+checkSums

13+ :: (Ord k, Issuable l)

14+ => Paths q r l

15+ -> (k -> Issue l)

16+ -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())

17+ -> ProdCons (Map k t)

18+ -> CompatFormula' q AnIssue r ()

19+checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

20+ case M.lookup key c of

21+ Nothing -> issueAt xs $ noElt key

22+ Just consElt ->

23+ let sumElts = ProdCons prodElt consElt

24+ in check key sumElts

stack.yaml+4−7

@@ -1,11 +1,8 @@

1−resolver: lts-18.16

2−

3−packages:

4− - .

1+resolver: lts-18.2

52

63extra-deps:

74 - open-union-0.4.0.0

85 - type-fun-0.1.3

9− - github-0.26

10− - base16-bytestring-0.1.1.7

11− - http-link-header-1.0.3.1

6+

7+apply-ghc-options: everything

8+rebuild-ghc-options: true

stack.yaml.lock+4−25

@@ -18,30 +18,9 @@ packages:

1818 sha256: b977d42525f0b4223959918d18e7905085283e937493c395077b608cd19b42c1

1919 original:

2020 hackage: type-fun-0.1.3

21−- completed:

22− hackage: github-0.26@sha256:a9d4046325c3eb28cdc7bef2c3f5bb213328caeae0b7dce6f51de655f0bffaa1,7162

23− pantry-tree:

24− size: 7511

25− sha256: b71aab2984b268030c9e2617043575681134c1fe60dffbd5596e659c0a3e9aec

26− original:

27− hackage: github-0.26

28−- completed:

29− hackage: base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231

30− pantry-tree:

31− size: 454

32− sha256: 2dc99cd67293b09204098202d0bdcdcf89d2b8c69ce6c8f4e31deadbdab2a7f9

33− original:

34− hackage: base16-bytestring-0.1.1.7

35−- completed:

36− hackage: http-link-header-1.0.3.1@sha256:9917c26635a46eff5d36c5344a4ae42fad2b5de79c0e300363bddd5eec66facd,1937

37− pantry-tree:

38− size: 990

39− sha256: 155feaf856daf5b55491048c8c4726ba765a8fe79263ebdbfc82f6c385a15715

40− original:

41− hackage: http-link-header-1.0.3.1

4221snapshots:

4322- completed:

44− size: 586286

45− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml

46− sha256: cdead65fca0323144b346c94286186f4969bf85594d649c49c7557295675d8a5

47− original: lts-18.16

23+ size: 585392

24+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/2.yaml

25+ sha256: 7abb45c0cc5eb349448b66d8753655542d45d387ad26970419282eab3d860724

26+ original: lts-18.2

test/README.md+1−1

@@ -30,7 +30,7 @@ This test would read the files `a.yaml` and `b.yaml` using the `Yaml.decodeFileT

3030

3131## Supported feature tests

3232

33−If a test starts with either `x ` or `v `, the test is assumed to test the support of some OpenAPI functionality. If the test begins `x ` it means that the feature is expected to be not supported, and the result will only be checked to have an "unsupported" flag set. If it starts with `v ` the test is expected to be supported and the result is compared to some file on disk.

33+If a test starts with either `x ` or `v `, the test is assumed to test the support of some OpenApi functionality. If the test begins `x ` it means that the feature is expected to be not supported, and the result will only be checked to have an "unsupported" flag set. If it starts with `v ` the test is expected to be supported and the result is compared to some file on disk.

3434

3535The result will be reflected in the generated compatibility matrix.

3636

test/Spec/Golden/Extra.hs+42−46

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

11module Spec.Golden.Extra

2− ( getGoldenInputs,

3− getGoldenInputsUniform,

4− goldenInputsTree,

5− goldenInputsTreeUniform,

2+ ( getGoldenInputs

3+ , getGoldenInputsUniform

4+ , goldenInputsTree

5+ , goldenInputsTreeUniform

66 )

77where

88

@@ -19,12 +19,12 @@ data TestInput t

1919 | TestInputLeaf TestName t FilePath

2020 deriving stock (Functor)

2121

22−getGoldenInputs ::

23− (Each s t (FilePath, FilePath -> IO a) a) =>

24− TestName ->

25− FilePath ->

26− s ->

27− IO (TestInput t)

22+getGoldenInputs

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

24+ => TestName

25+ -> FilePath

26+ -> s

27+ -> IO (TestInput t)

2828getGoldenInputs name filepath inp = do

2929 dirs' <- listDirectory filepath >>= filterM (doesDirectoryExist . (filepath </>))

3030 case dirs' of

@@ -39,34 +39,32 @@ getGoldenInputs name filepath inp = do

3939 TestInputNode name

4040 <$> forM dirs (\dir -> getGoldenInputs dir (filepath </> dir) inp)

4141

42−getGoldenInputsUniform ::

43− (Each t h (FilePath, FilePath -> IO a) a) =>

44− (Each s t FilePath (FilePath, FilePath -> IO a)) =>

45− TestName ->

46− (FilePath -> IO a) ->

47− FilePath ->

48− s ->

49− IO (TestInput h)

42+getGoldenInputsUniform

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

44+ => (Each s t FilePath (FilePath, FilePath -> IO a))

45+ => TestName

46+ -> (FilePath -> IO a)

47+ -> FilePath

48+ -> s

49+ -> IO (TestInput h)

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

5151

52−goldenInputsTree ::

53− (Each s t (FilePath, FilePath -> IO a) a) =>

54− TestName ->

55− -- | Root path

56− FilePath ->

57− -- | Name of golden file

58− FilePath ->

59− s ->

60− (t -> IO BSL.ByteString) ->

61− IO TestTree

52+goldenInputsTree

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

54+ => TestName

55+ -> FilePath -- ^ Root path

56+ -> FilePath -- ^ Name of golden file

57+ -> s

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

59+ -> IO TestTree

6260goldenInputsTree name filepath golden inp f = do

6361 runTestInputTree golden f <$> getGoldenInputs name filepath inp

6462

65−runTestInputTree ::

66− FilePath ->

67− (t -> IO BSL.ByteString) ->

68− TestInput t ->

69− TestTree

63+runTestInputTree

64+ :: FilePath

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

66+ -> TestInput t

67+ -> TestTree

7068runTestInputTree golden f (TestInputNode name rest) =

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

7270runTestInputTree golden f (TestInputLeaf name t path) =

@@ -76,18 +74,16 @@ runTestInputTree golden f (TestInputLeaf name t path) =

7674 (path </> golden)

7775 (f t)

7876

79−goldenInputsTreeUniform ::

80− ( Each t h (FilePath, FilePath -> IO a) a

81− , Each s t FilePath (FilePath, FilePath -> IO a)

82− ) =>

83− String ->

84− -- | Root path

85− FilePath ->

86− -- | Name of golden file

87− FilePath ->

88− s ->

89− (FilePath -> IO a) ->

90− (h -> IO BSL.ByteString) ->

91− IO TestTree

77+goldenInputsTreeUniform

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

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

80+ )

81+ => String

82+ -> FilePath -- ^ Root path

83+ -> FilePath -- ^ Name of golden file

84+ -> s

85+ -> (FilePath -> IO a)

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

87+ -> IO TestTree

9288goldenInputsTreeUniform name filepath golden inp h =

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

test/Spec/Golden/TraceTree.hs+6−9

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

11module Spec.Golden.TraceTree

2− ( tests,

2+ ( tests

33 )

44where

55

@@ -7,15 +7,13 @@ import Control.Category

77import Control.Exception

88import qualified Data.ByteString.Lazy as BSL

99import Data.Default

10−import Data.OpenApi.Compare.Run

11−import Data.OpenApi.Compare.Validate.OpenApi ()

1210import Data.Text (Text)

1311import qualified Data.Text.Encoding as T

1412import qualified Data.Yaml as Yaml

15−import Paths_compaREST

13+import OpenAPI.Checker.Run

14+import OpenAPI.Checker.Validate.OpenApi ()

1615import Spec.Golden.Extra

1716import Test.Tasty (TestTree, testGroup)

18−import Text.Pandoc.Builder

1917import Text.Pandoc.Class

2018import Text.Pandoc.Options

2119import Text.Pandoc.Writers

@@ -23,11 +21,10 @@ import Prelude hiding (id, (.))

2321

2422tests :: IO TestTree

2523tests = do

26− dir <- getDataDir

2724 traceTreeTests <-

2825 goldenInputsTreeUniform

2926 "TraceTree"

30− dir

27+ "test/golden/common"

3128 "trace-tree.yaml"

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

3330 Yaml.decodeFileThrow

@@ -36,11 +33,11 @@ tests = do

3633 reportTests <-

3734 goldenInputsTreeUniform

3835 "Report"

39− dir

36+ "test/golden/common"

4037 "report.md"

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

4239 Yaml.decodeFileThrow

43− (runPandoc . writeMarkdown def {writerExtensions = githubMarkdownExtensions} . doc . fst . runReport def)

40+ (runPandoc . writeMarkdown def {writerExtensions = githubMarkdownExtensions} . fst . runReport def)

4441

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

4643

test/golden/common/bad-oneof-unchanged/a.yamldeleted−39

@@ -1,39 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22−components:

23− schemas:

24− Test:

25− oneOf:

26− - type: object

27− required: ["tag", "prop_A"]

28− properties:

29− tag:

30− enum: ["A"]

31− prop_A:

32− type: string

33− - type: object

34− required: ["tag", "prop_B"]

35− properties:

36− tag:

37− enum: ["A"]

38− prop_B:

39− type: number

test/golden/common/bad-oneof-unchanged/b.yamldeleted−39

@@ -1,39 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22−components:

23− schemas:

24− Test:

25− oneOf:

26− - type: object

27− required: ["tag", "prop_B"]

28− properties:

29− tag:

30− enum: ["A"]

31− prop_B:

32− type: number

33− - type: object

34− required: ["tag", "prop_A"]

35− properties:

36− tag:

37− enum: ["A"]

38− prop_A:

39− type: string

test/golden/common/bad-oneof-unchanged/report.mddeleted−19

@@ -1,19 +0,0 @@

1−# Summary

2−

3−| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |

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

5−| 0 | 0 | 2 |

6−

7−# ❓ Unsupported feature changes

8−

9−## **POST** /test

10−

11−### ➡️☁️ JSON Request

12−

13−Could not deduce that `oneOf` cases don't overlap. Treating the `oneOf`

14−as an `anyOf`. Reported errors might not be accurate.

15−

16−### ⬅️☁️ JSON Response – 200

17−

18−Could not deduce that `oneOf` cases don't overlap. Treating the `oneOf`

19−as an `anyOf`. Reported errors might not be accurate.

test/golden/common/bad-oneof-unchanged/trace-tree.yamldeleted−18

@@ -1,18 +0,0 @@

1−forwardChanges:

2− AtPath "/test":

3− InOperation PostMethod:

4− InRequest:

5− InPayload:

6− PayloadSchema: OneOfNotDisjoint

7− WithStatusCode 200:

8− ResponsePayload:

9− PayloadSchema: OneOfNotDisjoint

10−backwardChanges:

11− AtPath "/test":

12− InOperation PostMethod:

13− InRequest:

14− InPayload:

15− PayloadSchema: OneOfNotDisjoint

16− WithStatusCode 200:

17− ResponsePayload:

18− PayloadSchema: OneOfNotDisjoint

test/golden/common/enum-added/report.md+7−7

@@ -1,14 +1,14 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 1 | 1 |

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

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

5+| 1 | 1 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

11−### ⬅️☁️ JSON Response – 200

11+### 📱⬅️ JSON Response – 200

1212

1313#### `$(String)`

1414

@@ -18,11 +18,11 @@ The following enum value was added:

1818"C"

1919```

2020

21−# ⚠️ Non-breaking changes

21+# 🙆 Non-breaking changes

2222

2323## **POST** /test

2424

25−### ➡️☁️ JSON Request

25+### 📱➡️ JSON Request

2626

2727#### `$(String)`

2828

test/golden/common/enum-added/trace-tree.yaml+2−2

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 WithStatusCode 200:

55 ResponsePayload:

66 PayloadSchema:

77 OfType String: EnumDoesntSatisfy (String "C")

8−backwardChanges:

8+nonBreakingChanges:

99 AtPath "/test":

1010 InOperation PostMethod:

1111 InRequest:

test/golden/common/enum-anyof/report.md+3−3

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

11# Summary

22

3−| ❌ Breaking changes | ⚠️ Non-breaking changes |

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

5−| 0 | 0 |

3+| ⚠️ Breaking changes | 🙆 Non-breaking changes | 🤷 Unsupported feature changes |

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

5+| 0 | 0 | 0 |

test/golden/common/enum-anyof/trace-tree.yaml+2−2

@@ -1,2 +1,2 @@

1−forwardChanges: {}

2−backwardChanges: {}

1+breakingChanges: {}

2+nonBreakingChanges: {}

test/golden/common/id/report.md+3−3

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

11# Summary

22

3−| ❌ Breaking changes | ⚠️ Non-breaking changes |

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

5−| 0 | 0 |

3+| ⚠️ Breaking changes | 🙆 Non-breaking changes | 🤷 Unsupported feature changes |

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

5+| 0 | 0 | 0 |

test/golden/common/id/trace-tree.yaml+2−2

@@ -1,2 +1,2 @@

1−forwardChanges: {}

2−backwardChanges: {}

1+breakingChanges: {}

2+nonBreakingChanges: {}

test/golden/common/json/recursive/report.md+3−3

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

11# Summary

22

3−| ❌ Breaking changes | ⚠️ Non-breaking changes |

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

5−| 0 | 0 |

3+| ⚠️ Breaking changes | 🙆 Non-breaking changes | 🤷 Unsupported feature changes |

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

5+| 0 | 0 | 0 |

test/golden/common/json/recursive/trace-tree.yaml+2−2

@@ -1,2 +1,2 @@

1−forwardChanges: {}

2−backwardChanges: {}

1+breakingChanges: {}

2+nonBreakingChanges: {}

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

@@ -1,24 +1,24 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 1 | 1 |

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

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

5+| 1 | 1 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

11−### ➡️☁️ JSON Request

11+### 📱➡️ JSON Request

1212

1313#### `$(Number)`

1414

1515Upper bound changed from 3.0 inclusive to 2.0 inclusive.

1616

17−# ⚠️ Non-breaking changes

17+# 🙆 Non-breaking changes

1818

1919## **POST** /test

2020

21−### ⬅️☁️ JSON Response – 200

21+### 📱⬅️ JSON Response – 200

2222

2323#### `$(Number)`

2424

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 InRequest:

@@ -6,7 +6,7 @@ forwardChanges:

66 PayloadSchema:

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

88 consumer = Inclusive 2.0})

9−backwardChanges:

9+nonBreakingChanges:

1010 AtPath "/test":

1111 InOperation PostMethod:

1212 WithStatusCode 200:

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

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

5−| 1 | 0 |

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

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

5+| 1 | 0 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 InParam "test1": ParamEmptinessIncompatible

5−backwardChanges: {}

5+nonBreakingChanges: {}

test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/report.md+4−4

@@ -1,10 +1,10 @@

11# Summary

22

3−| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 0 | 1 |

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

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

5+| 0 | 1 | 0 |

66

7−# ⚠️ Non-breaking changes

7+# 🙆 Non-breaking changes

88

99## **POST** /test

1010

test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/trace-tree.yaml+2−2

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

1−forwardChanges: {}

2−backwardChanges:

1+breakingChanges: {}

2+nonBreakingChanges:

33 AtPath "/test":

44 InOperation PostMethod:

55 InParam "test1": ParamEmptinessIncompatible

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 1 | 1 |

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

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

5+| 1 | 1 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

@@ -14,9 +14,9 @@

1414

1515##### `$(String)`

1616

17−The type has been removed.

17+The value has been removed.

1818

19−# ⚠️ Non-breaking changes

19+# 🙆 Non-breaking changes

2020

2121## **POST** /test

2222

@@ -26,4 +26,4 @@ The type has been removed.

2626

2727##### `$(Number)`

2828

29−The type has been added.

29+The value has been added.

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

@@ -1,12 +1,12 @@

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 InParam "test":

55 InParamSchema:

6− OfType String: TypeBecomesEmpty

7−backwardChanges:

6+ OfType String: NoContradiction

7+nonBreakingChanges:

88 AtPath "/test":

99 InOperation PostMethod:

1010 InParam "test":

1111 InParamSchema:

12− OfType Number: TypeBecomesEmpty

12+ OfType Number: NoContradiction

test/golden/common/pathItem/operation/parameters/required/false/add/report.md+3−3

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

11# Summary

22

3−| ❌ Breaking changes | ⚠️ Non-breaking changes |

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

5−| 0 | 0 |

3+| ⚠️ Breaking changes | 🙆 Non-breaking changes | 🤷 Unsupported feature changes |

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

5+| 0 | 0 | 0 |

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

@@ -1,2 +1,2 @@

1−forwardChanges: {}

2−backwardChanges: {}

1+breakingChanges: {}

2+nonBreakingChanges: {}

test/golden/common/pathItem/operation/parameters/required/false/del/report.md+3−3

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

11# Summary

22

3−| ❌ Breaking changes | ⚠️ Non-breaking changes |

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

5−| 0 | 0 |

3+| ⚠️ Breaking changes | 🙆 Non-breaking changes | 🤷 Unsupported feature changes |

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

5+| 0 | 0 | 0 |

test/golden/common/pathItem/operation/parameters/required/false/del/trace-tree.yaml+2−2

@@ -1,2 +1,2 @@

1−forwardChanges: {}

2−backwardChanges: {}

1+breakingChanges: {}

2+nonBreakingChanges: {}

test/golden/common/pathItem/operation/parameters/required/reset/report.md+4−4

@@ -1,10 +1,10 @@

11# Summary

22

3−| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 0 | 1 |

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

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

5+| 0 | 1 | 0 |

66

7−# ⚠️ Non-breaking changes

7+# 🙆 Non-breaking changes

88

99## **POST** /test

1010

test/golden/common/pathItem/operation/parameters/required/reset/trace-tree.yaml+2−2

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

1−forwardChanges: {}

2−backwardChanges:

1+breakingChanges: {}

2+nonBreakingChanges:

33 AtPath "/test":

44 InOperation PostMethod:

55 InParam "test1": ParamRequired

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

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

5−| 1 | 0 |

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

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

5+| 1 | 0 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 InParam "test1": ParamRequired

5−backwardChanges: {}

5+nonBreakingChanges: {}

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

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

5−| 1 | 0 |

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

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

5+| 1 | 0 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod: ParamNotMatched "test2"

4−backwardChanges: {}

4+nonBreakingChanges: {}

test/golden/common/pathItem/operation/parameters/required/true/del/report.md+4−4

@@ -1,10 +1,10 @@

11# Summary

22

3−| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 0 | 1 |

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

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

5+| 0 | 1 | 0 |

66

7−# ⚠️ Non-breaking changes

7+# 🙆 Non-breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges: {}

2−backwardChanges:

1+breakingChanges: {}

2+nonBreakingChanges:

33 AtPath "/test":

44 InOperation PostMethod: ParamNotMatched "test2"

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 0 | 1 |

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

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

5+| 0 | 1 | 0 |

66

7−# ⚠️ Non-breaking changes

7+# 🙆 Non-breaking changes

88

99## **POST** /test

1010

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/trace-tree.yaml+2−2

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

1−forwardChanges: {}

2−backwardChanges:

1+breakingChanges: {}

2+nonBreakingChanges:

33 AtPath "/test":

44 InOperation PostMethod:

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

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

@@ -1,25 +1,25 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 1 | 1 |

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

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

5+| 1 | 1 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

11−### ➡️☁️ JSON Request

11+### 📱➡️ JSON Request

1212

1313#### `$(String)`

1414

15−The type has been removed.

15+The value has been removed.

1616

17−# ⚠️ Non-breaking changes

17+# 🙆 Non-breaking changes

1818

1919## **POST** /test

2020

21−### ➡️☁️ JSON Request

21+### 📱➡️ JSON Request

2222

2323#### `$(Number)`

2424

25−The type has been added.

25+The value has been added.

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

@@ -1,14 +1,14 @@

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 InRequest:

55 InPayload:

66 PayloadSchema:

7− OfType String: TypeBecomesEmpty

8−backwardChanges:

7+ OfType String: NoContradiction

8+nonBreakingChanges:

99 AtPath "/test":

1010 InOperation PostMethod:

1111 InRequest:

1212 InPayload:

1313 PayloadSchema:

14− OfType Number: TypeBecomesEmpty

14+ OfType Number: NoContradiction

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

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

5−| 1 | 0 |

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

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

5+| 1 | 0 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

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

5−backwardChanges: {}

5+nonBreakingChanges: {}

test/golden/common/pathItem/operation/requestBody/required/reset/report.md+4−4

@@ -1,10 +1,10 @@

11# Summary

22

3−| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 0 | 1 |

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

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

5+| 0 | 1 | 0 |

66

7−# ⚠️ Non-breaking changes

7+# 🙆 Non-breaking changes

88

99## **POST** /test

1010

test/golden/common/pathItem/operation/requestBody/required/reset/trace-tree.yaml+2−2

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

1−forwardChanges: {}

2−backwardChanges:

1+breakingChanges: {}

2+nonBreakingChanges:

33 AtPath "/test":

44 InOperation PostMethod:

55 InRequest: RequestBodyRequired

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

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

5−| 1 | 0 |

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

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

5+| 1 | 0 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 InRequest: RequestBodyRequired

5−backwardChanges: {}

5+nonBreakingChanges: {}

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

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

5−| 1 | 0 |

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

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

5+| 1 | 0 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod: ConsumerDoesntHaveResponseCode 500

4−backwardChanges: {}

4+nonBreakingChanges: {}

test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/report.md+4−4

@@ -1,10 +1,10 @@

11# Summary

22

3−| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 0 | 1 |

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

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

5+| 0 | 1 | 0 |

66

7−# ⚠️ Non-breaking changes

7+# 🙆 Non-breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges: {}

2−backwardChanges:

1+breakingChanges: {}

2+nonBreakingChanges:

33 AtPath "/test":

44 InOperation PostMethod:

55 WithStatusCode 200: ProducerDoesntHaveResponseHeader "Test2"

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

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

5−| 1 | 0 |

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

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

5+| 1 | 0 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 WithStatusCode 200: ProducerDoesntHaveResponseHeader "Test2"

5−backwardChanges: {}

5+nonBreakingChanges: {}

test/golden/common/pathItem/operation/responses/change/headers/optional/add/report.md+3−3

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

11# Summary

22

3−| ❌ Breaking changes | ⚠️ Non-breaking changes |

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

5−| 0 | 0 |

3+| ⚠️ Breaking changes | 🙆 Non-breaking changes | 🤷 Unsupported feature changes |

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

5+| 0 | 0 | 0 |

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

@@ -1,2 +1,2 @@

1−forwardChanges: {}

2−backwardChanges: {}

1+breakingChanges: {}

2+nonBreakingChanges: {}

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

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

11# Summary

22

3−| ❌ Breaking changes | ⚠️ Non-breaking changes |

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

5−| 0 | 0 |

3+| ⚠️ Breaking changes | 🙆 Non-breaking changes | 🤷 Unsupported feature changes |

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

5+| 0 | 0 | 0 |

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

@@ -1,2 +1,2 @@

1−forwardChanges: {}

2−backwardChanges: {}

1+breakingChanges: {}

2+nonBreakingChanges: {}

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

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

5−| 1 | 0 |

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

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

5+| 1 | 0 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 WithStatusCode 200: ConsumerDoesntHaveMediaType application/x-www-form-urlencoded

5−backwardChanges: {}

5+nonBreakingChanges: {}

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

@@ -1,25 +1,25 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 1 | 1 |

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

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

5+| 1 | 1 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

11−### ⬅️☁️ JSON Response – 200

11+### 📱⬅️ JSON Response – 200

1212

1313#### `$(Number)`

1414

15−The type has been added.

15+The value has been added.

1616

17−# ⚠️ Non-breaking changes

17+# 🙆 Non-breaking changes

1818

1919## **POST** /test

2020

21−### ⬅️☁️ JSON Response – 200

21+### 📱⬅️ JSON Response – 200

2222

2323#### `$(String)`

2424

25−The type has been removed.

25+The value has been removed.

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

@@ -1,14 +1,14 @@

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 WithStatusCode 200:

55 ResponsePayload:

66 PayloadSchema:

7− OfType Number: TypeBecomesEmpty

8−backwardChanges:

7+ OfType Number: NoContradiction

8+nonBreakingChanges:

99 AtPath "/test":

1010 InOperation PostMethod:

1111 WithStatusCode 200:

1212 ResponsePayload:

1313 PayloadSchema:

14− OfType String: TypeBecomesEmpty

14+ OfType String: NoContradiction

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 0 | 1 |

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

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

5+| 0 | 1 | 0 |

66

7−# ⚠️ Non-breaking changes

7+# 🙆 Non-breaking changes

88

99## **POST** /test

1010

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

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

1−forwardChanges: {}

2−backwardChanges:

1+breakingChanges: {}

2+nonBreakingChanges:

33 AtPath "/test":

44 InOperation PostMethod:

55 WithStatusCode 200: ConsumerDoesntHaveMediaType application/x-www-form-urlencoded

test/golden/common/pathItem/operation/responses/del/report.md+4−4

@@ -1,10 +1,10 @@

11# Summary

22

3−| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 0 | 1 |

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

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

5+| 0 | 1 | 0 |

66

7−# ⚠️ Non-breaking changes

7+# 🙆 Non-breaking changes

88

99## **POST** /test

1010

test/golden/common/pathItem/operation/responses/del/trace-tree.yaml+2−2

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

1−forwardChanges: {}

2−backwardChanges:

1+breakingChanges: {}

2+nonBreakingChanges:

33 AtPath "/test":

44 InOperation PostMethod: ConsumerDoesntHaveResponseCode 500

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

@@ -1,14 +1,14 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 3 | 3 |

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

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

5+| 3 | 3 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

11−### ⬅️☁️ JSON Response – 200

11+### 📱⬅️ JSON Response – 200

1212

1313#### `$.property2`

1414

@@ -21,11 +21,11 @@

2121

22223. The property may not be present.

2323

24−# ⚠️ Non-breaking changes

24+# 🙆 Non-breaking changes

2525

2626## **POST** /test

2727

28−### ➡️☁️ JSON Request

28+### 📱➡️ JSON Request

2929

3030#### `$.property2`

3131

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 WithStatusCode 200:

@@ -9,7 +9,7 @@ forwardChanges:

99 - TypesRestricted [Number]

1010 - AdditionalToProperty

1111 - PropertyNowRequired

12−backwardChanges:

12+nonBreakingChanges:

1313 AtPath "/test":

1414 InOperation PostMethod:

1515 InRequest:

test/golden/common/property-removed/report.md+22−6

@@ -1,21 +1,37 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

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

5−| 2 | 0 |

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

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

5+| 2 | 2 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

11−### ➡️☁️ JSON Request

11+### 📱➡️ JSON Request

1212

1313#### `$.property2`

1414

1515The property has been removed.

1616

17−### ⬅️☁️ JSON Response – 200

17+### 📱⬅️ JSON Response – 200

1818

1919#### `$.property2`

2020

2121The property may not be present.

22+

23+# 🙆 Non-breaking changes

24+

25+## **POST** /test

26+

27+### 📱➡️ JSON Request

28+

29+#### `$.property2`

30+

31+The property may not be present.

32+

33+### 📱⬅️ JSON Response – 200

34+

35+#### `$.property2`

36+

37+The property has been removed.

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 InRequest:

@@ -11,7 +11,7 @@ forwardChanges:

1111 PayloadSchema:

1212 OfType Object:

1313 InProperty "property2": PropertyNowRequired

14−backwardChanges:

14+nonBreakingChanges:

1515 AtPath "/test":

1616 InOperation PostMethod:

1717 InRequest:

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

@@ -1,24 +1,24 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 1 | 1 |

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

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

5+| 1 | 1 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

11−### ➡️☁️ JSON Request

11+### 📱➡️ JSON Request

1212

1313#### `$.property2`

1414

1515The property has become required.

1616

17−# ⚠️ Non-breaking changes

17+# 🙆 Non-breaking changes

1818

1919## **POST** /test

2020

21−### ⬅️☁️ JSON Response – 200

21+### 📱⬅️ JSON Response – 200

2222

2323#### `$.property2`

2424

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 InRequest:

@@ -6,7 +6,7 @@ forwardChanges:

66 PayloadSchema:

77 OfType Object:

88 InProperty "property2": PropertyNowRequired

9−backwardChanges:

9+nonBreakingChanges:

1010 AtPath "/test":

1111 InOperation PostMethod:

1212 WithStatusCode 200:

test/golden/common/random-example/a.yamldeleted−56

@@ -1,56 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Swagger Petstore

5− license:

6− name: MIT

7−servers:

8− - url: https://example.com

9−paths:

10− /pets:

11− get:

12− parameters:

13− - name: limit

14− in: query

15− required: false

16− schema:

17− type: integer

18− maximum: 20

19− responses:

20− "200":

21− description: ""

22− headers:

23− x-next:

24− schema:

25− type: string

26− content:

27− application/json:

28− schema:

29− $ref: "#/components/schemas/Pets"

30− post:

31− requestBody:

32− content:

33− application/json:

34− schema:

35− $ref: "#/components/schemas/Pet"

36− responses:

37− "201":

38− description: ""

39−components:

40− schemas:

41− Pet:

42− type: object

43− required:

44− - id

45− - name

46− properties:

47− id:

48− type: integer

49− name:

50− type: string

51− minLength: 3

52− maxLength: 10

53− Pets:

54− type: array

55− items:

56− $ref: "#/components/schemas/Pet"

test/golden/common/random-example/b.yamldeleted−58

@@ -1,58 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.1.0

4− title: Swagger Petstore

5− license:

6− name: MIT

7−servers:

8− - url: https://example.com

9−paths:

10− /pets:

11− get:

12− parameters:

13− - name: limit

14− in: query

15− required: false

16− schema:

17− type: integer

18− maximum: 30

19− responses:

20− "200":

21− description: ""

22− headers:

23− x-next:

24− schema:

25− type: string

26− content:

27− application/json:

28− schema:

29− $ref: "#/components/schemas/Pets"

30− post:

31− requestBody:

32− content:

33− application/json:

34− schema:

35− $ref: "#/components/schemas/Pet"

36− responses:

37− "201":

38− description: ""

39−components:

40− schemas:

41− Pet:

42− type: object

43− required:

44− - id

45− - name

46− properties:

47− id:

48− type: integer

49− name:

50− type: string

51− minLength: 1

52− maxLength: 15

53− weight:

54− type: integer

55− Pets:

56− type: array

57− items:

58− $ref: "#/components/schemas/Pet"

test/golden/common/random-example/report.mddeleted−71

@@ -1,71 +0,0 @@

1−# Summary

2−

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 5 | 6 |

6−

7−# ❌ Breaking changes

8−

9−## **GET** /pets

10−

11−### ⬅️☁️ JSON Response – 200

12−

13−#### `$[*].name(String)`

14−

15−1. Maximum length of the string changed from 10 to 15.

16−

17−2. Minimum length of the string changed from 3 to 1.

18−

19−## **POST** /pets

20−

21−### ➡️☁️ JSON Request

22−

23−#### `$.weight`

24−

25−1. Values are now limited to the following types:

26−

27− - Number

28−

29−2. The property was previously implicitly described by the catch-all

30− "additional properties" case. It is now explicitly defined.

31−

32−#### `$.weight(Number)`

33−

34−Value is now a multiple of 1.0.

35−

36−# ⚠️ Non-breaking changes

37−

38−## **GET** /pets

39−

40−### Parameter limit

41−

42−#### JSON Schema

43−

44−##### `$(Number)`

45−

46−Upper bound changed from 20.0 inclusive to 30.0 inclusive.

47−

48−### ⬅️☁️ JSON Response – 200

49−

50−#### `$[*].weight`

51−

52−1. Values are now limited to the following types:

53−

54− - Number

55−

56−2. The property was previously implicitly described by the catch-all

57− "additional properties" case. It is now explicitly defined.

58−

59−#### `$[*].weight(Number)`

60−

61−Value is now a multiple of 1.0.

62−

63−## **POST** /pets

64−

65−### ➡️☁️ JSON Request

66−

67−#### `$.name(String)`

68−

69−1. Maximum length of the string changed from 10 to 15.

70−

71−2. Minimum length of the string changed from 3 to 1.

test/golden/common/random-example/trace-tree.yamldeleted−48

@@ -1,48 +0,0 @@

1−forwardChanges:

2− AtPath "/pets":

3− InOperation GetMethod:

4− WithStatusCode 200:

5− ResponsePayload:

6− PayloadSchema:

7− OfType Array:

8− InItems:

9− OfType Object:

10− InProperty "name":

11− OfType String:

12− - MatchingMaxLengthWeak (ProdCons {producer = 15, consumer = 10})

13− - MatchingMinLengthWeak (ProdCons {producer = 1, consumer = 3})

14− InOperation PostMethod:

15− InRequest:

16− InPayload:

17− PayloadSchema:

18− OfType Object:

19− InProperty "weight":

20− - TypesRestricted [Number]

21− - AdditionalToProperty

22− - OfType Number: NoMatchingMultipleOf 1.0

23−backwardChanges:

24− AtPath "/pets":

25− InOperation GetMethod:

26− WithStatusCode 200:

27− ResponsePayload:

28− PayloadSchema:

29− OfType Array:

30− InItems:

31− OfType Object:

32− InProperty "weight":

33− - TypesRestricted [Number]

34− - AdditionalToProperty

35− - OfType Number: NoMatchingMultipleOf 1.0

36− InParam "limit":

37− InParamSchema:

38− OfType Number: MatchingMaximumWeak (ProdCons {producer = Inclusive 30.0,

39− consumer = Inclusive 20.0})

40− InOperation PostMethod:

41− InRequest:

42− InPayload:

43− PayloadSchema:

44− OfType Object:

45− InProperty "name":

46− OfType String:

47− - MatchingMaxLengthWeak (ProdCons {producer = 15, consumer = 10})

48− - MatchingMinLengthWeak (ProdCons {producer = 1, consumer = 3})

test/golden/common/recursive/report.md+7−7

@@ -1,14 +1,14 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 1 | 1 |

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

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

5+| 1 | 1 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **GET** /api/foo

1010

11−### ➡️☁️ JSON Request

11+### 📱➡️ JSON Request

1212

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

1414

@@ -18,11 +18,11 @@ The following enum value has been added:

1818"a"

1919```

2020

21−# ⚠️ Non-breaking changes

21+# 🙆 Non-breaking changes

2222

2323## **GET** /api/foo

2424

25−### ⬅️☁️ JSON Response – 200

25+### 📱⬅️ JSON Response – 200

2626

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

2828

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/api/foo":

33 InOperation GetMethod:

44 InRequest:

@@ -11,7 +11,7 @@ forwardChanges:

1111 OfType Object:

1212 InProperty "foo":

1313 OfType String: NoMatchingEnum (String "a")

14−backwardChanges:

14+nonBreakingChanges:

1515 AtPath "/api/foo":

1616 InOperation GetMethod:

1717 WithStatusCode 200:

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

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 2 | 1 |

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

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

5+| 2 | 1 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /oauth/check

1010

@@ -22,7 +22,7 @@ Security scheme has been removed.

2222

2323Security scheme has been removed.

2424

25−# ⚠️ Non-breaking changes

25+# 🙆 Non-breaking changes

2626

2727## **POST** /oauth/check

2828

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/oauth/sign_out":

33 InOperation GetMethod:

44 SecurityRequirementStep 1:

@@ -7,7 +7,7 @@ forwardChanges:

77 InOperation PostMethod:

88 SecurityRequirementStep 0:

99 SecuritySchemeStep "oauth": SecuritySchemeNotMatched

10−backwardChanges:

10+nonBreakingChanges:

1111 AtPath "/oauth/check":

1212 InOperation PostMethod:

1313 SecurityRequirementStep 0:

test/golden/common/servers/report.md+5−5

@@ -1,10 +1,10 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 3 | 1 |

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

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

5+| 3 | 1 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **GET** /pets

1010

@@ -18,7 +18,7 @@ The server was removed.

1818

19192. A variable has been changed from being open to being closed.

2020

21−# ⚠️ Non-breaking changes

21+# 🙆 Non-breaking changes

2222

2323## **GET** /pets

2424

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

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/pets":

33 InOperation GetMethod:

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

55 - EnumValueNotConsumed 1 "a"

66 - ConsumerNotOpen 7

77 InServer "http://missing.url": ServerNotMatched

8−backwardChanges:

8+nonBreakingChanges:

99 AtPath "/pets":

1010 InOperation GetMethod:

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

test/golden/common/tuple-items/heterogeneous-component-mismatch/a.yamldeleted−28

@@ -1,28 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22−components:

23− schemas:

24− Test:

25− type: array

26− items:

27− - type: number

28− - type: string

test/golden/common/tuple-items/heterogeneous-component-mismatch/b.yamldeleted−28

@@ -1,28 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22−components:

23− schemas:

24− Test:

25− type: array

26− items:

27− - type: number

28− - type: object

test/golden/common/tuple-items/heterogeneous-component-mismatch/report.mddeleted−37

@@ -1,37 +0,0 @@

1−# Summary

2−

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 2 | 2 |

6−

7−# ❌ Breaking changes

8−

9−## **POST** /test

10−

11−### ➡️☁️ JSON Request

12−

13−#### `$[1](String)`

14−

15−The type has been removed.

16−

17−### ⬅️☁️ JSON Response – 200

18−

19−#### `$[1](Object)`

20−

21−The type has been added.

22−

23−# ⚠️ Non-breaking changes

24−

25−## **POST** /test

26−

27−### ➡️☁️ JSON Request

28−

29−#### `$[1](Object)`

30−

31−The type has been added.

32−

33−### ⬅️☁️ JSON Response – 200

34−

35−#### `$[1](String)`

36−

37−The type has been removed.

test/golden/common/tuple-items/heterogeneous-component-mismatch/trace-tree.yamldeleted−30

@@ -1,30 +0,0 @@

1−forwardChanges:

2− AtPath "/test":

3− InOperation PostMethod:

4− InRequest:

5− InPayload:

6− PayloadSchema:

7− OfType Array:

8− InItem 1:

9− OfType String: TypeBecomesEmpty

10− WithStatusCode 200:

11− ResponsePayload:

12− PayloadSchema:

13− OfType Array:

14− InItem 1:

15− OfType Object: TypeBecomesEmpty

16−backwardChanges:

17− AtPath "/test":

18− InOperation PostMethod:

19− InRequest:

20− InPayload:

21− PayloadSchema:

22− OfType Array:

23− InItem 1:

24− OfType Object: TypeBecomesEmpty

25− WithStatusCode 200:

26− ResponsePayload:

27− PayloadSchema:

28− OfType Array:

29− InItem 1:

30− OfType String: TypeBecomesEmpty

test/golden/common/tuple-items/heterogeneous-length-mismatch/a.yamldeleted−29

@@ -1,29 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22−components:

23− schemas:

24− Test:

25− type: array

26− items:

27− - type: number

28− - type: string

29− - type: object

test/golden/common/tuple-items/heterogeneous-length-mismatch/b.yamldeleted−28

@@ -1,28 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22−components:

23− schemas:

24− Test:

25− type: array

26− items:

27− - type: number

28− - type: object

test/golden/common/tuple-items/heterogeneous-length-mismatch/report.mddeleted−21

@@ -1,21 +0,0 @@

1−# Summary

2−

3−| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

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

5−| 2 | 0 |

6−

7−# ❌ Breaking changes

8−

9−## **POST** /test

10−

11−### ➡️☁️ JSON Request

12−

13−#### `$(Array)`

14−

15−Tuple length changed from 3 to 2.

16−

17−### ⬅️☁️ JSON Response – 200

18−

19−#### `$(Array)`

20−

21−Tuple length changed from 3 to 2.

test/golden/common/tuple-items/heterogeneous-length-mismatch/trace-tree.yamldeleted−26

@@ -1,26 +0,0 @@

1−forwardChanges:

2− AtPath "/test":

3− InOperation PostMethod:

4− InRequest:

5− InPayload:

6− PayloadSchema:

7− OfType Array: TupleItemsLengthChanged (ProdCons {producer = 3, consumer

8− = 2})

9− WithStatusCode 200:

10− ResponsePayload:

11− PayloadSchema:

12− OfType Array: TupleItemsLengthChanged (ProdCons {producer = 2, consumer

13− = 3})

14−backwardChanges:

15− AtPath "/test":

16− InOperation PostMethod:

17− InRequest:

18− InPayload:

19− PayloadSchema:

20− OfType Array: TupleItemsLengthChanged (ProdCons {producer = 2, consumer

21− = 3})

22− WithStatusCode 200:

23− ResponsePayload:

24− PayloadSchema:

25− OfType Array: TupleItemsLengthChanged (ProdCons {producer = 3, consumer

26− = 2})

test/golden/common/tuple-items/homogeneous-component-mismatch/a.yamldeleted−28

@@ -1,28 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22−components:

23− schemas:

24− Test:

25− type: array

26− items:

27− - type: string

28− - type: number

test/golden/common/tuple-items/homogeneous-component-mismatch/b.yamldeleted−29

@@ -1,29 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22−components:

23− schemas:

24− Test:

25− type: array

26− minItems: 2

27− maxItems: 2

28− items:

29− type: number

test/golden/common/tuple-items/homogeneous-component-mismatch/report.mddeleted−45

@@ -1,45 +0,0 @@

1−# Summary

2−

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 4 | 2 |

6−

7−# ❌ Breaking changes

8−

9−## **POST** /test

10−

11−### ➡️☁️ JSON Request

12−

13−#### `$(Array)`

14−

15−The array is no longer explicitly defined as a tuple.

16−

17−#### `$[0](String)`

18−

19−The type has been removed.

20−

21−### ⬅️☁️ JSON Response – 200

22−

23−#### `$(Array)`

24−

25−The array is no longer explicitly defined as a tuple.

26−

27−#### `$[0](Number)`

28−

29−The type has been added.

30−

31−# ⚠️ Non-breaking changes

32−

33−## **POST** /test

34−

35−### ➡️☁️ JSON Request

36−

37−#### `$[0](Number)`

38−

39−The type has been added.

40−

41−### ⬅️☁️ JSON Response – 200

42−

43−#### `$[0](String)`

44−

45−The type has been removed.

test/golden/common/tuple-items/homogeneous-component-mismatch/trace-tree.yamldeleted−34

@@ -1,34 +0,0 @@

1−forwardChanges:

2− AtPath "/test":

3− InOperation PostMethod:

4− InRequest:

5− InPayload:

6− PayloadSchema:

7− OfType Array:

8− - TupleToArray

9− - InItem 0:

10− OfType String: TypeBecomesEmpty

11− WithStatusCode 200:

12− ResponsePayload:

13− PayloadSchema:

14− OfType Array:

15− - ArrayToTuple

16− - InItem 0:

17− OfType Number: TypeBecomesEmpty

18−backwardChanges:

19− AtPath "/test":

20− InOperation PostMethod:

21− InRequest:

22− InPayload:

23− PayloadSchema:

24− OfType Array:

25− - ArrayToTuple

26− - InItem 0:

27− OfType Number: TypeBecomesEmpty

28− WithStatusCode 200:

29− ResponsePayload:

30− PayloadSchema:

31− OfType Array:

32− - TupleToArray

33− - InItem 0:

34− OfType String: TypeBecomesEmpty

test/golden/common/tuple-items/homogeneous-length-mismatch/a.yamldeleted−56

@@ -1,56 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test1:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22− /test2:

23− post:

24− requestBody:

25− content:

26− application/json:

27− schema:

28− $ref: "#/components/schemas/Test"

29− responses:

30− '200':

31− description: test

32− content:

33− application/json:

34− schema:

35− $ref: "#/components/schemas/Test"

36− /test3:

37− post:

38− requestBody:

39− content:

40− application/json:

41− schema:

42− $ref: "#/components/schemas/Test"

43− responses:

44− '200':

45− description: test

46− content:

47− application/json:

48− schema:

49− $ref: "#/components/schemas/Test"

50−components:

51− schemas:

52− Test:

53− type: array

54− items:

55− - type: number

56− - type: number

test/golden/common/tuple-items/homogeneous-length-mismatch/b.yamldeleted−67

@@ -1,67 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test1:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test1"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test1"

22− /test2:

23− post:

24− requestBody:

25− content:

26− application/json:

27− schema:

28− $ref: "#/components/schemas/Test2"

29− responses:

30− '200':

31− description: test

32− content:

33− application/json:

34− schema:

35− $ref: "#/components/schemas/Test2"

36− /test3:

37− post:

38− requestBody:

39− content:

40− application/json:

41− schema:

42− $ref: "#/components/schemas/Test3"

43− responses:

44− '200':

45− description: test

46− content:

47− application/json:

48− schema:

49− $ref: "#/components/schemas/Test3"

50−components:

51− schemas:

52− Test1:

53− type: array

54− maxItems: 2

55− items:

56− type: number

57− Test2:

58− type: array

59− minItems: 2

60− items:

61− type: number

62− Test3:

63− type: array

64− minItems: 3

65− maxItems: 3

66− items:

67− type: number

test/golden/common/tuple-items/homogeneous-length-mismatch/report.mddeleted−73

@@ -1,73 +0,0 @@

1−# Summary

2−

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 5 | 5 |

6−

7−# ❌ Breaking changes

8−

9−## **POST** /test1

10−

11−### ⬅️☁️ JSON Response – 200

12−

13−#### `$(Array)`

14−

15−The array is no longer explicitly defined as a tuple.

16−

17−## **POST** /test2

18−

19−### ⬅️☁️ JSON Response – 200

20−

21−#### `$(Array)`

22−

23−The array is no longer explicitly defined as a tuple.

24−

25−## **POST** /test3

26−

27−### ➡️☁️ JSON Request

28−

29−#### `$(Array)`

30−

31−Minimum length of the array changed from 2 to 3.

32−

33−### ⬅️☁️ JSON Response – 200

34−

35−#### `$(Array)`

36−

37−1. Tuple length changed from 2 to 3.

38−

39−2. The array is no longer explicitly defined as a tuple.

40−

41−# ⚠️ Non-breaking changes

42−

43−## **POST** /test1

44−

45−### ➡️☁️ JSON Request

46−

47−#### `$(Array)`

48−

49−The array is no longer explicitly defined as a tuple.

50−

51−## **POST** /test2

52−

53−### ➡️☁️ JSON Request

54−

55−#### `$(Array)`

56−

57−The array is no longer explicitly defined as a tuple.

58−

59−## **POST** /test3

60−

61−### ➡️☁️ JSON Request

62−

63−#### `$(Array)`

64−

65−1. Tuple length changed from 2 to 3.

66−

67−2. The array is no longer explicitly defined as a tuple.

68−

69−### ⬅️☁️ JSON Response – 200

70−

71−#### `$(Array)`

72−

73−Minimum length of the array changed from 2 to 3.

test/golden/common/tuple-items/homogeneous-length-mismatch/trace-tree.yamldeleted−52

@@ -1,52 +0,0 @@

1−forwardChanges:

2− AtPath "/test3":

3− InOperation PostMethod:

4− InRequest:

5− InPayload:

6− PayloadSchema:

7− OfType Array: MatchingMinItemsWeak (ProdCons {producer = 2, consumer =

8− 3})

9− WithStatusCode 200:

10− ResponsePayload:

11− PayloadSchema:

12− OfType Array:

13− - TupleItemsLengthChanged (ProdCons {producer = 3, consumer = 2})

14− - ArrayToTuple

15− AtPath "/test1":

16− InOperation PostMethod:

17− WithStatusCode 200:

18− ResponsePayload:

19− PayloadSchema:

20− OfType Array: NoMatchingTupleItems

21− AtPath "/test2":

22− InOperation PostMethod:

23− WithStatusCode 200:

24− ResponsePayload:

25− PayloadSchema:

26− OfType Array: NoMatchingTupleItems

27−backwardChanges:

28− AtPath "/test3":

29− InOperation PostMethod:

30− InRequest:

31− InPayload:

32− PayloadSchema:

33− OfType Array:

34− - TupleItemsLengthChanged (ProdCons {producer = 3, consumer = 2})

35− - ArrayToTuple

36− WithStatusCode 200:

37− ResponsePayload:

38− PayloadSchema:

39− OfType Array: MatchingMinItemsWeak (ProdCons {producer = 2, consumer =

40− 3})

41− AtPath "/test1":

42− InOperation PostMethod:

43− InRequest:

44− InPayload:

45− PayloadSchema:

46− OfType Array: NoMatchingTupleItems

47− AtPath "/test2":

48− InOperation PostMethod:

49− InRequest:

50− InPayload:

51− PayloadSchema:

52− OfType Array: NoMatchingTupleItems

test/golden/common/tuple-items/homogeneous-vector/a.yamldeleted−28

@@ -1,28 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22−components:

23− schemas:

24− Test:

25− type: array

26− items:

27− - type: number

28− - type: number

test/golden/common/tuple-items/homogeneous-vector/b.yamldeleted−29

@@ -1,29 +0,0 @@

1−openapi: "3.0.0"

2−info:

3− version: 1.0.0

4− title: Test

5−servers:

6− - url: http://localhost/

7−paths:

8− /test:

9− post:

10− requestBody:

11− content:

12− application/json:

13− schema:

14− $ref: "#/components/schemas/Test"

15− responses:

16− '200':

17− description: test

18− content:

19− application/json:

20− schema:

21− $ref: "#/components/schemas/Test"

22−components:

23− schemas:

24− Test:

25− type: array

26− minItems: 2

27− maxItems: 2

28− items:

29− type: number

test/golden/common/tuple-items/homogeneous-vector/report.mddeleted−5

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

1−# Summary

2−

3−| ❌ Breaking changes | ⚠️ Non-breaking changes |

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

5−| 0 | 0 |

test/golden/common/tuple-items/homogeneous-vector/trace-tree.yamldeleted−2

@@ -1,2 +0,0 @@

1−forwardChanges: {}

2−backwardChanges: {}

test/golden/common/type-changing/report.md+19−19

@@ -1,14 +1,14 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 6 | 6 |

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

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

5+| 6 | 6 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test1

1010

11−### ➡️☁️ JSON Request

11+### 📱➡️ JSON Request

1212

1313Values are now limited to the following types:

1414

@@ -16,7 +16,7 @@ Values are now limited to the following types:

1616

1717## **POST** /test2

1818

19−### ➡️☁️ JSON Request

19+### 📱➡️ JSON Request

2020

2121Values are now limited to the following types:

2222

@@ -28,23 +28,23 @@ Values are now limited to the following types:

2828

2929## **POST** /test3

3030

31−### ➡️☁️ JSON Request

31+### 📱➡️ JSON Request

3232

3333#### `$(Array)`

3434

35−The type has been removed.

35+The value has been removed.

3636

3737## **POST** /test4

3838

39−### ➡️☁️ JSON Request

39+### 📱➡️ JSON Request

4040

4141#### `$(Object)`

4242

43−The type has been removed.

43+The value has been removed.

4444

4545## **POST** /test5

4646

47−### ➡️☁️ JSON Request

47+### 📱➡️ JSON Request

4848

4949Values are now limited to the following types:

5050

@@ -54,11 +54,11 @@ Values are now limited to the following types:

5454

5555Value is now a multiple of 1.0.

5656

57−# ⚠️ Non-breaking changes

57+# 🙆 Non-breaking changes

5858

5959## **POST** /test1

6060

61−### ⬅️☁️ JSON Response – 200

61+### 📱⬅️ JSON Response – 200

6262

6363Values are now limited to the following types:

6464

@@ -66,7 +66,7 @@ Values are now limited to the following types:

6666

6767## **POST** /test2

6868

69−### ⬅️☁️ JSON Response – 200

69+### 📱⬅️ JSON Response – 200

7070

7171Values are now limited to the following types:

7272

@@ -78,23 +78,23 @@ Values are now limited to the following types:

7878

7979## **POST** /test3

8080

81−### ⬅️☁️ JSON Response – 200

81+### 📱⬅️ JSON Response – 200

8282

8383#### `$(Array)`

8484

85−The type has been removed.

85+The value has been removed.

8686

8787## **POST** /test4

8888

89−### ⬅️☁️ JSON Response – 200

89+### 📱⬅️ JSON Response – 200

9090

9191#### `$(Object)`

9292

93−The type has been removed.

93+The value has been removed.

9494

9595## **POST** /test5

9696

97−### ⬅️☁️ JSON Response – 200

97+### 📱⬅️ JSON Response – 200

9898

9999Values are now limited to the following types:

100100

test/golden/common/type-changing/trace-tree.yaml+6−6

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test5":

33 InOperation PostMethod:

44 InRequest:

@@ -11,13 +11,13 @@ forwardChanges:

1111 InRequest:

1212 InPayload:

1313 PayloadSchema:

14− OfType Array: TypeBecomesEmpty

14+ OfType Array: NoContradiction

1515 AtPath "/test4":

1616 InOperation PostMethod:

1717 InRequest:

1818 InPayload:

1919 PayloadSchema:

20− OfType Object: TypeBecomesEmpty

20+ OfType Object: NoContradiction

2121 AtPath "/test1":

2222 InOperation PostMethod:

2323 InRequest:

@@ -28,7 +28,7 @@ forwardChanges:

2828 InRequest:

2929 InPayload:

3030 PayloadSchema: TypesRestricted [Number,Array,Object]

31−backwardChanges:

31+nonBreakingChanges:

3232 AtPath "/test5":

3333 InOperation PostMethod:

3434 WithStatusCode 200:

@@ -41,13 +41,13 @@ backwardChanges:

4141 WithStatusCode 200:

4242 ResponsePayload:

4343 PayloadSchema:

44− OfType Array: TypeBecomesEmpty

44+ OfType Array: NoContradiction

4545 AtPath "/test4":

4646 InOperation PostMethod:

4747 WithStatusCode 200:

4848 ResponsePayload:

4949 PayloadSchema:

50− OfType Object: TypeBecomesEmpty

50+ OfType Object: NoContradiction

5151 AtPath "/test1":

5252 InOperation PostMethod:

5353 WithStatusCode 200:

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

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

11# Summary

22

3−| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |

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

5−| 0 | 0 | 1 |

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

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

5+| 0 | 0 | 1 |

66

7−# ❓ Unsupported feature changes

7+# 🤷 Unsupported feature changes

88

99## **GET** /api/foo

1010

11−### ⬅️☁️ JSON Response – 200

11+### 📱⬅️ JSON Response – 200

1212

13−Encountered recursion that is too complex for CompaREST to untangle.

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

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

@@ -1,10 +1,10 @@

1−forwardChanges:

1+breakingChanges:

22 AtPath "/api/foo":

33 InOperation GetMethod:

44 WithStatusCode 200:

55 ResponsePayload:

66 PayloadSchema: UnguardedRecursion

7−backwardChanges:

7+nonBreakingChanges:

88 AtPath "/api/foo":

99 InOperation GetMethod:

1010 WithStatusCode 200:

test/golden/common/variant-added/report.md+11−11

@@ -1,25 +1,25 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 1 | 1 |

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

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

5+| 1 | 1 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

11−### ⬅️☁️ JSON Response – 200

11+### 📱⬅️ JSON Response – 200

1212

13−#### `$(Object)`

13+#### In cases where `$.tag` is `"C"`

1414

15−The case where `$.tag` is `"C"` – has been added.

15+The value has been added.

1616

17−# ⚠️ Non-breaking changes

17+# 🙆 Non-breaking changes

1818

1919## **POST** /test

2020

21−### ➡️☁️ JSON Request

21+### 📱➡️ JSON Request

2222

23−#### `$(Object)`

23+#### In cases where `$.tag` is `"C"`

2424

25−The case where `$.tag` is `"C"` – has been added.

25+The value has been added.

test/golden/common/variant-added/trace-tree.yaml+6−6

@@ -1,16 +1,16 @@

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 WithStatusCode 200:

55 ResponsePayload:

66 PayloadSchema:

7− OfType Object: PartitionBecomesEmpty (PInProperty "tag" PHere,CByEnumValue

8− (fromList [String "C"]))

9−backwardChanges:

7+ OfType Object:

8+ InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "C"])): NoContradiction

9+nonBreakingChanges:

1010 AtPath "/test":

1111 InOperation PostMethod:

1212 InRequest:

1313 InPayload:

1414 PayloadSchema:

15− OfType Object: PartitionBecomesEmpty (PInProperty "tag" PHere,CByEnumValue

16− (fromList [String "C"]))

15+ OfType Object:

16+ InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "C"])): NoContradiction

test/golden/common/variant-changed/report.md+13−13

@@ -1,45 +1,45 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 2 | 2 |

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

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

5+| 2 | 2 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

11−### ➡️☁️ JSON Request

11+### 📱➡️ JSON Request

1212

1313#### In cases where `$.tag` is `"B"`

1414

1515##### `$.prop_B(Number)`

1616

17−The type has been removed.

17+The value has been removed.

1818

19−### ⬅️☁️ JSON Response – 200

19+### 📱⬅️ JSON Response – 200

2020

2121#### In cases where `$.tag` is `"B"`

2222

2323##### `$.prop_B(String)`

2424

25−The type has been added.

25+The value has been added.

2626

27−# ⚠️ Non-breaking changes

27+# 🙆 Non-breaking changes

2828

2929## **POST** /test

3030

31−### ➡️☁️ JSON Request

31+### 📱➡️ JSON Request

3232

3333#### In cases where `$.tag` is `"B"`

3434

3535##### `$.prop_B(String)`

3636

37−The type has been added.

37+The value has been added.

3838

39−### ⬅️☁️ JSON Response – 200

39+### 📱⬅️ JSON Response – 200

4040

4141#### In cases where `$.tag` is `"B"`

4242

4343##### `$.prop_B(Number)`

4444

45−The type has been removed.

45+The value has been removed.

test/golden/common/variant-changed/trace-tree.yaml+6−6

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 InRequest:

@@ -7,15 +7,15 @@ forwardChanges:

77 OfType Object:

88 InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):

99 InProperty "prop_B":

10− OfType Number: TypeBecomesEmpty

10+ OfType Number: NoContradiction

1111 WithStatusCode 200:

1212 ResponsePayload:

1313 PayloadSchema:

1414 OfType Object:

1515 InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):

1616 InProperty "prop_B":

17− OfType String: TypeBecomesEmpty

18−backwardChanges:

17+ OfType String: NoContradiction

18+nonBreakingChanges:

1919 AtPath "/test":

2020 InOperation PostMethod:

2121 InRequest:

@@ -24,11 +24,11 @@ backwardChanges:

2424 OfType Object:

2525 InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):

2626 InProperty "prop_B":

27− OfType String: TypeBecomesEmpty

27+ OfType String: NoContradiction

2828 WithStatusCode 200:

2929 ResponsePayload:

3030 PayloadSchema:

3131 OfType Object:

3232 InPartition (PInProperty "tag" PHere,CByEnumValue (fromList [String "B"])):

3333 InProperty "prop_B":

34− OfType Number: TypeBecomesEmpty

34+ OfType Number: NoContradiction

test/golden/common/variant-deep-changed/report.md+13−13

@@ -1,45 +1,45 @@

11# Summary

22

3−| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

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

5−| 2 | 2 |

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

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

5+| 2 | 2 | 0 |

66

7−# ❌ Breaking changes

7+# ⚠️ Breaking changes

88

99## **POST** /test

1010

11−### ➡️☁️ JSON Request

11+### 📱➡️ JSON Request

1212

1313#### In cases where `$.desc.name` is `"B"`

1414

1515##### `$.prop_B(Number)`

1616

17−The type has been removed.

17+The value has been removed.

1818

19−### ⬅️☁️ JSON Response – 200

19+### 📱⬅️ JSON Response – 200

2020

2121#### In cases where `$.desc.name` is `"B"`

2222

2323##### `$.prop_B(String)`

2424

25−The type has been added.

25+The value has been added.

2626

27−# ⚠️ Non-breaking changes

27+# 🙆 Non-breaking changes

2828

2929## **POST** /test

3030

31−### ➡️☁️ JSON Request

31+### 📱➡️ JSON Request

3232

3333#### In cases where `$.desc.name` is `"B"`

3434

3535##### `$.prop_B(String)`

3636

37−The type has been added.

37+The value has been added.

3838

39−### ⬅️☁️ JSON Response – 200

39+### 📱⬅️ JSON Response – 200

4040

4141#### In cases where `$.desc.name` is `"B"`

4242

4343##### `$.prop_B(Number)`

4444

45−The type has been removed.

45+The value has been removed.

test/golden/common/variant-deep-changed/trace-tree.yaml+6−6

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

1−forwardChanges:

1+breakingChanges:

22 AtPath "/test":

33 InOperation PostMethod:

44 InRequest:

@@ -7,15 +7,15 @@ forwardChanges:

77 OfType Object:

88 InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):

99 InProperty "prop_B":

10− OfType Number: TypeBecomesEmpty

10+ OfType Number: NoContradiction

1111 WithStatusCode 200:

1212 ResponsePayload:

1313 PayloadSchema:

1414 OfType Object:

1515 InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):

1616 InProperty "prop_B":

17− OfType String: TypeBecomesEmpty

18−backwardChanges:

17+ OfType String: NoContradiction

18+nonBreakingChanges:

1919 AtPath "/test":

2020 InOperation PostMethod:

2121 InRequest:

@@ -24,11 +24,11 @@ backwardChanges:

2424 OfType Object:

2525 InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):

2626 InProperty "prop_B":

27− OfType String: TypeBecomesEmpty

27+ OfType String: NoContradiction

2828 WithStatusCode 200:

2929 ResponsePayload:

3030 PayloadSchema:

3131 OfType Object:

3232 InPartition (PInProperty "desc" (PInProperty "name" PHere),CByEnumValue (fromList [String "B"])):

3333 InProperty "prop_B":

34− OfType Number: TypeBecomesEmpty

34+ OfType Number: NoContradiction