e71cbde...master · typeable/compaREST

.github/actions/common_setup/action.yamlnew file+42

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

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@v27

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@v15

40+ with:

41+ name: typeable

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

.github/workflows/github-actions-image.yaml+261−27

@@ -5,52 +5,286 @@ on:

55 branches: [master]

66 pull_request:

77 branches: [master]

8+ release:

9+ types: [prereleased]

810

911jobs:

10− build-github-action-image:

11− runs-on: ubuntu-latest

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

1227

28+ check_versions:

29+ runs-on: ubuntu-latest

1330 steps:

1431 - uses: actions/checkout@v2

1532 with:

1633 submodules: recursive

17− - name: Increase swap

34+

35+ - name: Common setup

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

37+ with:

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

39+

40+ - name: Check library version

41+ if: github.event_name == 'release'

1842 run: |

19− free -h

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

44+ echo "::error file=compaREST.cabal::Library version does not match release version."

45+ exit 1

46+ fi

2047

21− sudo swapoff /mnt/swapfile

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

23− sudo mkswap /mnt/swapfile

24− sudo swapon /mnt/swapfile

48+ - name: Check docker tag

49+ if: github.event_name == 'release'

50+ run: |

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

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

53+ exit 1

54+ fi

2555

26− free -h

56+ - name: Check changelog

57+ if: github.event_name == 'release'

58+ run: |

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

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

61+ exit 1

62+ fi

2763

28− - name: Install Nix

29− uses: cachix/install-nix-action@v12

64+ Linux:

65+ needs: check_versions

66+ runs-on: ubuntu-latest

67+ steps:

68+ - uses: actions/checkout@v2

69+ with:

70+ submodules: recursive

71+

72+ - name: Common setup

73+ uses: ./.github/actions/common_setup

3074 with:

31− extra_nix_config: |

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

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

75+ authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

76+

77+ - name: Test

78+ shell: bash

79+ run: |

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

81+

82+ - name: Build Linux static binary

83+ shell: bash

84+ run: |

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

3486

35− - name: Login to Cachix

36− uses: cachix/cachix-action@v8

87+ - name: Upload compaREST Linux Binary

88+ uses: actions/upload-artifact@v2

3789 with:

38− name: octopod

39− signingKey: ${{ secrets.CACHIX_SIGNING_KEY }}

90+ name: compaREST-Linux

91+ path: compaREST

4092

41− - name: Build Github Action Docker Image

93+ - name: Build Docker Images

94+ shell: bash

4295 run: |

43− nix-build -A compaRESTGithubAction -j auto -o image

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

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

4498

45− - name: Log into Docker Hub

46− if: github.ref == 'refs/heads/master'

47− uses: docker/login-action@v1

99+ - name: Upload compaREST Docker Github Action Image

100+ uses: actions/upload-artifact@v2

101+ with:

102+ name: compaREST Github Action Docker Image

103+ path: compaREST-Github-Action-image.tar.gz

104+

105+ - name: Upload compaREST Docker Image

106+ uses: actions/upload-artifact@v2

107+ with:

108+ name: compaREST Docker Image

109+ path: compaREST-image.tar.gz

110+

111+ - name: Login to DockerHub

112+ uses: docker/login-action@v1.10.0

48113 with:

49114 username: ${{ secrets.DOCKER_HUB_USERNAME }}

50115 password: ${{ secrets.DOCKER_HUB_ACCESS_TOKEN }}

51116

52− - name: Upload Image to Docker Hub

53− if: github.ref == 'refs/heads/master'

117+ - name: Push Nightly Docker Images to DockerHub

118+ if: github.ref == 'refs/heads/master' && github.event_name == 'push'

119+ shell: bash

120+ run: |

121+ skopeo copy docker-archive:$(nix-build -A compaRESTGithubAction -j auto --no-out-link) docker://typeable/comparest-github-action:nightly

122+ skopeo copy docker-archive:$(nix-build -A compaRESTImage -j auto --no-out-link) docker://typeable/comparest:nightly

123+

124+ - name: Push Release Docker Images to DockerHub

125+ if: github.event_name == 'release'

126+ shell: bash

127+ run: |

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

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

130+

131+ - name: Zip Release Assets

132+ if: github.event_name == 'release'

133+ shell: bash

134+ run: |

135+ zip compaREST-Linux-x86.zip compaREST

136+

137+ - name: Upload compaREST Github Action Docker Image to release

138+ if: github.event_name == 'release'

139+ uses: svenstaro/upload-release-action@2.2.1

140+ with:

141+ repo_token: ${{ secrets.GITHUB_TOKEN }}

142+ file: compaREST-Github-Action-image.tar.gz

143+ tag: ${{ github.ref }}

144+

145+ - name: Upload compaREST Docker Image to release

146+ if: github.event_name == 'release'

147+ uses: svenstaro/upload-release-action@2.2.1

148+ with:

149+ repo_token: ${{ secrets.GITHUB_TOKEN }}

150+ file: compaREST-image.tar.gz

151+ tag: ${{ github.ref }}

152+

153+ - name: Upload compaREST binary – Linux – x86 to release

154+ if: github.event_name == 'release'

155+ uses: svenstaro/upload-release-action@2.2.1

156+ with:

157+ repo_token: ${{ secrets.GITHUB_TOKEN }}

158+ file: compaREST-Linux-x86.zip

159+ tag: ${{ github.ref }}

160+

161+ dist:

162+ needs: [check_versions, Linux]

163+ runs-on: ubuntu-latest

164+ steps:

165+ - uses: actions/checkout@v2

166+ with:

167+ submodules: recursive

168+

169+ - name: Common setup

170+ uses: ./.github/actions/common_setup

171+ with:

172+ authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

173+

174+ - name: Cache

175+ uses: actions/cache@v1

176+ with:

177+ path: |

178+ ~/.stack

179+ .stack-work

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

181+ restore-keys: |

182+ ${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }}

183+ ${{ runner.os }}-stack

184+

185+ - name: Upgrade stack

186+ shell: bash

187+ # Needed for Hackage token authorization

188+ run: stack upgrade --git

189+

190+ - name: Build dist

191+ run: |

192+ stack sdist --pvp-bounds both

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

194+

195+ - name: Upload compaREST sources artifact

196+ uses: actions/upload-artifact@v2

197+ with:

198+ name: compaREST sources

199+ path: ${{ env.distPath }}/*.tar.gz

200+

201+ - name: Upload compaREST sources to release

202+ if: github.event_name == 'release'

203+ uses: svenstaro/upload-release-action@2.2.1

204+ with:

205+ repo_token: ${{ secrets.GITHUB_TOKEN }}

206+ file_glob: true

207+ file: ${{ env.distPath }}/*.tar.gz

208+ tag: ${{ github.ref }}

209+

210+ - name: Publish compaREST candidate to Hackage

211+ shell: bash

212+ if: github.event_name == 'release'

213+ env:

214+ HACKAGE_KEY: ${{ secrets.HACKAGE_KEY }}

54215 run: |

55− docker load -i image

56− docker push typeable/comparest-github-action:latest

216+ stack upload --pvp-bounds both --candidate .

217+

218+ macOS:

219+ needs: check_versions

220+ runs-on: macos-latest

221+ steps:

222+ - uses: actions/checkout@v2

223+ with:

224+ submodules: recursive

225+

226+ - name: Common setup

227+ uses: ./.github/actions/common_setup

228+ with:

229+ authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

230+

231+ - name: Build macOS binary bundle

232+ run: |

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

234+

235+ - name: Upload macOS compaREST bundle

236+ uses: actions/upload-artifact@v2

237+ with:

238+ name: compaREST binary – macOS – x86

239+ path: compaREST

240+

241+ - name: Zip Release Assets

242+ if: github.event_name == 'release'

243+ shell: bash

244+ run: |

245+ zip -r compaREST-macOS-x86.zip compaREST

246+

247+ - name: Upload compaREST binary – macOS – x86 to release

248+ if: github.event_name == 'release'

249+ uses: svenstaro/upload-release-action@2.2.1

250+ with:

251+ repo_token: ${{ secrets.GITHUB_TOKEN }}

252+ file: compaREST-macOS-x86.zip

253+ tag: ${{ github.ref }}

254+

255+# Linux-Windows:

256+# needs: check_versions

257+# runs-on: ubuntu-latest

258+# steps:

259+# - uses: actions/checkout@v2

260+# with:

261+# submodules: recursive

262+#

263+# - name: Common setup

264+# uses: ./.github/actions/common_setup

265+# with:

266+# authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

267+#

268+# - name: Build Windows binary

269+# run: |

270+# cp -LR $(nix-build -A WindowsCompaRESTBin -j auto --no-out-link)/bin compaREST

271+#

272+# - name: Upload Windows compaREST bundle

273+# uses: actions/upload-artifact@v2

274+# with:

275+# name: compaREST binary – Windows

276+# path: compaREST

277+#

278+# - name: Zip Release Assets

279+# if: github.event_name == 'release'

280+# shell: bash

281+# run: |

282+# zip -r compaREST-Windows.zip compaREST

283+#

284+# - name: Upload compaREST binary – Windows to release

285+# if: github.event_name == 'release'

286+# uses: svenstaro/upload-release-action@2.2.1

287+# with:

288+# repo_token: ${{ secrets.GITHUB_TOKEN }}

289+# file: compaREST-Windows.zip

290+# tag: ${{ github.ref }}

.github/workflows/linux-binary.yamldeleted−54

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

1−name: Linux binary

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 13G /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 comparest-linux --copy-bins --flag comparest:Static

39− - name: Test

40− run: stack test --ghc-options=-O3 --flag comparest:Static --test-arguments='--hide-successes --no-create'

41−

42− - name: Zip

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

44− run: |

45− zip comparest-linux comparest-linux/comparest

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.yamldeleted−17

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

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

.gitmodulesdeleted−3

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

1−[submodule "awsm-css"]

2− path = awsm-css

3− url = https://github.com/igoradamenko/awsm.css.git

CHANGELOG.md+7−3

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

11# Changelog

22

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

3+`compaREST` uses [PVP Versioning][1].

44

5−## 0.0.0.0

5+## 0.1.0.1

66

7−* Initially created.

7+* Fixed an issue related to empty commit SHAs in GitHub Actions.

8+

9+## 0.1.0.0

10+

11+* Initial release.

812

913[1]: https://pvp.haskell.org

LICENSE+1−1

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

11MIT License

22

44

55Permission is hereby granted, free of charge, to any person obtaining a copy

66of this software and associated documentation files (the "Software"), to deal

README.md+40−19

@@ -1,14 +1,33 @@

1−# CompaREST

1+# compaREST

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/compaREST.svg?logo=haskell)](https://hackage.haskell.org/package/compaREST)

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

75

86Compatibility checker for OpenAPI

9−# Quick Start Guide

107

11−## Your situation

8+## Using compaREST in Github Actions

9+

10+Add the following step to your Github Actions workflow:

11+

12+```yaml

13+- uses: typeable/comparest

14+ if: ${{ github.event_name == 'pull_request' }}

15+ with:

16+ old: old-openapi.yaml

17+ new: new-openapi.yaml

18+```

19+

20+The `new` and `old` values should be paths to your OpenAPI specifications you want to compare.

21+

22+You will get something like this in your pull requests:

23+

24+![](docs/img/github-action-report.png)

25+

26+For more detail please see our [integration guide](docs/Integration_guide.md).

27+

28+## An example

29+

30+### Your situation

1231

1332You 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.)

1433

@@ -75,7 +94,7 @@ components:

7594 $ref: "#/components/schemas/Pet"

7695```

7796

78−## Evolving your product

97+### Evolving your product

7998

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

81100

@@ -144,7 +163,7 @@ components:

144163

145164Looking 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.

146165

147−## Assessing compatibility automatically

166+### Assessing compatibility automatically

148167

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

150169

@@ -158,15 +177,15 @@ Running this command will output a file `report.md`, containing the compatibilit

158177

159178> # Summary

160179>

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

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

163−> | 5 | 6 | 0 |

180+> | [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

181+> |------------------------------------------|--------------------------------------------------|

182+> | 5 | 6 |

164183>

165−> # ⚠️ Breaking changes

184+> # ❌ Breaking changes

166185>

167186> ## **GET** /pets

168187>

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

188+> ### ⬅️☁️ JSON Response – 200

170189>

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

172191>

@@ -176,7 +195,7 @@ Running this command will output a file `report.md`, containing the compatibilit

176195>

177196> ## **POST** /pets

178197>

179−> ### 📱➡️ JSON Request

198+> ### ➡️☁️ JSON Request

180199>

181200> #### `$.weight`

182201>

@@ -191,7 +210,7 @@ Running this command will output a file `report.md`, containing the compatibilit

191210>

192211> Value is now a multiple of 1.0.

193212>

194−> # 🙆 Non-breaking changes

213+> # ⚠️ Non-breaking changes

195214>

196215> ## **GET** /pets

197216>

@@ -203,7 +222,7 @@ Running this command will output a file `report.md`, containing the compatibilit

203222>

204223> Upper bound changed from 20.0 inclusive to 30.0 inclusive.

205224>

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

225+> ### ⬅️☁️ JSON Response – 200

207226>

208227> #### `$[*].weight`

209228>

@@ -220,7 +239,7 @@ Running this command will output a file `report.md`, containing the compatibilit

220239>

221240> ## **POST** /pets

222241>

223−> ### 📱➡️ JSON Request

242+> ### ➡️☁️ JSON Request

224243>

225244> #### `$.name(String)`

226245>

@@ -230,7 +249,7 @@ Running this command will output a file `report.md`, containing the compatibilit

230249

231250You 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.

232251

233−## Additional formats

252+### Additional formats

234253

235254You 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:

236255

@@ -238,7 +257,9 @@ You can also produce a self-contained HTML report that you can open in your brow

238257docker 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

239258```

240259

241−# CLI docs

260+## CLI docs

261+

262+For more detail please see our [user guide](docs/User_guide.md).

242263

243264```

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

action.yaml+14−13

@@ -7,41 +7,42 @@ inputs:

77 default: "${{ github.token }}"

88 required: false

99 repo:

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

10+ description: The owner of the repo in which to post the results.

1111 default: "${{ github.repository }}"

1212 required: false

13− pull_request:

14− description: The pull request in which to post the comment.

15− default: "${{ github.event.pull_request.number }}"

16− required: false

1713 project_name:

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

19− required: true

14+ description: The name of the project to which the API pertains. Used to name the check. Useful when you have multiple APIs in the same repo.

15+ required: false

16+ default: ""

2017 footer:

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

18+ description: A footer that can be appended to the check body.

2219 required: false

2320 default: ""

2421 old:

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

22+ description: The path to the old (client) specification of the API.

2623 required: true

2724 new:

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

25+ description: The path to new (server) specification of the API.

2926 required: true

27+ sha:

28+ description: The sha of the commit to post the check for.

29+ required: false

30+ default: "${{ github.event.pull_request.head.sha }}"

3031runs:

3132 using: "docker"

32− image: "typeable/comparest-github-action:latest"

33+ image: "docker://typeable/comparest-github-action:0.1.0.1"

3334 env:

3435 GITHUB_TOKEN: "${{ inputs.GITHUB_TOKEN }}"

3536 REPO: "${{ inputs.repo }}"

36− PR_NUMBER: "${{ inputs.pull_request }}"

3737 PROJECT_NAME: "${{ inputs.project_name }}"

3838 FOOTER: "${{ inputs.footer }}"

3939 ROOT: "/github/workspace"

4040 OLD: "${{ inputs.old }}"

4141 NEW: "${{ inputs.new }}"

42+ SHA: "${{ inputs.sha }}"

4243 pre-entrypoint: "/bin/pre"

4344 entrypoint: "/bin/run"

4445

4546branding:

4647 icon: crosshair

47− color: gray-dark

48+ color: blue

app/Data/OpenApi/Compare/Options.hs+92−72

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

11module Data.OpenApi.Compare.Options

2− ( Options (..)

3− , OutputMode (..)

4− , parseOptions

2+ ( Options (..),

3+ OutputMode (..),

4+ parseOptions,

55 )

66where

77

@@ -9,6 +9,7 @@ import Data.OpenApi.Compare.Report

99import GHC.Generics (Generic)

1010import Options.Applicative

1111import Options.Applicative.Help hiding (fullDesc)

12+import Text.PrettyPrint.ANSI.Leijen ((<$$>),string)

1213

1314parseOptions :: IO Options

1415parseOptions = customExecParser (prefs $ showHelpOnError) optionsParserInfo

@@ -30,86 +31,105 @@ optionsParserInfo :: ParserInfo Options

3031optionsParserInfo =

3132 info

3233 (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")))

34+ ( fullDesc

35+ <> header "CompaREST"

36+ <> progDescDoc

37+ ( Just $

38+ par "A tool to check compatibility between two OpenAPI specifications."

39+ <$$> hardline <> par "Usage examples" <> hardline

40+ <$$> indent

41+ 4

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

43+ <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml"

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

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

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

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

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

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

50+ )

51+ )

52+ )

4953

5054optionsParser :: Parser Options

5155optionsParser =

5256 Options

5357 <$> strOption

54− (short 'c'

55− <> long "client"

56− <> help

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

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

58+ ( short 'c'

59+ <> long "client"

60+ <> help

61+ "A path to the file containing the specification that will be \

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

63+ )

5964 <*> strOption

60− (short 's'

61− <> long "server"

62− <> help

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

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

65− <*> (flag'

66− Nothing

67− (long "silent"

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

69− <|> flag'

70− (Just OnlyErrors)

71− (long "only-breaking"

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

73− <|> flag'

74− (Just All)

75− (long "all"

76− <> help

77− "Report both incompatible and compatible changes. \

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

79− <|> pure (Just All))

80− <*> ((FileMode

81− <$> strOption

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

83− <> helpDoc

84− (Just $

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

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

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

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

89− <|> pure StdoutMode)

90− <*> (flag'

91− FoldingBlockquotesTreeStyle

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

93− <> help

94− "The report tree is structured using \

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

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

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

98− \bugs on GitHub.")

99− <|> flag'

100− HeadersTreeStyle

101− (long "header-style"

65+ ( short 's'

66+ <> long "server"

67+ <> help

68+ "A path to the file containing the specification that will be \

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

70+ )

71+ <*> ( flag'

72+ Nothing

73+ ( long "silent"

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

75+ )

76+ <|> flag'

77+ (Just OnlyErrors)

78+ ( long "only-breaking"

79+ <> help "Only report breaking changes in the output."

80+ )

81+ <|> flag'

82+ (Just All)

83+ ( long "all"

84+ <> help

85+ "Report both incompatible and compatible changes. \

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

87+ )

88+ <|> pure (Just All)

89+ )

90+ <*> ( ( FileMode

91+ <$> strOption

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

93+ <> helpDoc

94+ ( Just $

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

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

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

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

99+ )

100+ )

101+ )

102+ <|> pure StdoutMode

103+ )

104+ <*> ( flag'

105+ FoldingBlockquotesTreeStyle

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

102107 <> help

103108 "The report tree is structured using \

104− \increasing levels of headers.")

105− <|> pure HeadersTreeStyle)

106− <*> switch

107− (long "signal-exit-code"

108− <> helpDoc (Just $

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

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

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

112+ \bugs on GitHub."

113+ )

114+ <|> flag'

115+ HeadersTreeStyle

116+ ( long "header-style"

117+ <> help

118+ "The report tree is structured using \

119+ \increasing levels of headers."

120+ )

121+ <|> pure HeadersTreeStyle

122+ )

123+ <*> switch

124+ ( long "signal-exit-code"

125+ <> helpDoc

126+ ( Just $

109127 par "Signal API compatibility with the exit code."

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

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

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

130+ <$$> par "Exit with 2 if could not determine compatibility."

131+ )

132+ )

113133

114134par :: String -> Doc

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

app/FormatHeuristic.hs+1−1

@@ -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

app/Main.hs+1

@@ -2,6 +2,7 @@ module Main (main) where

22

33import Control.Monad

44import Control.Monad.Except

5+import Control.Monad.Trans (lift)

56import Data.Aeson

67import qualified Data.ByteString.Lazy as BSL

78import Data.Default

awsm-cssdeleted−1

Submodule changed.

ci/policeman.nixnew file+4

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

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

2+, pkgs ? import sources.nixpkgs { }

3+}:

4+pkgs.haskellPackages.policeman

comparest.cabal → compaREST.cabalrenamed+24−20

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

11cabal-version: 2.4

2−name: comparest

3−version: 0.0.0.0

2+name: compaREST

3+version: 0.1.0.1

44synopsis: Compatibility checker for OpenAPI

55description: Compatibility checker for OpenAPI.

66license: MIT

77license-file: LICENSE

88author: Typeable

9−maintainer: comparest@typeable.io

9+maintainer: compaREST@typeable.io

1010copyright: 2021 Typeable

1111category: Web

1212build-type: Simple

1313extra-doc-files: README.md

1414 CHANGELOG.md

15−tested-with: GHC == 8.10.4

16−extra-source-files: awsm-css/dist/awsm.min.css

17−

18−Flag static

19− Default: False

20− Manual: True

15+tested-with: GHC == 9.6

16+extra-source-files: css/awsm.min.css

17+extra-source-files:

18+ test/golden/**/*.yaml

19+ test/golden/**/*.md

2120

2221common common-options

23− if flag(static)

24− cc-options: -static

25− ld-options: -static -pthread

26− ghc-options: -static

2722 ghc-options:

2823 -Weverything

2924 -Wno-implicit-prelude

@@ -31,15 +26,17 @@ common common-options

3126 -Wno-safe

3227 -Wno-prepositive-qualified-module

3328 -Wno-missing-import-lists

29+ -Wno-missing-kind-signatures

3430 -Wno-partial-fields

3531 -Wno-all-missed-specialisations

3632 -Wno-missing-local-signatures

3733 -Wno-unsafe

3834 -fconstraint-solver-iterations=0

3935 default-language: Haskell2010

40− build-depends: base >= 4.12.0.0 && < 4.16

36+ build-depends: base >= 4.12.0.0 && < 5

4137 , text

4238

39+

4340 default-extensions: ApplicativeDo

4441 , BangPatterns

4542 , ConstraintKinds

@@ -81,6 +78,7 @@ common common-options

8178 , QuantifiedConstraints

8279 , DefaultSignatures

8380

81+

8482library

8583 import: common-options

8684 build-depends:

@@ -151,12 +149,12 @@ library

151149 other-modules: Data.HList

152150 , Data.OpenUnion.Extra

153151

154−executable comparest

152+executable compaREST

155153 import: common-options

156154 hs-source-dirs: app

157155 main-is: Main.hs

158156 build-depends:

159− comparest

157+ compaREST

160158 , pandoc

161159 , data-default

162160 , bytestring

@@ -168,6 +166,7 @@ executable comparest

168166 , containers

169167 , doctemplates

170168 , pandoc-types

169+ , prettyprinter-compat-ansi-wl-pprint

171170 ghc-options: -threaded

172171 -rtsopts

173172 -with-rtsopts=-N

@@ -175,12 +174,12 @@ executable comparest

175174 FormatHeuristic

176175 Data.OpenApi.Compare.Options

177176

178−executable comparest-github-action

177+executable compaREST-GitHub-Action

179178 import: common-options

180179 hs-source-dirs: github-action

181180 main-is: Main.hs

182181 build-depends:

183− comparest

182+ compaREST

184183 , pandoc

185184 , yaml

186185 , aeson

@@ -190,6 +189,7 @@ executable comparest-github-action

190189 , pandoc-types

191190 , envy

192191 , filepath

192+ , bytestring

193193 ghc-options: -threaded

194194 -rtsopts

195195 -with-rtsopts=-N

@@ -197,8 +197,10 @@ executable comparest-github-action

197197 Control.Monad.Freer.GitHub

198198 CompaREST.GitHub.API

199199 CompaREST.GitHub.Action.Config

200+ GitHub.Data.Checks

201+ GitHub.Endpoints.Checks

200202

201−test-suite comparest-tests

203+test-suite compaREST-tests

202204 import: common-options

203205 type: exitcode-stdio-1.0

204206 hs-source-dirs: test

@@ -206,8 +208,10 @@ test-suite comparest-tests

206208 other-modules:

207209 Spec.Golden.Extra

208210 Spec.Golden.TraceTree

211+ Paths_compaREST

212+ autogen-modules: Paths_compaREST

209213 build-depends:

210− , comparest

214+ , compaREST

211215 , tasty-golden

212216 , tasty

213217 , bytestring

css/awsm.min.cssnew file+1

@@ -0,0 +1 @@

1+@charset "UTF-8";html{font-family:"PT Serif",Georgia,serif;font-size:100%;line-height:1.6;background:#fff;color:#000;-webkit-overflow-scrolling:touch}body{margin:1em;font-size:1rem}@media (min-width:20rem){body{font-size:calc(1rem + .0125*(100vw - 20rem))}}@media (min-width:40rem){body{font-size:1.25rem}}body article,body footer,body header,body main{position:relative;max-width:40rem;margin:0 auto}body>header{margin-bottom:3.5em}body>header h1{margin:0;font-size:1.5em}body>header p{margin:0;font-size:.85em}body>footer{margin-top:4.5em;padding-bottom:1.5em;text-align:center;font-size:.8rem;color:#aaa}details,nav,p{margin:1em 0}nav ul{list-style:none;margin:0;padding:0}nav li{display:inline-block;margin-right:1em;margin-bottom:.25em}nav a:visited{color:#0064c1}article header h1 a:visited:hover,article header h2 a:visited:hover,nav a:hover{color:#3000c1}ol,ul{margin-top:0;padding-top:0;padding-left:2.5em}p{-webkit-hyphens:auto;-ms-hyphens:auto;hyphens:auto}aside:first-child,p:first-child{margin-top:0}aside:last-child,p:last-child{margin-bottom:0}p+ol,p+ul{margin-top:-.75em}p img,p picture{float:right;margin-bottom:.5em;margin-left:.5em}p picture img{float:none;margin:0}blockquote,dd{padding-left:2.5em}dd{margin-bottom:1em;margin-left:0}dt{font-weight:700}blockquote{margin:0}aside{margin:.5em 0;font-style:italic;color:#aaa}@media (min-width:65rem){aside{position:absolute;right:-12.5rem;width:9.375rem;max-width:9.375rem;margin:0;padding-left:.5em;font-size:.8em;border-left:1px solid #f2f2f2}}section+section{margin-top:2em}h1,h2,h3,h4,h5,h6{margin:1.25em 0 0;line-height:1.2}h1:focus>a[href^="#"][id],h1:hover>a[href^="#"][id],h2:focus>a[href^="#"][id],h2:hover>a[href^="#"][id],h3:focus>a[href^="#"][id],h3:hover>a[href^="#"][id],h4:focus>a[href^="#"][id],h4:hover>a[href^="#"][id],h5:focus>a[href^="#"][id],h5:hover>a[href^="#"][id],h6:focus>a[href^="#"][id],h6:hover>a[href^="#"][id]{opacity:1;transition:opacity 0s,color 300ms ease-out}figure+p,h1+details,h1+p,h2+details,h2+p,h3+details,h3+p,h4+details,h4+p,h5+details,h5+p,h6+details,h6+p{margin-top:.5em}h1>a[href^="#"][id],h2>a[href^="#"][id],h3>a[href^="#"][id],h4>a[href^="#"][id],h5>a[href^="#"][id],h6>a[href^="#"][id]{position:absolute;left:-.5em;opacity:0;background:0 0;color:rgba(0,0,0,.5);transition:opacity 300ms ease-out}h1>a[href^="#"][id]:focus,h1>a[href^="#"][id]:hover,h1>a[href^="#"][id]:target,h2>a[href^="#"][id]:focus,h2>a[href^="#"][id]:hover,h2>a[href^="#"][id]:target,h3>a[href^="#"][id]:focus,h3>a[href^="#"][id]:hover,h3>a[href^="#"][id]:target,h4>a[href^="#"][id]:focus,h4>a[href^="#"][id]:hover,h4>a[href^="#"][id]:target,h5>a[href^="#"][id]:focus,h5>a[href^="#"][id]:hover,h5>a[href^="#"][id]:target,h6>a[href^="#"][id]:focus,h6>a[href^="#"][id]:hover,h6>a[href^="#"][id]:target{opacity:1;box-shadow:none;color:#000;transition:opacity 0s,color 0s}h1>a[href^="#"][id]:target:focus,h2>a[href^="#"][id]:target:focus,h3>a[href^="#"][id]:target:focus,h4>a[href^="#"][id]:target:focus,h5>a[href^="#"][id]:target:focus,h6>a[href^="#"][id]:target:focus{outline:0}h1>a[href^="#"][id]::before,h2>a[href^="#"][id]::before,h3>a[href^="#"][id]::before,h4>a[href^="#"][id]::before,h5>a[href^="#"][id]::before,h6>a[href^="#"][id]::before{content:"â€¢"}h1{font-size:2em}h2{font-size:1.75em}h3{font-size:1.25em}h4{font-size:1.15em}h5,h6{font-size:1em}h6{margin-top:1em;color:#aaa}article+article{margin-top:5em}article header p{font-family:system-ui,-apple-system,BlinkMacSystemFont,"Segoe UI",Roboto,Oxygen,Ubuntu,Cantarell,"Fira Sans","Droid Sans","Helvetica Neue",Helvetica,Arial,sans-serif;font-size:.6em;color:#aaa}article header p+h1,article header p+h2{margin-top:-.25em}article header h1+p,article header h2+p{margin-top:.25em}article header h1 a,article header h2 a{color:#000;background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="1"%3E%3Crect x="0" y="0.5" width="1" height="0.5" fill="rgba(0, 0, 0, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}@media screen and (-ms-high-contrast:active),(-ms-high-contrast:none){article header h1 a,article header h2 a{background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="2"%3E%3Crect x="0" y="1" width="1" height="1" fill="rgba(0, 0, 0, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}}article header h1 a:visited,article header h2 a:visited{color:#aaa;background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="1"%3E%3Crect x="0" y="0.5" width="1" height="0.5" fill="rgba(170, 170, 170, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}@media screen and (-ms-high-contrast:active),(-ms-high-contrast:none){article header h1 a:visited,article header h2 a:visited{background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="2"%3E%3Crect x="0" y="1" width="1" height="1" fill="rgba(170, 170, 170, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}}article>footer{margin-top:1.5em;font-size:.85em}a,abbr{text-decoration:none}a{color:#0064c1;transition:color 300ms ease-out,box-shadow 300ms ease-out;background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="1"%3E%3Crect x="0" y="0.5" width="1" height="0.5" fill="rgba(0, 100, 193, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}@media screen and (-ms-high-contrast:active),(-ms-high-contrast:none){a{background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="2"%3E%3Crect x="0" y="1" width="1" height="1" fill="rgba(0, 100, 193, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}}a:visited{color:#80b2e0}a:active,a:hover{outline-width:0}a:hover{box-shadow:inset 0 -1px #3000c1;color:#3000c1;transition:color 0s,box-shadow 0s}abbr{margin-right:-.075em;-webkit-hyphens:none;-ms-hyphens:none;hyphens:none;letter-spacing:.075em;font-size:.9em;border-bottom:1px dotted}img,picture{display:block;max-width:100%;margin:0 auto}audio,video{width:100%;max-width:100%}video{-o-object-position:0 -1px;object-position:0 -1px}figure{margin:1em 0 .5em;padding:0}figure figcaption{opacity:.65;font-size:.85em}table{display:inline-block;border-spacing:0;border-collapse:collapse;overflow-x:auto;max-width:100%;text-align:left;vertical-align:top;background:linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 0 0,linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 100% 0;background-attachment:scroll,scroll;background-size:1px 100%,1px 100%;background-repeat:no-repeat,no-repeat}table caption{font-size:.9em;background:#fff}table td,table th{padding:.35em .75em;vertical-align:top;font-size:.9em;border:1px solid #f2f2f2;border-top:0;border-left:0}table td:first-child,table th:first-child{padding-left:0;background-image:linear-gradient(to right,#fff 50%,rgba(255,255,255,0) 100%);background-size:2px 100%;background-repeat:no-repeat}table td:last-child,table th:last-child{padding-right:0;border-right:0;background-image:linear-gradient(to left,#fff 50%,rgba(255,255,255,0) 100%);background-position:100% 0;background-size:2px 100%;background-repeat:no-repeat}table td:only-child,table th:only-child{background-image:linear-gradient(to right,#fff 50%,rgba(255,255,255,0) 100%),linear-gradient(to left,#fff 50%,rgba(255,255,255,0) 100%);background-position:0 0,100% 0;background-size:2px 100%,2px 100%;background-repeat:no-repeat,no-repeat}table th{line-height:1.2}code,kbd,samp,var{font-family:Consolas,"Lucida Console",Monaco,monospace;font-style:normal}pre{overflow-x:auto;font-size:.8em;background:linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 0 0,linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 100% 0;background-attachment:scroll,scroll;background-size:1px 100%,1px 100%;background-repeat:no-repeat,no-repeat}pre>code,summary{display:inline-block}pre>code{overflow-x:visible;box-sizing:border-box;min-width:100%;border-right:3px solid #fff;border-left:1px solid #fff}hr{height:1px;margin:2em 0;border:0;background:#f2f2f2}details[open]{padding-bottom:.5em;border-bottom:1px solid #f2f2f2}summary{font-weight:700;border-bottom:1px dashed;cursor:pointer}summary::-webkit-details-marker{display:none}noscript{color:#d00000}::selection{background:rgba(0,100,193,.15)}

default.nix+68−14

@@ -1,10 +1,14 @@

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

22, haskellNix ? import sources.haskellNix { inherit system; }

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

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

44, system ? builtins.currentSystem

55, nix-filter ? import sources.nix-filter

66}:

77let

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

9+ yq = import ./nix/yq.nix { pkgs = masterPkgs; };

10+ diffYaml = import ./nix/diff-yaml.nix { pkgs = masterPkgs; };

11+

812 hsPkgs = pkgs.haskell-nix.stackProject {

913 src = nix-filter {

1014 root = ./.;

@@ -12,7 +16,7 @@ let

1216 include = [

1317 ./stack.yaml

1418 ./stack.yaml.lock

15− ./comparest.cabal

19+ ./compaREST.cabal

1620 ];

1721 };

1822

@@ -21,16 +25,22 @@ let

2125 dontStrip = false;

2226 dontPatchELF = false;

2327 enableDeadCodeElimination = true;

24− packages.comparest.src = nix-filter {

28+ ghcOptions = [

29+ "-O2"

30+ "-fexpose-all-unfoldings"

31+ "-fspecialise-aggressively"

32+ ];

33+ packages.pandoc.ghcOptions = [ "-O1" ];

34+ packages.compaREST.src = nix-filter {

2535 root = ./.;

2636 name = "compaREST-src";

2737 include = with nix-filter; [

28− (./comparest.cabal)

38+ (./compaREST.cabal)

2939 (inDirectory ./test)

3040 (inDirectory ./src)

3141 (inDirectory ./app)

3242 (inDirectory ./github-action)

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

43+ ./css/awsm.min.css

3444 ./LICENSE

3545 ];

3646 };

@@ -45,27 +55,71 @@ let

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

4656 '';

4757

48− compaREST = pkgs.dockerTools.buildImage {

58+ compaRESTBin = hsPkgs.compaREST.components.exes.compaREST;

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

60+

61+

62+ # doesn't work

63+ armDarwinCompaREST = hsPkgs.projectCross.aarch64-darwin.hsPkgs.compaREST.components.exes.compaREST;

64+

65+ compaRESTImage = pkgs.dockerTools.buildImage {

4966 name = "compaREST";

50− contents = [ (staticify "compaREST-static" hsPkgs.projectCross.musl64.hsPkgs.comparest.components.exes.comparest) ];

67+ contents = [ compaRESTStaticBin ];

5168 config = {

52− Entrypoint = [ "/bin/comparest" ];

69+ Entrypoint = [ "/bin/compaREST" ];

5370 };

5471 };

5572

73+ macOSCompaRESTBundle = pkgs.runCommand "compaREST-macOS-bundled"

74+ {

75+ buildInputs = [ masterPkgs.macdylibbundler ];

76+ } ''

77+ mkdir -p $out/lib

78+ cp ${compaRESTBin}/bin/compaREST $out/compaREST

79+ chmod 755 $out/compaREST

80+ dylibbundler -b \

81+ -x $out/compaREST \

82+ -d $out/lib \

83+ -p '@executable_path/lib'

84+ '';

85+

86+

5687 compaRESTGithubAction =

5788 let

58− action = staticify "compaREST-github-action-static" hsPkgs.projectCross.musl64.hsPkgs.comparest.components.exes.comparest-github-action;

59− wrapped = pkgs.runCommand "wrapped-compaREST-github-action" { buildInputs = [ pkgs.makeWrapper ]; } ''

60− makeWrapper ${action}/bin/comparest-github-action $out/bin/pre --add-flags "pre"

61− makeWrapper ${action}/bin/comparest-github-action $out/bin/run --add-flags "run"

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

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

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

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

6293 '';

6394 in

6495 pkgs.dockerTools.buildImage {

65− name = "typeable/comparest-github-action";

96+ name = "typeable/compaREST-GitHub-Action";

6697 tag = "latest";

6798 contents = [ wrapped pkgs.cacert ];

6899 };

69100

101+ WindowsCompaRESTBin = hsPkgs.projectCross.mingwW64.hsPkgs.compaREST.components.exes.compaREST;

102+

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

104+ # The only binaries build on CI are static.

105+ test = hsPkgs.projectCross.musl64.hsPkgs.compaREST.components.tests.compaREST-tests.overrideAttrs (final: old: {

106+ buildInputs = old.buildInputs ++ [ diffYaml yq ];

107+ nativeBuildInputs = old.nativeBuildInputs ++ (with masterPkgs; [ makeWrapper ]);

108+

109+ postInstall = ''

110+ wrapProgram $out/bin/compaREST-tests \

111+ --prefix PATH : ${masterPkgs.lib.makeBinPath [ diffYaml yq ]}

112+ '';

113+ });

70114in

71−{ inherit compaREST compaRESTGithubAction hsPkgs haskellNix; }

115+{

116+ inherit

117+ compaRESTImage

118+ compaRESTGithubAction

119+ compaRESTStaticBin

120+ compaRESTBin

121+ hsPkgs

122+ macOSCompaRESTBundle

123+ WindowsCompaRESTBin

124+ test;

125+}

docs/Development_guide.mdnew file+149

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

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.md+3−5

@@ -28,8 +28,6 @@ In our example we have already generated the two OpenAPI specs and placed them i

2828

2929We can now run our action:

3030

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

32−

3331```yaml

3432- uses: typeable/comparest

3533 with:

@@ -38,11 +36,11 @@ We can now run our action:

3836 project_name: TEST

3937```

4038

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

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

4240

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

41+![](img/github-action-report.png)

4442

45−Consecutive runs of the action will update the comment instead of creating new ones. This will prevent the pile-up of compaREST comments and save you from distracting notifications.

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

4644

4745## Integrating into something other than Github Actions

4846

docs/Releasing.mdnew file+15

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

1+# The release procedure

2+

3+1. Update the version number everywhere:

4+ 1. Version in [compaREST.cabal](../compaREST.cabal)

5+ 2. Docker tag in [action.yaml](../action.yaml)

6+ 3. Set the version of unreleased changes in [CHANGELOG.md](../CHANGELOG.md)

7+2. Publish!

8+ 1. Create a pre-release on GitHub:

9+ ![](img/pre-release.png)

10+ 2. This will automatically start the release procedure. You can check the state of it in the "Actions" tab on GitHub:

11+ ![](img/pre-release-ci.png)

12+ 3. If everything goes as planned, the release action should pass and all assets should be added to the release:

13+ ![](img/pre-release-artifacts.png)

14+ 4. The new version should be automatically uploaded a release candidate to [Hackage](https://hackage.haskell.org/package/compaREST/candidates/). Make sure everything looks okay and publish it.

15+ 5. Go to the Releases tab on GitHub and edit the release to make it not a "pre-release".

docs/User_guide.mdnew file+51

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

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-comment.pngdeleted

Binary file not shown.

docs/img/github-action-report.pngnew file

Binary file not shown.

docs/img/pre-release-artifacts.pngnew file

Binary file not shown.

docs/img/pre-release-ci.pngnew file

Binary file not shown.

docs/img/pre-release.pngnew file

Binary file not shown.

github-action/CompaREST/GitHub/API.hs+70−39

@@ -1,55 +1,86 @@

11module CompaREST.GitHub.API

2− ( mapComment,

3− createOrUpdateComment,

2+ ( postStatus,

3+ postStatusProcessing,

44 )

55where

66

77import CompaREST.GitHub.Action.Config

8−import Control.Monad

98import Control.Monad.Freer

109import Control.Monad.Freer.GitHub

1110import Control.Monad.Freer.Reader

12−import Data.Foldable

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

1315import Data.Proxy

1416import Data.Text (Text)

15−import qualified Data.Text as T

16−import qualified Data.Vector as V

1717import GitHub

18−import qualified GitHub as GH

18+import GitHub.Data.Checks

19+import GitHub.Endpoints.Checks

1920

20−findComment :: Members '[GitHub, Reader Config] effs => Eff effs (Maybe GH.IssueComment)

21−findComment = do

21+postStatusProcessing ::

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

23+ Eff effs ()

24+postStatusProcessing = do

2225 Config {..} <- ask

23− comments <- sendGitHub $ GH.commentsR repoOwner repoName issue GH.FetchAll

24− htmlComment <- getHTMLComment

25− let tryStripPrefix :: GH.IssueComment -> Maybe GH.IssueComment

26− tryStripPrefix c@GH.IssueComment {issueCommentBody = (T.stripSuffix htmlComment -> Just b)} =

27− Just $ c {GH.issueCommentBody = b}

28− tryStripPrefix _ = Nothing

29− pure . (V.!? 0) $ V.mapMaybe tryStripPrefix comments

26+ printJSON $

27+ sendGitHub $

28+ checkR

29+ repoOwner

30+ repoName

31+ Check

32+ { checkName = mkName Proxy checkName

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+ }

3043

31−mapComment :: Members '[GitHub, Reader Config] effs => (Text -> Text) -> Eff effs ()

32−mapComment f = do

33− findComment

34− >>= traverse_

35− ( \comment -> do

36− Config {..} <- ask

37− htmlComment <- getHTMLComment

38− sendGitHub $ editCommentR repoOwner repoName (GH.mkId Proxy $ GH.issueCommentId comment) ((<> htmlComment) . f $ GH.issueCommentBody comment)

39− pure ()

40− )

41−

42−createOrUpdateComment :: Members '[GitHub, Reader Config] effs => Text -> Eff effs ()

43−createOrUpdateComment body' = do

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

4456 Config {..} <- ask

45− htmlComment <- getHTMLComment

46− let body = body' <> htmlComment

47− void $

48− findComment >>= \case

49− Just comment -> sendGitHub $ editCommentR repoOwner repoName (GH.mkId Proxy $ GH.issueCommentId comment) body

50− Nothing -> sendGitHub $ createCommentR repoOwner repoName issue body

57+ printJSON $

58+ sendGitHub $

59+ checkR

60+ repoOwner

61+ repoName

62+ Check

63+ { checkName = mkName Proxy checkName

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+ }

5182

52−getHTMLComment :: Member (Reader Config) effs => Eff effs Text

53−getHTMLComment = do

54− name <- asks projectName

55− pure $ "\n\n"

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.hs+10−6

@@ -8,16 +8,17 @@ import Data.Text (Text)

88import qualified Data.Text as T

99import qualified GitHub as GH

1010

11+import Data.Functor

1112import System.Envy

1213

1314data Config = Config

1415 { githubToken :: GH.Auth

1516 , repoOwner :: GH.Name GH.Owner

1617 , repoName :: GH.Name GH.Repo

17− , issue :: GH.IssueNumber

18− , projectName :: Text

18+ , checkName :: Text

1919 , footerText :: Text

2020 , root :: FilePath

21+ , sha :: GH.Name GH.Commit

2122 }

2223

2324instance FromEnv Config where

@@ -27,17 +28,20 @@ instance FromEnv Config where

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

2829 [owner, name] -> pure (owner, name)

2930 _ -> fail "malformed repo"

30− issue <- GH.IssueNumber <$> env "PR_NUMBER"

31− projectName <- env "PROJECT_NAME"

31+ checkName <-

32+ envMaybe "PROJECT_NAME" <&> \case

33+ Just pName | not . T.null . T.strip $ pName -> "compaREST – " <> pName

34+ _ -> "compaREST"

3235 footerText <- env "FOOTER"

3336 root <- envMaybe "ROOT" .!= "."

37+ sha <- env "SHA"

3438 pure $

3539 Config

3640 { githubToken = token

3741 , repoOwner = GH.mkName Proxy owner

3842 , repoName = GH.mkName Proxy repo

39− , issue = issue

40− , projectName = projectName

43+ , checkName = checkName

4144 , footerText = footerText

4245 , root = root

46+ , sha = GH.mkName Proxy sha

4347 }

github-action/GitHub/Data/Checks.hsnew file+173

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

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.hsnew file+12

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

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.hs+20−35

@@ -9,6 +9,7 @@ import Control.Monad.Freer.GitHub

99import Control.Monad.Freer.Reader

1010import Data.OpenApi.Compare.Run

1111import Data.Text (Text)

12+import qualified Data.Text as T

1213import qualified Data.Yaml.Aeson as Yaml

1314import qualified GitHub as GH

1415import System.Environment

@@ -22,13 +23,18 @@ import Text.Pandoc.Writers

2223main :: IO ()

2324main = do

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

26+ case sha cfg of

27+ x | T.null . T.strip . GH.untagName $ x -> do

28+ putStrLn "SHA not specified. Exiting without doing anything."

29+ pure ()

30+ _ ->

31+ getArgs >>= \case

32+ ["pre"] -> runPre cfg

33+ ["run"] -> do

34+ oldFile <- getEnv "OLD"

35+ newFile <- getEnv "NEW"

36+ runRun cfg (root cfg </> oldFile) (root cfg </> newFile)

37+ _ -> error "Invalid arguments."

3238

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

3440runner cfg =

@@ -37,10 +43,7 @@ runner cfg =

3743 . runGitHub (githubToken cfg)

3844

3945runPre :: Config -> IO ()

40−runPre cfg =

41− runner cfg $

42− mapComment

43− (markdown (header 4 "⏳ Report might not be accurate. Attempting to update." <> horizontalRule) <>)

46+runPre cfg = runner cfg postStatusProcessing

4447

4548runRun :: Config -> FilePath -> FilePath -> IO ()

4649runRun cfg old' new' = runner cfg $ do

@@ -53,31 +56,13 @@ runRun cfg old' new' = runner cfg $ do

5356 }

5457 (report, status) = runReport reportConfig (old, new)

5558

56− summaryDetail s d =

57− rawHtml "<details>"

58− <> rawHtml "<summary>"

59− <> s

60− <> rawHtml "</summary>"

61− <> d

62− <> rawHtml "</details>"

63− where

64− rawHtml = rawBlock "html"

59+ body = markdown report <> "\n\n" <> footerText cfg

6560

66− message =

67− header 3 (text $ "⛄ compaREST – " <> projectName cfg)

68− <> if old == new

69− then header 1 "✅ The API did not change"

70− else

71− header

72− 1

73− ( case status of

74− BreakingChanges -> "⚠️ Breaking changes found!"

75− NoBreakingChanges -> "No breaking changes found ✨"

76− OnlyUnsupportedChanges -> "🤷 Couldn't determine compatibility"

77− )

78− <> summaryDetail (plain "ℹ️ Details") report

79− messageBody = markdown message <> "\n\n" <> footerText cfg

80− createOrUpdateComment messageBody

61+ result =

62+ if old == new

63+ then Nothing

64+ else Just (body, status)

65+ postStatus result

8166

8267markdown :: Blocks -> Text

8368markdown =

nix/ci.nixnew file+11

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

1+{ sources ? import ./sources.nix

2+, pkgs ? import sources.nixpkgs { }

3+}:

4+

5+let

6+ yq = import ./yq.nix { inherit pkgs; };

7+ diff-yaml = import ./diff-yaml.nix { inherit pkgs; };

8+in

9+pkgs.mkShell {

10+ packages = [ pkgs.haskellPackages.fourmolu diff-yaml yq ];

11+}

nix/diff-yaml.nixnew file+20

@@ -0,0 +1,20 @@

1+{ pkgs ? import <nixpkgs> {} }:

2+

3+let

4+ inherit (pkgs) stdenv;

5+ yq = import ./yq.nix { inherit pkgs; };

6+in

7+stdenv.mkDerivation {

8+ name = "diff-yaml";

9+

10+ src = ../scripts/diff-yaml;

11+

12+ buildInputs = [ pkgs.bash yq ];

13+

14+ phases = [ "installPhase" ];

15+

16+ installPhase = ''

17+ mkdir -p $out/bin

18+ cp $src $out/bin/diff-yaml

19+ '';

20+}

nix/shell.nixnew file+11

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

1+{ sources ? import ./sources.nix

2+, pkgs ? import sources.nixpkgs { }

3+}:

4+

5+let

6+ patched-yq = import ./yq.nix { inherit pkgs; };

7+ diffYaml = import ./diff-yaml.nix { inherit pkgs; };

8+in

9+pkgs.mkShell {

10+ buildInputs = with pkgs; [ pkg-config diffYaml patched-yq zlib ];

11+}

nix/sources.json+22−10

@@ -5,10 +5,10 @@

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

66 "owner": "input-output-hk",

77 "repo": "haskell.nix",

8− "rev": "1992b910e9b4d880e1f4639f4fe7266bceb9a5ad",

9− "sha256": "15w3wixjnb52f7cj3s94fy0zc0l1gc94p3n2wyq3qqxj10hvirfw",

8+ "rev": "d7f95903c84a5a50d6fe0844280da82c3c81680a",

9+ "sha256": "02870rk4sx44lwwa0k20iwdhqcx0ayz34yb3b0qy045p22q45815",

1010 "type": "tarball",

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

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

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

1313 },

1414 "niv": {

@@ -17,22 +17,34 @@

1717 "homepage": "https://github.com/nmattia/niv",

1818 "owner": "nmattia",

1919 "repo": "niv",

20− "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

21− "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

20+ "rev": "f7c538837892dd2eb83567c9f380a11efb59b53f",

21+ "sha256": "0xl33k24vfc29cg9lnp95kvcq69qbq5fzb7jk9ig4lgrhaarh651",

2222 "type": "tarball",

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

23+ "url": "https://github.com/nmattia/niv/archive/f7c538837892dd2eb83567c9f380a11efb59b53f.tar.gz",

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

2525 },

2626 "nix-filter": {

27− "branch": "master",

27+ "branch": "main",

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

2929 "homepage": "",

3030 "owner": "numtide",

3131 "repo": "nix-filter",

32− "rev": "3c9e33ed627e009428197b07216613206f06ed80",

33− "sha256": "19w142crrkywxynmyw4rhz4nglrg64yjawfkw3j91qwkwbfjds84",

32+ "rev": "3342559a24e85fc164b295c3444e8a139924675b",

33+ "sha256": "08xia32g5jzaiyhfl3kzxslzbr4w1i56i0mhy5gpfggv8gqy8sym",

34+ "type": "tarball",

35+ "url": "https://github.com/numtide/nix-filter/archive/3342559a24e85fc164b295c3444e8a139924675b.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": "bf038bd724982de67a2ee9a6b2f1fcb7d6a87bd7",

45+ "sha256": "0ivvwdmg9fipj6ylq5ipxqpb0xnz6hsx3lyn377jacfpiqi9w0cv",

3446 "type": "tarball",

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

47+ "url": "https://github.com/NixOS/nixpkgs/archive/bf038bd724982de67a2ee9a6b2f1fcb7d6a87bd7.tar.gz",

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

3749 }

3850}

nix/yq.nixnew file+26

@@ -0,0 +1,26 @@

1+{ pkgs ? import <nixpkgs> {} }:

2+

3+# Make yq work inside whatever `stack test` launches.

4+# Nuke this when https://github.com/kislyuk/yq/pull/193 is merged

5+# and nixpkgs includes that fix.

6+

7+let

8+ yq-patch = pkgs.writeText "yq-tty-fix.patch" ''

9+diff --git a/yq/__init__.py b/yq/__init__.py

10+index d95ac4b..ae7d59e 100644

11+--- a/yq/__init__.py

12++++ b/yq/__init__.py

13+@@ -110,7 +110,7 @@ def cli(args=None, input_format="yaml", program_name="yq"):

14+ in_place = args.in_place

15+ delattr(args, "in_place")

16+

17+- if sys.stdin.isatty() and not args.input_streams:

18++ if (sys.stdin is None or sys.stdin.isatty()) and not args.input_streams:

19+ parser.print_help()

20+ sys.exit(2)

21+ elif not args.input_streams:

22+ '';

23+in

24+pkgs.yq.overrideAttrs (final: old: {

25+ patches = old.patches ++ [ yq-patch ];

26+})

scripts/diff-yamlnew file+35

@@ -0,0 +1,35 @@

1+#!/usr/bin/env bash

2+set -e

3+

4+# Normalise YAML files passed as inputs, then run diff on them.

5+

6+check_util() {

7+ local util=$1

8+

9+ if [ -z $util ]; then

10+ echo "Error: $util not found in PATH"

11+ exit 1

12+ fi

13+}

14+

15+DIFF=`which diff`

16+check_util $DIFF

17+

18+YQ=`which yq`

19+check_util $YQ

20+

21+# Only normalise YAML files.

22+# Print anything else as is.

23+normalise() {

24+ local file=$1

25+ local contents=($YQ -y -S '.' $file)

26+

27+ # if $contents contains actual YAML data, print it

28+ if [[ $? == 0 ]]; then

29+ echo $contents

30+ else

31+ cat $file

32+ fi

33+}

34+

35+$DIFF -u <(normalise $1) <(normalise $2)

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/Behavior.hs+11−11

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

11module 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

2+ ( BehaviorLevel (..),

3+ Behavable (..),

4+ IssueKind (..),

5+ Issuable (..),

6+ Orientation (..),

7+ toggleOrientation,

8+ Behavior,

9+ AnIssue (..),

10+ withClass,

11+ anIssueKind,

12+ relatedAnIssues,

1313 )

1414where

1515

src/Data/OpenApi/Compare/Common.hs+1−1

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

11module Data.OpenApi.Compare.Common

2− ( zipAll

2+ ( zipAll,

33 )

44where

55

src/Data/OpenApi/Compare/Formula.hs+31−21

@@ -1,14 +1,15 @@

11module Data.OpenApi.Compare.Formula

2− ( FormulaF

3− , VarRef

4− , variable

5− , eitherOf

6− , anError

7− , errors

8− , calculate

9− , maxFixpoint

10− , mapErrors

11− ) where

2+ ( FormulaF,

3+ VarRef,

4+ variable,

5+ eitherOf,

6+ anError,

7+ errors,

8+ calculate,

9+ maxFixpoint,

10+ mapErrors,

11+ )

12+where

1213

1314import Data.Kind

1415import qualified Data.List.NonEmpty as NE

@@ -24,15 +25,24 @@ type VarRef = Int

2425-- fixpoints always exist, i.e. that @x = f x@ has at least one solution.

2526data FormulaF (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: Type) where

2627 Result :: a -> FormulaF q f r a

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

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

3137 -- both not 'Result'

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

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

3544 -- 'SelectFirst'

45+ FormulaF q f r a

3646 Variable :: !VarRef -> a -> FormulaF q f r a

3747

3848mkApply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a

@@ -44,13 +54,13 @@ mkApply f x h = Apply f x h

4454mkSelectFirst :: [SomeFormulaF b] -> P.PathsPrefixTree q f r -> (b -> a) -> FormulaF q f r a

4555mkSelectFirst fs allE h = case foldMap check fs of

4656 (First (Just x), _) -> Result (h x)

47− (First Nothing, x:xs) -> SelectFirst (x NE.:| xs) allE h

57+ (First Nothing, x : xs) -> SelectFirst (x NE.:| xs) allE h

4858 (First Nothing, []) -> Errors allE

4959 where

5060 check (SomeFormulaF (Result x)) = (First (Just x), mempty)

5161 check (SomeFormulaF (Errors _)) = (mempty, mempty)

52− check (SomeFormulaF (SelectFirst xs _ h'))

53− = (mempty, NE.toList (fmap (fmap h') xs))

62+ check (SomeFormulaF (SelectFirst xs _ h')) =

63+ (mempty, NE.toList (fmap (fmap h') xs))

5464 check x = (mempty, [x])

5565

5666data SomeFormulaF (a :: Type) where

@@ -96,7 +106,7 @@ calculate (Apply f x h) = case calculate f of

96106 Right x' -> Right (h (f' x'))

97107calculate (SelectFirst xs e h) = go (NE.toList xs)

98108 where

99− go (SomeFormulaF r:rs) = case calculate r of

109+ go (SomeFormulaF r : rs) = case calculate r of

100110 Left _ -> go rs

101111 Right x -> Right (h x)

102112 go [] = Left e

src/Data/OpenApi/Compare/Memo.hs+104−66

@@ -1,22 +1,24 @@

11{-# LANGUAGE AllowAmbiguousTypes #-}

2+

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

34module Data.OpenApi.Compare.Memo

4− ( MonadMemo

5− , MemoState

6− , runMemo

7− , modifyMemoNonce

8− , KnotTier(..)

9− , unknot

10− , memoWithKnot

11− , memoTaggedWithKnot

12− ) where

5+ ( MonadMemo,

6+ MemoState,

7+ runMemo,

8+ modifyMemoNonce,

9+ KnotTier (..),

10+ unknot,

11+ memoWithKnot,

12+ memoTaggedWithKnot,

13+ )

14+where

1315

1416import Control.Monad.State

1517import Data.Dynamic

1618import qualified Data.Map as M

1719import Data.Tagged

18−import Data.Void

1920import qualified Data.TypeRepMap as T

21+import Data.Void

2022import Type.Reflection

2123

2224data Progress a = Finished a | Started | TyingKnot Dynamic

@@ -29,16 +31,23 @@ data MemoState s = MemoState s (T.TypeRepMap MemoMap)

2931-- | An effectful memoization monad.

3032type MonadMemo s m = MonadState (MemoState s) m

3133

32−memoStateLookup

33− :: forall k v s. (Typeable k, Typeable v, Ord k)

34− => k -> MemoState s -> Maybe (Progress v)

34+memoStateLookup ::

35+ forall k v s.

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

37+ k ->

38+ MemoState s ->

39+ Maybe (Progress v)

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

3641 Just (MemoMap m) -> M.lookup k m

3742 Nothing -> Nothing

3843

39−memoStateInsert

40− :: forall k v s. (Typeable k, Typeable v, Ord k)

41− => k -> Progress v -> MemoState s -> MemoState s

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

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

4352 where

4453 m'' = M.insert k x m'

@@ -59,19 +68,23 @@ runMemo s = (`evalStateT` MemoState s T.empty)

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

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

6170data 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

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

6474 -- to the inner computations

65− , tieKnot :: d -> v -> m v -- ^ Once we're done and we're outside, tie the

75+ onKnotUsed :: d -> m v

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

6677 -- knot using the datum

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

6779 }

6880

6981unknot :: KnotTier v Void m

70−unknot = KnotTier

71− { onKnotFound = error "Recursion detected"

72− , onKnotUsed = absurd

73− , tieKnot = absurd

74− }

82+unknot =

83+ KnotTier

84+ { onKnotFound = error "Recursion detected"

85+ , onKnotUsed = absurd

86+ , tieKnot = absurd

87+ }

7588

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

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

@@ -80,47 +93,72 @@ unknot = KnotTier

8093--

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

8295-- *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'

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'

118147

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

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/Paths.hs+9−9

@@ -2,17 +2,17 @@

22-- collection of datatypes that "contain" eachother in some form of tree

33-- structure.

44module Data.OpenApi.Compare.Paths

5− ( NiceQuiver

6− , AdditionalQuiverConstraints

7− , Paths (..)

8− , DiffPaths (..)

9− , catDiffPaths

10− , AnItem (..)

11− , step

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+42−41

@@ -1,29 +1,30 @@

11{-# LANGUAGE QuantifiedConstraints #-}

22

33module 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

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,

2020 )

2121where

2222

2323import Control.Monad

2424import Data.Aeson

2525import Data.Foldable hiding (null, toList)

26−import qualified Data.HashMap.Strict as HM

26+import qualified Data.Aeson.Key as Key

27+import qualified Data.Aeson.KeyMap as KeyMap

2728import Data.Kind

2829import qualified Data.Map as M

2930import Data.Monoid

@@ -35,7 +36,7 @@ import qualified Data.TypeRepMap as TRM

3536import qualified Data.Vector as V

3637import qualified GHC.Exts as Exts

3738import Type.Reflection

38−import Prelude hiding (filter, map, null, lookup)

39+import Prelude hiding (filter, lookup, map, null)

3940

4041-- | A list of @AnItem r f@, but optimized into a prefix tree.

4142data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPrefixTree

@@ -102,11 +103,11 @@ deriving stock instance Eq (PathsPrefixTree q f a)

102103

103104-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where

104105-- 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

106+compareTRM ::

107+ (forall a. Typeable a => Ord (f a)) =>

108+ TRM.TypeRepMap f ->

109+ TRM.TypeRepMap f ->

110+ Ordering

110111compareTRM s1 s2 =

111112 foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys

112113 where

@@ -116,11 +117,11 @@ compareTRM s1 s2 =

116117 compareMaybe _ Nothing (Just _) = LT

117118 compareMaybe _ (Just _) Nothing = GT

118119 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

120+ compareW ::

121+ (forall a. Typeable a => Ord (f a)) =>

122+ TRM.WrapTypeable f ->

123+ TRM.WrapTypeable f ->

124+ Ordering

124125 compareW (TRM.WrapTypeable (x :: f a)) (TRM.WrapTypeable (y :: f b))

125126 | Just Refl <- testEquality (typeRep @a) (typeRep @b) = compare x y

126127 | otherwise = EQ -- unreachable

@@ -172,10 +173,10 @@ instance Monoid (ASet a) where

172173 mempty = AnEmptySet

173174

174175data 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

176+ AStep ::

177+ NiceQuiver q r a =>

178+ !(M.Map (q r a) (PathsPrefixTree q f a)) ->

179+ AStep q f r a

179180

180181mapAStep :: (forall x. f x -> f x) -> AStep q f r a -> AStep q f r a

181182mapAStep f (AStep m) = AStep $ M.map (map f) m

@@ -215,12 +216,12 @@ null :: PathsPrefixTree q f r -> Bool

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

216217null _ = False

217218

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

219+foldWith ::

220+ forall q f m r.

221+ Monoid m =>

222+ (forall a. Ord (f a) => Paths q r a -> f a -> m) ->

223+ PathsPrefixTree q f r ->

224+ m

224225foldWith k = goTPT Root

225226 where

226227 goTPT :: forall a. Paths q r a -> PathsPrefixTree q f a -> m

@@ -256,7 +257,7 @@ newtype MergableObject = MergableObject {getMergableObject :: Object}

256257

257258instance Semigroup MergableObject where

258259 (MergableObject x) <> (MergableObject y) =

259− MergableObject $ HM.unionWith mergeValue x y

260+ MergableObject $ KeyMap.unionWith mergeValue x y

260261 where

261262 mergeValue :: Value -> Value -> Value

262263 mergeValue (Object a) (Object b) =

@@ -271,6 +272,6 @@ instance Monoid MergableObject where

271272

272273traceObject :: Paths q r a -> Value -> Object

273274traceObject Root (Object o) = o

274−traceObject Root v = HM.singleton "root" v

275+traceObject Root v = KeyMap.singleton "root" v

275276traceObject (root `Snoc` s) v =

276− traceObject root . Object $ HM.singleton (T.pack . show $ s) v

277+ traceObject root . Object $ KeyMap.singleton (Key.fromText . T.pack . show $ s) v

src/Data/OpenApi/Compare/References.hs+8−9

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.References

4− ( Step (..)

5− , dereference

6− , Typeable

4+ ( Step (..),

5+ dereference,

6+ Typeable,

77 )

88where

99

@@ -13,17 +13,16 @@ import Data.Maybe

1313import Data.OpenApi

1414import Data.OpenApi.Compare.Orphans ()

1515import Data.OpenApi.Compare.Subtree

16−import Data.Typeable

1716

1817instance Typeable a => Steppable (Referenced a) a where

1918 data Step (Referenced a) a = InlineStep

2019 deriving stock (Eq, Ord, Show)

2120

22−dereference

23− :: Typeable a

24− => Traced (Definitions a)

25− -> Traced (Referenced a)

26− -> Traced a

21+dereference ::

22+ Typeable a =>

23+ Traced (Definitions a) ->

24+ Traced (Referenced a) ->

25+ Traced a

2726dereference defs x = case extract x of

2827 Inline a ->

2928 traced (ask x >>> step InlineStep) a

src/Data/OpenApi/Compare/Report.hs+139−119

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

11module Data.OpenApi.Compare.Report

2− ( generateReport

3− , CheckerOutput(..)

4− , ReportInput (..)

5− , segregateIssues

6− , ReportStatus (..)

7− , Pandoc

8− , ReportConfig (..)

9− , ReportTreeStyle (..)

10− , ReportMode (..)

2+ ( generateReport,

3+ CheckerOutput (..),

4+ ReportInput (..),

5+ segregateIssues,

6+ ReportStatus (..),

7+ Pandoc,

8+ ReportConfig (..),

9+ ReportTreeStyle (..),

10+ ReportMode (..),

1111 )

1212where

1313

@@ -30,8 +30,8 @@ import qualified Data.OpenApi.Compare.PathsPrefixTree as P hiding (empty)

3030import Data.OpenApi.Compare.Report.Jet

3131import Data.OpenApi.Compare.Subtree (invertIssueOrientationP)

3232import Data.OpenApi.Compare.Validate.OpenApi

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

3433import Data.OpenApi.Compare.Validate.Schema.Issues

34+import Data.OpenApi.Compare.Validate.Schema.TypedJson

3535import Data.OpenUnion

3636import Data.OpenUnion.Extra

3737import Data.Set

@@ -54,22 +54,27 @@ data CheckerOutput = CheckerOutput

5454 deriving anyclass (ToJSON)

5555

5656data ReportInput = ReportInput

57− { breakingChanges :: Changes -- ^ forward 'CertainIssue', 'ProbablyIssue' and 'Comment'

58− , nonBreakingChanges :: Changes -- ^ backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'

59− , unsupportedChanges :: Changes -- ^ forward and backward 'Unsupported' (assumed to be the same anyway)

60− , schemaIssues :: Changes -- ^ forward and backward 'SchemaInvalid' (assumed to be the same anyway)

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

6165 }

6266 deriving stock (Generic)

6367 deriving (Semigroup, Monoid) via (Generically ReportInput)

6468 deriving anyclass (ToJSON)

6569

6670segregateIssues :: CheckerOutput -> ReportInput

67−segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} = ReportInput

68− { breakingChanges = P.filter isBreaking fwd

69− , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck

70− , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck

71− , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck

72− }

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+ }

7378 where

7479 isBreaking i = anIssueKind i `elem` [CertainIssue, ProbablyIssue, Comment]

7580 isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool

@@ -106,8 +111,7 @@ twoRowTable x = simpleTable (para . fst <$> x) [para . snd <$> x]

106111

107112generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)

108113generateReport cfg inp =

109− let

110− schemaIssuesPresent = not $ P.null $ schemaIssues inp

114+ let schemaIssuesPresent = not $ P.null $ schemaIssues inp

111115 breakingChangesPresent = not $ P.null $ breakingChanges inp

112116 nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp

113117 unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp

@@ -116,47 +120,55 @@ generateReport cfg inp =

116120 OnlyErrors -> False

117121 builder = buildReport cfg

118122 report =

119− header 1 "Summary"

120− <> twoRowTable

121− (when'

122− schemaIssuesPresent

123− [ ( refOpt schemaIssuesPresent schemaIssuesId "‼️ Schema issues"

124− , show' $ P.size $ schemaIssues inp

125− )

126− ]

127− ++

128− [ ( refOpt breakingChangesPresent breakingChangesId "❌ Breaking changes"

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"

129134 , show' $ P.size $ breakingChanges inp

130135 )

131136 ]

132− ++ when'

133− nonBreakingChangesShown

134− [ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "⚠️ Non-breaking changes"

135− , show' $ P.size $ nonBreakingChanges inp

136− )

137− ]

138− ++ when'

139− unsupportedChangesPresent

140− [ ( refOpt unsupportedChangesPresent unsupportedChangesId "❓ Unsupported feature changes"

141− , show' $ P.size $ unsupportedChanges inp

142− )

143− ])

144− <> when'

145− schemaIssuesPresent

146− (header 1 (anchor schemaIssuesId <> "‼️ Schema issues")

147− <> builder (showErrs $ schemaIssues inp))

148− <> when'

149− breakingChangesPresent

150− (header 1 (anchor breakingChangesId <> "❌ Breaking changes")

151− <> builder (showErrs $ breakingChanges inp))

152− <> when'

153− (nonBreakingChangesPresent && nonBreakingChangesShown)

154− (header 1 (anchor nonBreakingChangesId <> "⚠️ Non-breaking changes")

155− <> builder (showErrs $ nonBreakingChanges inp))

156− <> when'

157− unsupportedChangesPresent

158− (header 1 (anchor unsupportedChangesId <> "❓ Unsupported feature changes")

159− <> builder (showErrs $ unsupportedChanges inp))

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

160172 status =

161173 if

162174 | breakingChangesPresent -> BreakingChanges

@@ -190,9 +202,10 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =

190202 Just Refl

191203 | (S.toList -> p@((AnIssue ori _) : _), o) <-

192204 S.partition

193− (\((AnIssue _ u)) -> case u of

194− NoPathsMatched {} -> True

195− AllPathsFailed {} -> True)

205+ ( \((AnIssue _ u)) -> case u of

206+ NoPathsMatched {} -> True

207+ AllPathsFailed {} -> True

208+ )

196209 currentIssues ->

197210 let p' = p <&> (\(AnIssue _ i) -> i)

198211 in (Just (ori, p'), o)

@@ -203,9 +216,10 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =

203216 paths = case removedPaths of

204217 Just (ori, ps) -> do

205218 singletonHeader

206− (case ori of

207− Forward -> "Removed paths"

208− Backward -> "Added paths")

219+ ( case ori of

220+ Forward -> "Removed paths"

221+ Backward -> "Added paths"

222+ )

209223 $ singletonBody $

210224 bulletList $

211225 ps <&> \case

@@ -249,52 +263,54 @@ jets =

249263 unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."

250264 unwrapReportJetResult (Free f) = f

251265

252− jsonPathJet

253− :: NonEmpty

254− ( Union

255− '[ Behave 'SchemaLevel 'TypedSchemaLevel

256− , Behave 'TypedSchemaLevel 'SchemaLevel

257− ]

258− )

259− -> Inlines

266+ jsonPathJet ::

267+ NonEmpty

268+ ( Union

269+ '[ Behave 'SchemaLevel 'TypedSchemaLevel

270+ , Behave 'TypedSchemaLevel 'SchemaLevel

271+ ]

272+ ) ->

273+ Inlines

260274 jsonPathJet x = code $ "$" <> showParts (NE.toList x)

261275 where

262− showParts

263− :: [ Union

264− '[ Behave 'SchemaLevel 'TypedSchemaLevel

265− , Behave 'TypedSchemaLevel 'SchemaLevel

266− ]

267− ]

268− -> Text

276+ showParts ::

277+ [ Union

278+ '[ Behave 'SchemaLevel 'TypedSchemaLevel

279+ , Behave 'TypedSchemaLevel 'SchemaLevel

280+ ]

281+ ] ->

282+ Text

269283 showParts [] = mempty

270284 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs

271285 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs

272286 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs

273287 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs

274288 showParts (y : ys) =

275− ((\(OfType t) -> "(" <> describeJSONType t <> ")")

276− @@> (\case

277− InItems -> "[*]"

278− InItem i -> "[" <> T.pack (show i) <> "]"

279− InProperty p -> "." <> p

280− InAdditionalProperty -> ".*")

281− @@> typesExhausted)

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

282298 y

283299 <> showParts ys

284300

285−observeJetShowErrs

286− :: ReportJet' Behave (Maybe Inlines)

287− -> P.PathsPrefixTree Behave AnIssue a

288− -> (Report, P.PathsPrefixTree Behave AnIssue a)

301+observeJetShowErrs ::

302+ ReportJet' Behave (Maybe Inlines) ->

303+ P.PathsPrefixTree Behave AnIssue a ->

304+ (Report, P.PathsPrefixTree Behave AnIssue a)

289305observeJetShowErrs jet p = case observeJetShowErrs' jet p of

290306 Just m -> m

291307 Nothing -> (mempty, p)

292308

293−observeJetShowErrs'

294− :: forall a.

295− ReportJet' Behave (Maybe Inlines)

296− -> P.PathsPrefixTree Behave AnIssue a

297− -> Maybe (Report, P.PathsPrefixTree Behave AnIssue a)

309+observeJetShowErrs' ::

310+ forall a.

311+ ReportJet' Behave (Maybe Inlines) ->

312+ P.PathsPrefixTree Behave AnIssue a ->

313+ Maybe (Report, P.PathsPrefixTree Behave AnIssue a)

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

299315 let results =

300316 subIssues >>= \(WrapTypeable (AStep m)) ->

@@ -302,21 +318,23 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)

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

303319 jet @_ @_ @[] bhv

304320 & mapMaybe

305− (\case

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

307− Pure (Just h) ->

308− if P.null subErrs

309− then Just mempty

310− else Just (singletonHeader h (showErrs subErrs), mempty)

311− Pure Nothing -> Nothing)

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

312329 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $

313330 if any isRight results

314331 then

315332 Just $

316333 foldMap

317− (\case

318− Left e -> (mempty, e)

319− Right m -> m)

334+ ( \case

335+ Left e -> (mempty, e)

336+ Right m -> m

337+ )

320338 results

321339 else Nothing

322340

@@ -339,8 +357,9 @@ buildReport cfg = case treeStyle cfg of

339357 body rprt

340358 <> foldOMapWithKey

341359 (headers rprt)

342− (\k v ->

343− header level k <> subBuilder v)

360+ ( \k v ->

361+ header level k <> subBuilder v

362+ )

344363 where

345364 subBuilder = headerStyleBuilder (level + 1)

346365

@@ -349,16 +368,17 @@ buildReport cfg = case treeStyle cfg of

349368 body rprt

350369 <> foldOMapWithKey

351370 (headers rprt)

352− (\k v ->

353− if (OM.size . headers $ rprt) < 2

354− then para k <> blockQuote (subBuilder v)

355− else

356− rawHtml "<details>"

357− <> rawHtml "<summary>"

358− <> plain k

359− <> rawHtml "</summary>"

360− <> blockQuote (subBuilder v)

361− <> rawHtml "</details>")

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

362382 where

363383 subBuilder = foldingStyleBuilder

364384

src/Data/OpenApi/Compare/Report/Html/Template.hs+2−2

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

11{-# LANGUAGE TemplateHaskell #-}

22

33module Data.OpenApi.Compare.Report.Html.Template

4− ( template

4+ ( template,

55 )

66where

77

@@ -36,4 +36,4 @@ template =

3636 \</html>"

3737

3838awsmCss :: ByteString

39−awsmCss = $(makeRelativeToProject "awsm-css/dist/awsm.min.css" >>= embedFile)

39+awsmCss = $(makeRelativeToProject "css/awsm.min.css" >>= embedFile)

src/Data/OpenApi/Compare/Report/Jet.hs+4−4

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

11module Data.OpenApi.Compare.Report.Jet

2− ( ReportJet (..)

3− , ReportJet'

4− , ConstructReportJet (..)

5− , ReportJetResult

2+ ( ReportJet (..),

3+ ReportJet',

4+ ConstructReportJet (..),

5+ ReportJetResult,

66 )

77where

88

src/Data/OpenApi/Compare/Run.hs+4−4

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

11module Data.OpenApi.Compare.Run

2− ( runChecker

3− , runReport

4− , module Data.OpenApi.Compare.Report

2+ ( runChecker,

3+ runReport,

4+ module Data.OpenApi.Compare.Report,

55 )

66where

77

88import Data.HList

99import Data.OpenApi (OpenApi)

10−import Text.Pandoc.Builder

1110import Data.OpenApi.Compare.Paths

1211import Data.OpenApi.Compare.Report

1312import Data.OpenApi.Compare.Subtree

1413import Data.OpenApi.Compare.Validate.OpenApi ()

14+import Text.Pandoc.Builder

1515

1616runChecker :: (OpenApi, OpenApi) -> CheckerOutput

1717runChecker (client, server) =

src/Data/OpenApi/Compare/Subtree.hs+122−120

@@ -1,52 +1,52 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module 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

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,

3333

3434 -- * Structural helpers

35− , structuralMaybe

36− , structuralMaybeWith

37− , structuralEq

38− , iohmStructural

39− , iohmStructuralWith

40− , structuralList

35+ structuralMaybe,

36+ structuralMaybeWith,

37+ structuralEq,

38+ iohmStructural,

39+ iohmStructuralWith,

40+ structuralList,

4141

4242 -- * Reexports

43− , (>>>)

44− , (<<<)

45− , extract

46− , ask

47− , local

48− , step

49− , Typeable

43+ (>>>),

44+ (<<<),

45+ extract,

46+ ask,

47+ local,

48+ step,

49+ Typeable,

5050 )

5151where

5252

@@ -115,10 +115,10 @@ orientProdCons :: Orientation -> ProdCons x -> ProdCons x

115115orientProdCons Forward x = x

116116orientProdCons Backward (ProdCons p c) = ProdCons c p

117117

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)

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)

122122swapProdCons f e (ProdCons p c) =

123123 invertIssueOrientation $

124124 f (swapEnvRoles e) (ProdCons c p)

@@ -153,8 +153,8 @@ instance Applicative ProdCons where

153153 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)

154154

155155newtype CompatM a = CompatM

156− { unCompatM

157− :: StateT (MemoState VarRef) Identity a

156+ { unCompatM ::

157+ StateT (MemoState VarRef) Identity a

158158 }

159159 deriving newtype

160160 ( Functor

@@ -183,64 +183,64 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where

183183 type CheckEnv t :: [Type]

184184 type SubtreeLevel t :: BehaviorLevel

185185

186− checkStructuralCompatibility

187− :: HList (CheckEnv t)

188− -> ProdCons (Traced t)

189− -> StructuralCompatFormula ()

186+ checkStructuralCompatibility ::

187+ HList (CheckEnv t) ->

188+ ProdCons (Traced t) ->

189+ StructuralCompatFormula ()

190190

191− checkSemanticCompatibility

192− :: HList (CheckEnv t)

193− -> Behavior (SubtreeLevel t)

194− -> ProdCons (Traced t)

195− -> SemanticCompatFormula ()

191+ checkSemanticCompatibility ::

192+ HList (CheckEnv t) ->

193+ Behavior (SubtreeLevel t) ->

194+ ProdCons (Traced t) ->

195+ SemanticCompatFormula ()

196196

197197{-# WARNING checkStructuralCompatibility "You should not be calling this directly. Use 'checkSubstructure'" #-}

198198

199199{-# WARNING checkSemanticCompatibility "You should not be calling this directly. Use 'checkCompatibility'" #-}

200200

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

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

208208checkCompatibility bhv e = memo bhv SemanticMemoKey $ \pc ->

209209 case runCompatFormula $ checkSubstructure e pc of

210210 Left _ -> checkSemanticCompatibility (reassemble e) bhv pc

211211 Right () -> pure ()

212212{-# INLINE checkCompatibility #-}

213213

214−checkSubstructure

215− :: (ReassembleHList xs (CheckEnv t), Subtree t)

216− => HList xs

217− -> ProdCons (Traced t)

218− -> StructuralCompatFormula ()

214+checkSubstructure ::

215+ (ReassembleHList xs (CheckEnv t), Subtree t) =>

216+ HList xs ->

217+ ProdCons (Traced t) ->

218+ StructuralCompatFormula ()

219219checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility (reassemble e)

220220{-# INLINE checkSubstructure #-}

221221

222−structuralMaybe

223− :: (Subtree a, ReassembleHList xs (CheckEnv a))

224− => HList xs

225− -> ProdCons (Maybe (Traced a))

226− -> StructuralCompatFormula ()

222+structuralMaybe ::

223+ (Subtree a, ReassembleHList xs (CheckEnv a)) =>

224+ HList xs ->

225+ ProdCons (Maybe (Traced a)) ->

226+ StructuralCompatFormula ()

227227structuralMaybe e = structuralMaybeWith (checkSubstructure e)

228228{-# INLINE structuralMaybe #-}

229229

230−structuralMaybeWith

231− :: (ProdCons a -> StructuralCompatFormula ())

232− -> ProdCons (Maybe a)

233− -> StructuralCompatFormula ()

230+structuralMaybeWith ::

231+ (ProdCons a -> StructuralCompatFormula ()) ->

232+ ProdCons (Maybe a) ->

233+ StructuralCompatFormula ()

234234structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b

235235structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()

236236structuralMaybeWith _ _ = structuralIssue

237237{-# INLINE structuralMaybeWith #-}

238238

239−structuralList

240− :: (Subtree a, ReassembleHList xs (CheckEnv a))

241− => HList xs

242− -> ProdCons [Traced a]

243− -> StructuralCompatFormula ()

239+structuralList ::

240+ (Subtree a, ReassembleHList xs (CheckEnv a)) =>

241+ HList xs ->

242+ ProdCons [Traced a] ->

243+ StructuralCompatFormula ()

244244structuralList _ (ProdCons [] []) = pure ()

245245structuralList e (ProdCons (a : aa) (b : bb)) = do

246246 checkSubstructure e $ ProdCons a b

@@ -253,11 +253,11 @@ structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula (

253253structuralEq (ProdCons a b) = if extract a == extract b then pure () else structuralIssue

254254{-# INLINE structuralEq #-}

255255

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

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

261261iohmStructural e =

262262 iohmStructuralWith (\k -> checkSubstructure (k `HCons` e))

263263{-# INLINE iohmStructural #-}

@@ -266,25 +266,26 @@ instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMa

266266 data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k

267267 deriving stock (Eq, Ord, Show)

268268

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

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

274274iohmStructuralWith f pc = do

275275 let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys . extract <$> pc

276276 if pEKeys == cEKeys

277277 then

278278 for_

279279 pEKeys

280− (\eKey ->

281− f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc)

280+ ( \eKey ->

281+ f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc

282+ )

282283 else structuralIssue

283284{-# INLINE iohmStructuralWith #-}

284285

285−runCompatFormula

286− :: CompatFormula' q f r a

287− -> Either (P.PathsPrefixTree q f r) a

286+runCompatFormula ::

287+ CompatFormula' q f r a ->

288+ Either (P.PathsPrefixTree q f r) a

288289runCompatFormula (Compose f) =

289290 calculate . runIdentity . runMemo 0 . unCompatM $ f

290291{-# INLINE runCompatFormula #-}

@@ -314,27 +315,27 @@ invertIssueOrientationP = P.map (\(AnIssue ori i) -> AnIssue (toggleOrientation

314315structuralIssue :: StructuralCompatFormula a

315316structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy

316317

317−anyOfAt

318− :: Issuable l

319− => Paths q r l

320− -> Issue l

321− -> [CompatFormula' q AnIssue r a]

322− -> CompatFormula' q AnIssue r a

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

323324anyOfAt _ _ [x] = x

324325anyOfAt xs issue fs =

325326 Compose $ (`eitherOf` AnItem xs (anIssue issue)) <$> traverse getCompose fs

326327

327328-- | If the given formula contains any issues, add another issue on top. Otherwise succeed.

328−clarifyIssue

329− :: AnItem q AnIssue r

330− -> CompatFormula' q AnIssue r a

331− -> CompatFormula' q AnIssue r a

329+clarifyIssue ::

330+ AnItem q AnIssue r ->

331+ CompatFormula' q AnIssue r a ->

332+ CompatFormula' q AnIssue r a

332333clarifyIssue item f =

333334 Compose ((`eitherOf` item) <$> pure <$> getCompose f) *> f

334335

335−fixpointKnot

336− :: MonadState (MemoState VarRef) m

337− => KnotTier (FormulaF q f r ()) VarRef m

336+fixpointKnot ::

337+ MonadState (MemoState VarRef) m =>

338+ KnotTier (FormulaF q f r ()) VarRef m

338339fixpointKnot =

339340 KnotTier

340341 { onKnotFound = modifyMemoNonce succ

@@ -342,19 +343,20 @@ fixpointKnot =

342343 , tieKnot = \i x -> pure $ maxFixpoint i x

343344 }

344345

345−memo

346− :: (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a)

347− => Paths q r l

348− -> MemoKey

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

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

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

351352memo bhv k f pc = Compose $ do

352353 formula' <-

353354 memoWithKnot

354355 fixpointKnot

355− (do

356− formula <- getCompose $ f pc

357− pure $ mapErrors (P.takeSubtree bhv) formula)

356+ ( do

357+ formula <- getCompose $ f pc

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

359+ )

358360 (k, ask <$> pc)

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

360362

src/Data/OpenApi/Compare/Validate/MediaTypeObject.hs+2−2

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Validate.MediaTypeObject

4− ( Issue (..)

5− , Behave (..)

4+ ( Issue (..),

5+ Behave (..),

66 )

77where

88

src/Data/OpenApi/Compare/Validate/OAuth2Flows.hs+13−13

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Validate.OAuth2Flows

4− ( Step (..)

5− , Issue (..)

6− , Behave (..)

4+ ( Step (..),

5+ Issue (..),

6+ Behave (..),

77 )

88where

99

@@ -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

src/Data/OpenApi/Compare/Validate/OpenApi.hs+15−13

@@ -3,8 +3,8 @@

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

44

55module Data.OpenApi.Compare.Validate.OpenApi

6− ( Behave (..)

7− , Issue (..)

6+ ( Behave (..),

7+ Issue (..),

88 )

99where

1010

@@ -38,7 +38,8 @@ tracedSecuritySchemes :: Traced OpenApi -> Traced (Definitions SecurityScheme)

3838tracedSecuritySchemes oa =

3939 traced

4040 (ask oa >>> step ComponentsSecurityScheme)

41− (_componentsSecuritySchemes . _openApiComponents . extract $ oa)

41+ (unSecurityDefinitions . _componentsSecuritySchemes . _openApiComponents . extract $ oa)

42+ where unSecurityDefinitions (SecurityDefinitions ds) = ds

4243

4344tracedResponses :: Traced OpenApi -> Traced (Definitions Response)

4445tracedResponses oa =

@@ -79,16 +80,17 @@ instance Subtree OpenApi where

7980 checkSemanticCompatibility _ beh prodCons = do

8081 checkCompatibility @ProcessedPathItems

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

83+ ( (tracedRequestBodies <$> prodCons)

84+ `HCons` (tracedParameters <$> prodCons)

85+ `HCons` (tracedSecuritySchemes <$> prodCons)

86+ `HCons` (tracedResponses <$> prodCons)

87+ `HCons` (tracedHeaders <$> prodCons)

88+ `HCons` (tracedSchemas <$> prodCons)

89+ `HCons` (_openApiServers . extract <$> prodCons)

90+ `HCons` (tracedLinks <$> prodCons)

91+ `HCons` (tracedCallbacks <$> prodCons)

92+ `HCons` HNil

93+ )

9294 (tracedPaths <$> prodCons)

9395

9496instance Steppable OpenApi ProcessedPathItems where

src/Data/OpenApi/Compare/Validate/Operation.hs+26−24

@@ -4,17 +4,17 @@

44

55module Data.OpenApi.Compare.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

@@ -87,10 +87,11 @@ tracedCallbacks (Traced t oper) =

8787 ]

8888

8989-- FIXME: #28

90−getServers

91− :: [Server] -- ^ Servers from env

92− -> MatchedOperation

93− -> [Server]

90+getServers ::

91+ -- | Servers from env

92+ [Server] ->

93+ MatchedOperation ->

94+ [Server]

9495getServers env oper =

9596 case _operationServers . operation $ oper of

9697 [] -> env

@@ -337,9 +338,10 @@ instance Issuable 'APILevel where

337338 deriving stock (Eq, Ord, Show)

338339 issueKind = \case

339340 _ -> CertainIssue

340− relatedIssues = (==) `withClass` \case

341− NoPathsMatched fp -> Just fp

342− AllPathsFailed fp -> Just fp

341+ relatedIssues =

342+ (==) `withClass` \case

343+ NoPathsMatched fp -> Just fp

344+ AllPathsFailed fp -> Just fp

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

344346 describeIssue Backward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been added."

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

@@ -434,10 +436,10 @@ tracedFragments mpi =

434436 | (i, x) <- L.zip [0 ..] $ pathFragments $ extract mpi

435437 ]

436438

437−tracedMethod

438− :: OperationMethod

439− -> Traced MatchedPathItem

440− -> Maybe (Traced' MatchedOperation Operation)

439+tracedMethod ::

440+ OperationMethod ->

441+ Traced MatchedPathItem ->

442+ Maybe (Traced' MatchedOperation Operation)

441443tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)

442444

443445instance Issuable 'PathLevel where

@@ -485,10 +487,10 @@ instance Subtree MatchedPathItem where

485487 checkSemanticCompatibility env beh prodCons = do

486488 let paramDefs = getH @(ProdCons (Traced (Definitions Param))) env

487489 pathTracedParams = getPathParams <$> paramDefs <*> prodCons

488− getPathParams

489− :: Traced (Definitions Param)

490− -> Traced MatchedPathItem

491− -> [Traced Param]

490+ getPathParams ::

491+ Traced (Definitions Param) ->

492+ Traced MatchedPathItem ->

493+ [Traced Param]

492494 getPathParams defs mpi = do

493495 paramRef <- tracedMatchedPathItemParameters mpi

494496 pure $ dereference defs paramRef

src/Data/OpenApi/Compare/Validate/Param.hs+9−7

@@ -2,8 +2,8 @@

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

33

44module Data.OpenApi.Compare.Validate.Param

5− ( Behave (..)

6− , Issue (..)

5+ ( Behave (..),

6+ Issue (..),

77 )

88where

99

@@ -79,7 +79,7 @@ instance Issuable 'PathFragmentLevel where

7979 describeIssue _ ParamPlaceIncompatible = para "Parameters in incompatible locations."

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

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

82− describeIssue ori (PathFragmentsDontMatch (orientProdCons ori -> ProdCons e a)) =

82+ describeIssue ori (PathFragmentsDontMatch (orientProdCons ori -> ProdCons e a)) =

8383 para $ "Parameter changed from " <> code e <> " to " <> code a <> "."

8484

8585instance Behavable 'PathFragmentLevel 'SchemaLevel where

@@ -106,15 +106,17 @@ instance Subtree Param where

106106 when (_paramName (extract p) /= _paramName (extract c)) $

107107 issueAt beh ParamNameMismatch

108108 when

109− ((fromMaybe False . _paramRequired . extract $ c)

110− && not (fromMaybe False . _paramRequired . extract $ p))

109+ ( (fromMaybe False . _paramRequired . extract $ c)

110+ && not (fromMaybe False . _paramRequired . extract $ p)

111+ )

111112 $ issueAt beh ParamRequired

112113 case (_paramIn . extract $ p, _paramIn . extract $ c) of

113114 (ParamQuery, ParamQuery) -> do

114115 -- Emptiness is only for query params

115116 when

116− ((fromMaybe False . _paramAllowEmptyValue . extract $ p)

117− && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))

117+ ( (fromMaybe False . _paramAllowEmptyValue . extract $ p)

118+ && not (fromMaybe False . _paramAllowEmptyValue . extract $ c)

119+ )

118120 $ issueAt beh ParamEmptinessIncompatible

119121 (a, b) | a == b -> pure ()

120122 _ -> issueAt beh ParamPlaceIncompatible

src/Data/OpenApi/Compare/Validate/PathFragment.hs+3−4

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

11module Data.OpenApi.Compare.Validate.PathFragment

2− ( parsePath

3− , PathFragment (..)

4− , PathFragmentParam

2+ ( parsePath,

3+ PathFragment (..),

4+ PathFragmentParam,

55 )

66where

77

@@ -12,7 +12,6 @@ import Data.OpenApi.Compare.Subtree

1212import Data.OpenApi.Compare.Validate.Param

1313import Data.Text (Text)

1414import qualified Data.Text as T

15−import Data.Typeable

1615

1716-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.

1817-- #23

src/Data/OpenApi/Compare/Validate/Products.hs+27−28

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

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−

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

1514module Data.OpenApi.Compare.Validate.Products

16− ( checkProducts

17− , ProductLike(..)

18− ) where

15+ ( checkProducts,

16+ ProductLike (..),

17+ )

18+where

1919

2020import Data.Foldable

2121import Data.Map.Strict (Map)

@@ -30,20 +30,19 @@ data ProductLike a = ProductLike

3030 , required :: Bool

3131 }

3232

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

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

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

4242 case M.lookup key p of

4343 Nothing -> case required consElt of

44− True -> issueAt xs $ noElt key

44+ True -> issueAt xs $ noElt key

4545 False -> pure ()

4646 Just prodElt -> do

47− let

48− elts = ProdCons prodElt consElt

47+ let elts = ProdCons prodElt consElt

4948 check key (productValue <$> elts)

src/Data/OpenApi/Compare/Validate/RequestBody.hs+2−2

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Validate.RequestBody

4− ( Issue (..)

5− , Behave (..)

4+ ( Issue (..),

5+ Behave (..),

66 )

77where

88

src/Data/OpenApi/Compare/Validate/Responses.hs+1−1

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

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

33

44module Data.OpenApi.Compare.Validate.Responses

5− ( Behave (..)

5+ ( Behave (..),

66 )

77where

88

src/Data/OpenApi/Compare/Validate/Schema.hs+77−98

@@ -1,18 +1,19 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

2+

23module Data.OpenApi.Compare.Validate.Schema

34 (

45 )

56where

67

7−import Control.Monad.Writer

8+import Control.Monad (when,unless)

89import qualified Data.Aeson as A

910import Data.Coerce

1011import Data.Foldable (for_, toList)

1112import Data.Functor

1213import Data.HList

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

1315import qualified Data.List.NonEmpty as NE

1416import qualified Data.Map as M

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

1617import Data.Maybe

1718import Data.OpenApi

1819import Data.OpenApi.Compare.Behavior

@@ -22,24 +23,24 @@ import Data.OpenApi.Compare.Subtree

2223import Data.OpenApi.Compare.Validate.Schema.DNF

2324import Data.OpenApi.Compare.Validate.Schema.Issues

2425import Data.OpenApi.Compare.Validate.Schema.JsonFormula

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

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

2726import Data.OpenApi.Compare.Validate.Schema.Partition

2827import Data.OpenApi.Compare.Validate.Schema.Process

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

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

2930import Data.Ord

3031import Data.Ratio

3132import Data.Semigroup

3233import qualified Data.Set as S

3334import Data.Text (Text)

3435

35−checkFormulas

36− :: (ReassembleHList xs (CheckEnv (Referenced Schema)))

37− => HList xs

38− -> Behavior 'SchemaLevel

39− -> ProdCons (Trace Schema)

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

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

42− -> SemanticCompatFormula ()

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

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

4445 case P.toList ep ++ P.toList ec of

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

@@ -144,21 +145,21 @@ checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =

144145 EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?

145146 issueFromDisjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> S.toList ps

146147

147−checkContradiction

148− :: Behavior 'TypedSchemaLevel

149− -> Maybe Partition

150− -> S.Set (Condition t)

151− -> SemanticCompatFormula ()

148+checkContradiction ::

149+ Behavior 'TypedSchemaLevel ->

150+ Maybe Partition ->

151+ S.Set (Condition t) ->

152+ SemanticCompatFormula ()

152153checkContradiction beh mPart _ = issueAt beh $ maybe TypeBecomesEmpty PartitionBecomesEmpty mPart -- TODO #70

153154

154−checkImplication

155− :: (ReassembleHList xs (CheckEnv (Referenced Schema)))

156− => HList xs

157− -> Behavior 'TypedSchemaLevel

158− -> ProdCons (Trace Schema) -- the traces of the root schemas used in this comparison

159− -> S.Set (Condition t)

160− -> Condition t

161− -> SemanticCompatFormula ()

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

162163checkImplication env beh trs prods cons = case findExactly prods of

163164 Just e

164165 | all (satisfiesTyped e) prods ->

@@ -166,124 +167,104 @@ checkImplication env beh trs prods cons = case findExactly prods of

166167 then pure ()

167168 else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

168169 | otherwise -> pure () -- vacuously true

169−

170170 Nothing -> case cons of

171171 -- the above code didn't catch it, so there's no Exactly condition on the lhs

172172 Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)

173−

174173 Maximum m -> foldCheck min m NoMatchingMaximum MatchingMaximumWeak $ \case

175174 Maximum m' -> Just m'

176175 _ -> Nothing

177−

178176 Minimum m -> foldCheck max m (NoMatchingMinimum . coerce) (MatchingMinimumWeak . coerce) $ \case

179177 Minimum m' -> Just m'

180178 _ -> Nothing

181−

182179 MultipleOf m -> foldCheck lcmScientific m NoMatchingMultipleOf MatchingMultipleOfWeak $ \case

183180 MultipleOf m' -> Just m'

184181 _ -> Nothing

185−

186182 NumberFormat f -> case flip any prods $ \case

187− NumberFormat f' -> f == f'

188− _ -> False

189− of

183+ NumberFormat f' -> f == f'

184+ _ -> False of

190185 True -> pure ()

191186 False -> issueAt beh (NoMatchingFormat f)

192−

193187 MaxLength m -> foldCheck min m NoMatchingMaxLength MatchingMaxLengthWeak $ \case

194188 MaxLength m' -> Just m'

195189 _ -> Nothing

196−

197190 MinLength m -> foldCheck max m NoMatchingMinLength MatchingMinLengthWeak $ \case

198191 MinLength m' -> Just m'

199192 _ -> Nothing

200−

201193 Pattern p -> case flip any prods $ \case

202− Pattern p' -> p == p'

203− _ -> False

204− of

194+ Pattern p' -> p == p'

195+ _ -> False of

205196 True -> pure ()

206197 False -> issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32

207−

208198 StringFormat f -> case flip any prods $ \case

209− StringFormat f' -> f == f'

210− _ -> False

211− of

199+ StringFormat f' -> f == f'

200+ _ -> False of

212201 True -> pure ()

213202 False -> issueAt beh (NoMatchingFormat f)

214−

215203 Items _ cons' -> case foldSome (<>) prods $ \case

216− Items _ rs -> Just (Just (rs NE.:| []), mempty)

217− TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))

218− _ -> Nothing

219− of

204+ Items _ rs -> Just (Just (rs NE.:| []), mempty)

205+ TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))

206+ _ -> Nothing of

220207 Just (mItems, Just pfs)

221208 | not $ allSame (length <$> pfs) -> pure () -- vacuously

222− | let plen = genericLength (NE.head pfs)

223− -> clarifyIssue (AnItem beh (anIssue TupleToArray)) $ for_ [0 .. plen - 1] $ \i -> do

224− let prod' = tracedConjunct $ case mItems of

225− Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'

226− Nothing -> (`genericIndex` i) <$> pfs

227− checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'

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'

228216 Just (Just prods', Nothing) -> do

229217 let prod' = tracedConjunct prods'

230218 checkCompatibility (beh >>> step InItems) env $ ProdCons prod' cons'

231219 _ -> clarifyIssue (AnItem beh (anIssue NoMatchingItems)) $ do

232220 checkCompatibility (beh >>> step InItems) env $ ProdCons prodTopSchema cons'

233−

234221 TupleItems (map snd -> fs) -> case foldSome (<>) prods $ \case

235− TupleItems (map snd -> fs') -> Just (Just $ fs' NE.:| [], Just . Max $ genericLength fs', Just . Min $ genericLength fs', mempty)

236− MinItems m' -> Just (mempty, Just . Max $ m', mempty, mempty)

237− MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)

238− Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))

239− _ -> Nothing

240− of

241− -- if the length constraints in the producer are contradictory:

242− Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()

243− -- We have an explicit tuple items clause...

244− Just (Just pfs, Just (Max plen), _, _)

245− | plen /= genericLength fs -- ...of wrong length

246− -> issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

247− | otherwise

248− -> for_ [0 .. plen - 1] $ \i -> do

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

249235 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct $ (`genericIndex` i) <$> pfs) (fs `genericIndex` i)

250− -- We have a fixed length array in the producer...

251− Just (Nothing, Just (Max plen), Just (Min plen'), mProd)

252− | plen == plen'

253− -> clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of

254− _ | plen /= genericLength fs -> -- ...of wrong length

255− issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

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

256243 Just rs -> for_ [0 .. plen - 1] $ \i -> do

257244 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct rs) (fs `genericIndex` i)

258245 -- ...and no "items" schema

259246 Nothing -> clarifyIssue (AnItem beh (anIssue NoMatchingTupleItems)) $ do

260247 for_ [0 .. plen - 1] $ \i -> do

261248 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prodTopSchema (fs `genericIndex` i)

262− _ -> issueAt beh NoMatchingTupleItems

263−

249+ _ -> issueAt beh NoMatchingTupleItems

264250 MaxItems m -> foldCheck min m NoMatchingMaxItems MatchingMaxItemsWeak $ \case

265251 MaxItems m' -> Just m'

266252 TupleItems fs -> Just $ toInteger $ length fs

267253 _ -> Nothing

268−

269254 MinItems m -> foldCheck max m NoMatchingMinItems MatchingMinItemsWeak $ \case

270255 MinItems m' -> Just m'

271256 TupleItems fs -> Just $ toInteger $ length fs

272257 _ -> Nothing

273−

274258 UniqueItems -> case flip any prods $ \case

275− UniqueItems -> True

276− MaxItems 1 -> True

277− TupleItems fs | length fs == 1 -> True

278− _ -> False

279− of

259+ UniqueItems -> True

260+ MaxItems 1 -> True

261+ TupleItems fs | length fs == 1 -> True

262+ _ -> False of

280263 True -> pure ()

281264 False -> issueAt beh NoMatchingUniqueItems

282−

283265 Properties props _ madd -> case foldSome (<>) prods $ \case

284− Properties props' _ madd' -> Just $ (props', madd') NE.:| []

285− _ -> Nothing

286− of

266+ Properties props' _ madd' -> Just $ (props', madd') NE.:| []

267+ _ -> Nothing of

287268 Just pm ->

288269 anyOfAt beh NoMatchingProperties $ -- TODO: could first "concat" the lists

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

@@ -314,11 +295,9 @@ checkImplication env beh trs prods cons = case findExactly prods of

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

315296 pure ()

316297 Nothing -> issueAt beh NoMatchingProperties

317−

318298 MaxProperties m -> foldCheck min m NoMatchingMaxProperties MatchingMaxPropertiesWeak $ \case

319299 MaxProperties m' -> Just m'

320300 _ -> Nothing

321−

322301 MinProperties m -> foldCheck max m NoMatchingMinProperties MatchingMinPropertiesWeak $ \case

323302 MinProperties m' -> Just m'

324303 _ -> Nothing

@@ -326,14 +305,14 @@ checkImplication env beh trs prods cons = case findExactly prods of

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

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

328307

329− foldCheck

330− :: Eq a

331− => (a -> a -> a)

332− -> a

333− -> (a -> Issue 'TypedSchemaLevel)

334− -> (ProdCons a -> Issue 'TypedSchemaLevel)

335− -> (forall t. Condition t -> Maybe a)

336− -> SemanticCompatFormula ()

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

337316 foldCheck f m missing weak extr = case foldSome f prods extr of

338317 Just m'

339318 | f m' m == m' -> pure ()

src/Data/OpenApi/Compare/Validate/Schema/DNF.hs+8−8

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

11module 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

2+ ( DNF (..),

3+ Disjunct (..),

4+ pattern SingleDisjunct,

5+ pattern TopDNF,

6+ pattern BottomDNF,

7+ pattern LiteralDNF,

8+ foldDNF,

9+ forDNF,

1010 )

1111where

1212

src/Data/OpenApi/Compare/Validate/Schema/Issues.hs+53−51

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Validate.Schema.Issues

4− ( Issue (..)

5− , Behave (..)

4+ ( Issue (..),

5+ Behave (..),

66 )

77where

88

@@ -100,53 +100,54 @@ instance Issuable 'TypedSchemaLevel where

100100 TypeBecomesEmpty -> ProbablyIssue -- TODO: #70

101101 PartitionBecomesEmpty _ -> ProbablyIssue -- ditto

102102 _ -> CertainIssue

103− relatedIssues = (==) `withClass` \case

103+ relatedIssues =

104+ (==) `withClass` \case

104105 EnumDoesntSatisfy v -> Just v

105106 NoMatchingEnum v -> Just v

106107 _ -> Nothing

107− `withClass` \case

108− NoMatchingMaximum _ -> Just ()

109− MatchingMaximumWeak _ -> Just ()

110− _ -> Nothing

111− `withClass` \case

112− NoMatchingMinimum _ -> Just ()

113− MatchingMinimumWeak _ -> Just ()

114− _ -> Nothing

115− `withClass` \case

116− NoMatchingMultipleOf _ -> Just ()

117− MatchingMultipleOfWeak _ -> Just ()

118− _ -> Nothing

119− `withClass` \case

120− NoMatchingMaxLength _ -> Just ()

121− MatchingMaxLengthWeak _ -> Just ()

122− _ -> Nothing

123− `withClass` \case

124− NoMatchingMinLength _ -> Just ()

125− MatchingMinLengthWeak _ -> Just ()

126− _ -> Nothing

127− `withClass` \case

128− NoMatchingItems -> Just ()

129− ArrayToTuple -> Just ()

130− TupleToArray -> Just ()

131− NoMatchingTupleItems -> Just ()

132− TupleItemsLengthChanged _ -> Just ()

133− _ -> Nothing

134− `withClass` \case

135− NoMatchingMaxItems _ -> Just ()

136− MatchingMaxItemsWeak _ -> Just ()

137− _ -> Nothing

138− `withClass` \case

139− NoMatchingMinItems _ -> Just ()

140− MatchingMinItemsWeak _ -> Just ()

141− _ -> Nothing

142− `withClass` \case

143− NoMatchingMaxProperties _ -> Just ()

144− MatchingMaxPropertiesWeak _ -> Just ()

145− _ -> Nothing

146− `withClass` \case

147− NoMatchingMinProperties _ -> Just ()

148− MatchingMinPropertiesWeak _ -> Just ()

149− _ -> 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

150151 describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v

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

152153 describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v

@@ -254,14 +255,15 @@ instance Issuable 'SchemaLevel where

254255 PropertyToAdditional -> Comment

255256 TypesRestricted _ -> ProbablyIssue -- TODO: #70

256257 _ -> CertainIssue

257− relatedIssues = (==) `withClass` \case

258+ relatedIssues =

259+ (==) `withClass` \case

258260 AdditionalToProperty -> Just ()

259261 PropertyToAdditional -> Just ()

260262 _ -> Nothing

261− `withClass` \case

262− PropertyNowRequired -> Just ()

263− UnexpectedProperty -> Just ()

264− _ -> Nothing

263+ `withClass` \case

264+ PropertyNowRequired -> Just ()

265+ UnexpectedProperty -> Just ()

266+ _ -> Nothing

265267 describeIssue _ (NotSupported i) =

266268 para (emph "Encountered a feature that CompaREST does not support: " <> text i <> ".")

267269 describeIssue _ OneOfNotDisjoint =

src/Data/OpenApi/Compare/Validate/Schema/JsonFormula.hs+56−48

@@ -1,26 +1,27 @@

11module 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

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,

1616 )

1717where

1818

1919import Algebra.Lattice

2020import qualified Data.Aeson as A

21+import qualified Data.Aeson.Key as Key

22+import qualified Data.Aeson.KeyMap as KeyMap

2123import qualified Data.ByteString.Lazy as BSL

2224import qualified Data.Foldable as F

23−import qualified Data.HashMap.Strict as HM

2425import Data.Functor

2526import Data.Int

2627import Data.Kind

@@ -39,7 +40,7 @@ import Data.Text (Text)

3940import qualified Data.Text as T

4041import qualified Data.Text.Encoding as T

4142import Data.Typeable

42−import Text.Pandoc.Builder hiding (Format, Null)

43+import Text.Pandoc.Builder hiding (Format)

4344import Text.Regex.Pcre2

4445

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

@@ -67,30 +68,33 @@ data Property = Property

6768data Condition :: JsonType -> Type where

6869 Exactly :: TypedValue t -> Condition t

6970 Maximum :: !(Bound Scientific) -> Condition 'Number

70− Minimum

71− :: !(Down (Bound (Down Scientific)))

72− -> Condition 'Number -- ^ this has the right Ord

71+ Minimum ::

72+ !(Down (Bound (Down Scientific))) ->

73+ -- | this has the right Ord

74+ Condition 'Number

7375 MultipleOf :: !Scientific -> Condition 'Number

7476 NumberFormat :: !Format -> Condition 'Number

7577 MaxLength :: !Integer -> Condition 'String

7678 MinLength :: !Integer -> Condition 'String

7779 Pattern :: !Pattern -> Condition 'String

7880 StringFormat :: !Format -> Condition 'String

79− Items

80− :: !(ForeachType JsonFormula)

81− -> !(Traced (Referenced Schema))

82− -> Condition 'Array

83− TupleItems

84− :: ![(ForeachType JsonFormula, Traced (Referenced Schema))]

85− -> Condition 'Array

81+ Items ::

82+ !(ForeachType JsonFormula) ->

83+ !(Traced (Referenced Schema)) ->

84+ Condition 'Array

85+ TupleItems ::

86+ ![(ForeachType JsonFormula, Traced (Referenced Schema))] ->

87+ Condition 'Array

8688 MaxItems :: !Integer -> Condition 'Array

8789 MinItems :: !Integer -> Condition 'Array

8890 UniqueItems :: Condition 'Array

89− Properties

90− :: !(M.Map Text Property)

91− -> !(ForeachType JsonFormula) -- ^ formula for additional properties

92− -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom

93− -> Condition 'Object

91+ Properties ::

92+ !(M.Map Text Property) ->

93+ -- | formula for additional properties

94+ !(ForeachType JsonFormula) ->

95+ -- | schema for additional properties, Nothing means bottom

96+ !(Maybe (Traced (Referenced Schema))) ->

97+ Condition 'Object

9498 MaxProperties :: !Integer -> Condition 'Object

9599 MinProperties :: !Integer -> Condition 'Object

96100

@@ -118,13 +122,15 @@ showCondition = \case

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

119123 (Properties props additional _) ->

120124 bulletList $

121− (M.toList props

122− <&> (\(k, p) ->

123− para (code k)

124− <> para (strong $ if propRequired p then "Required" else "Optional")

125− <> showForEachJsonFormula (propFormula p)))

125+ ( M.toList props

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

127+ para (code k)

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

129+ <> showForEachJsonFormula (propFormula p)

130+ )

131+ )

126132 <> [ para (emph "Additional properties")

127− <> showForEachJsonFormula additional

133+ <> showForEachJsonFormula additional

128134 ]

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

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

@@ -133,15 +139,17 @@ showCondition = \case

133139 showForEachJsonFormula i =

134140 bulletList $

135141 foldType

136− (\t f -> case getJsonFormula $ f i of

137− BottomDNF -> mempty

138− (DNF conds) ->

142+ ( \t f -> case getJsonFormula $ f i of

143+ BottomDNF -> mempty

144+ (DNF conds) ->

139145 [ para (describeJSONType t)

140146 <> bulletList

141− (S.toList conds <&> \case

142− Disjunct (S.toList -> []) -> para "Empty"

143− Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond))

144− ])

147+ ( S.toList conds <&> \case

148+ Disjunct (S.toList -> []) -> para "Empty"

149+ Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond)

150+ )

151+ ]

152+ )

145153

146154showJSONValue :: A.Value -> Blocks

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

@@ -170,10 +178,10 @@ satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m

170178satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m

171179satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36

172180satisfiesTyped (TObject o) (Properties props additional _) =

173− all (`HM.member` o) (M.keys (M.filter propRequired props))

174− && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)

175−satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m

176−satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m

181+ all (`KeyMap.member` o) (map Key.fromText $ M.keys (M.filter propRequired props))

182+ && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup (Key.toText k) props) (KeyMap.toList o)

183+satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (KeyMap.size o) <= m

184+satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (KeyMap.size o) >= m

177185

178186checkNumberFormat :: Format -> Scientific -> Bool

179187checkNumberFormat "int32" (toRational -> n) =

src/Data/OpenApi/Compare/Validate/Schema/Partition.hs+34−30

@@ -1,21 +1,22 @@

11module 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

2+ ( partitionSchema,

3+ partitionRefSchema,

4+ selectPartition,

5+ runPartitionM,

6+ tryPartition,

7+ showPartition,

8+ intersectSchema,

9+ intersectRefSchema,

10+ IntersectionResult (..),

11+ runIntersectionM,

12+ Partition,

1313 )

1414where

1515

1616import Algebra.Lattice

1717import Algebra.Lattice.Lifted

1818import Control.Applicative

19+import Control.Monad (when)

1920import Control.Monad.Reader hiding (ask)

2021import qualified Control.Monad.Reader as R

2122import Control.Monad.State

@@ -31,6 +32,7 @@ import qualified Data.List as L

3132import qualified Data.List.NonEmpty as NE

3233import qualified Data.Map as M

3334import Data.Maybe

35+import Data.Monoid

3436import Data.OpenApi

3537import Data.OpenApi.Compare.Memo

3638import Data.OpenApi.Compare.References

@@ -43,7 +45,8 @@ import Data.Ord

4345import qualified Data.Set as S

4446import Data.Text (Text)

4547import qualified Data.Text as T

46−import Text.Pandoc.Builder hiding (Format, Null)

48+import Data.Traversable (forM)

49+import Text.Pandoc.Builder hiding (Format)

4750

4851data PartitionData

4952 = DByEnumValue (DNF (S.Set A.Value))

@@ -143,10 +146,11 @@ partitionCondition = \case

143146 Just _ -> top

144147 Nothing ->

145148 singletonPart $

146− DByProperties $ LiteralDNF

147− ( M.keysSet $ M.filter (not . propRequired) props

148− , M.keysSet $ M.filter propRequired props

149− )

149+ DByProperties $

150+ LiteralDNF

151+ ( M.keysSet $ M.filter (not . propRequired) props

152+ , M.keysSet $ M.filter propRequired props

153+ )

150154 inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do

151155 f <- partitionRefSchema $ propRefSchema prop

152156 pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f

@@ -156,10 +160,10 @@ partitionCondition = \case

156160runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a

157161runPartitionM defs = runIdentity . runMemo () . (`runReaderT` defs)

158162

159−partitionJsonFormulas

160− :: ProdCons (Traced (Definitions Schema))

161− -> ProdCons (JsonFormula t)

162− -> Lifted Partitions

163+partitionJsonFormulas ::

164+ ProdCons (Traced (Definitions Schema)) ->

165+ ProdCons (JsonFormula t) ->

166+ Lifted Partitions

163167partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart

164168 where

165169 pcPart = partitionFormula <$> defs <*> pc

@@ -211,11 +215,11 @@ runIntersectionM defs act = case runWriterT $ runReaderT act defs of

211215 Just (x, Any False) -> Same x

212216 Just (x, Any True) -> New x

213217

214−intersectSchema

215− :: PartitionLocation

216− -> PartitionChoice

217− -> Traced Schema

218− -> IntersectionM Schema

218+intersectSchema ::

219+ PartitionLocation ->

220+ PartitionChoice ->

221+ Traced Schema ->

222+ IntersectionM Schema

219223intersectSchema loc part sch = do

220224 allOf' <- forM (tracedAllOf sch) $ \rss ->

221225 -- Assuming i ranges over a nonempty set (checked in processSchema)

@@ -258,11 +262,11 @@ intersectSchema loc part sch = do

258262 pure $ sch' {_schemaEnum = Just enum'}

259263 CByProperties {} -> error "CByProperties not implemented"

260264

261−intersectRefSchema

262− :: PartitionLocation

263− -> PartitionChoice

264− -> Traced (Referenced Schema)

265− -> IntersectionM (Referenced Schema)

265+intersectRefSchema ::

266+ PartitionLocation ->

267+ PartitionChoice ->

268+ Traced (Referenced Schema) ->

269+ IntersectionM (Referenced Schema)

266270intersectRefSchema loc part rs = do

267271 defs <- R.ask

268272 Inline <$> intersectSchema loc part (dereference defs rs)

src/Data/OpenApi/Compare/Validate/Schema/Process.hs+47−48

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

11module Data.OpenApi.Compare.Validate.Schema.Process

2− ( schemaToFormula

2+ ( schemaToFormula,

33 )

44where

55

66import Algebra.Lattice

7−import qualified Control.Monad.Reader as R

87import Control.Monad.Reader hiding (ask)

8+import qualified Control.Monad.Reader as R

99import Control.Monad.State

1010import Control.Monad.Writer

1111import qualified Data.Aeson as A

@@ -13,6 +13,7 @@ import Data.Functor.Identity

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

1414import qualified Data.Map as M

1515import Data.Maybe

16+import Data.Monoid

1617import Data.OpenApi hiding (get)

1718import Data.OpenApi.Compare.Behavior

1819import Data.OpenApi.Compare.Memo

@@ -28,6 +29,7 @@ import Data.OpenApi.Compare.Validate.Schema.Traced

2829import Data.OpenApi.Compare.Validate.Schema.TypedJson

2930import Data.Ord

3031import qualified Data.Set as S

32+import Data.Traversable (forM)

3133

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

3335newtype Silent w a = Silent {runSilent :: a}

@@ -39,15 +41,11 @@ instance Monoid w => MonadWriter w (Silent w) where

3941 listen (Silent x) = Silent (x, mempty)

4042 pass (Silent (x, _)) = Silent x

4143

42−instance MonadState (MemoState ()) (Silent w) where

43− get = Silent $ runIdentity $ runMemo () get

44− put _ = pure ()

45−

4644type ProcessM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))

4745

48−type SilentM = ReaderT (Traced (Definitions Schema)) (Silent (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))

46+type SilentM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Silent (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))

4947

50−-- Either SilentM or ProcessM

48+-- Either ProcessM or SilentM

5149type MonadProcess m =

5250 ( MonadReader (Traced (Definitions Schema)) m

5351 , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m

@@ -57,11 +55,11 @@ type MonadProcess m =

5755warn :: MonadProcess m => Issue 'SchemaLevel -> m ()

5856warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue

5957

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

58+-- Perform a computation lazily, ignoring the warnings and discarding memoization/loop detection information.

59+lazily :: MonadProcess m => SilentM a -> m a

60+lazily m = do

6361 defs <- R.ask

64− pure . runSilent $ runReaderT m defs

62+ pure $ runSilent $ runReaderT (runMemo () m) defs

6563

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

6765warnKnot =

@@ -71,10 +69,10 @@ warnKnot =

7169 , tieKnot = \_ -> pure

7270 }

7371

74−processRefSchema

75− :: MonadProcess m

76− => Traced (Referenced Schema)

77− -> m (ForeachType JsonFormula)

72+processRefSchema ::

73+ MonadProcess m =>

74+ Traced (Referenced Schema) ->

75+ m (ForeachType JsonFormula)

7876processRefSchema x = do

7977 defs <- R.ask

8078 memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)

@@ -82,10 +80,10 @@ processRefSchema x = do

8280-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition

8381-- for every possible type of a JSON value. The conditions are independent, and

8482-- are thus checked independently.

85−processSchema

86− :: MonadProcess m

87− => Traced Schema

88− -> m (ForeachType JsonFormula)

83+processSchema ::

84+ MonadProcess m =>

85+ Traced Schema ->

86+ m (ForeachType JsonFormula)

8987processSchema sch@(extract -> Schema {..}) = do

9088 let singletonFormula :: Condition t -> JsonFormula t

9189 singletonFormula = JsonFormula . LiteralDNF

@@ -243,11 +241,11 @@ processSchema sch@(extract -> Schema {..}) = do

243241 itemsClause <- case tracedItems sch of

244242 Nothing -> pure top

245243 Just (Left rs) -> do

246− f <- silently $ processRefSchema rs

244+ f <- lazily $ processRefSchema rs

247245 pure top {forArray = singletonFormula $ Items f rs}

248246 Just (Right rss) -> do

249247 fsrs <- forM rss $ \rs -> do

250− f <- silently $ processRefSchema rs

248+ f <- lazily $ processRefSchema rs

251249 pure (f, rs)

252250 pure top {forArray = singletonFormula $ TupleItems fsrs}

253251

@@ -273,12 +271,12 @@ processSchema sch@(extract -> Schema {..}) = do

273271 _ -> top

274272

275273 (addProps, addPropSchema) <- case tracedAdditionalProperties sch of

276− Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)

274+ Just (Right rs) -> (,Just rs) <$> lazily (processRefSchema rs)

277275 Just (Left False) -> pure (bottom, Nothing)

278276 _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)

279277 propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do

280278 (f, psch) <- case IOHM.lookup k $ tracedProperties sch of

281− Just rs -> (,rs) <$> silently (processRefSchema rs)

279+ Just rs -> (,rs) <$> lazily (processRefSchema rs)

282280 Nothing ->

283281 let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty

284282 in -- The mempty here is incorrect, but if addPropSchema was Nothing, then

@@ -331,26 +329,27 @@ processSchema sch@(extract -> Schema {..}) = do

331329 pure $

332330 nullableClause

333331 \/ 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− ])

332+ ( allClauses

333+ <> [ anyClause

334+ , oneClause

335+ , typeClause

336+ , enumClause

337+ , maximumClause

338+ , minimumClause

339+ , multipleOfClause

340+ , formatClause

341+ , maxLengthClause

342+ , minLengthClause

343+ , patternClause

344+ , itemsClause

345+ , maxItemsClause

346+ , minItemsClause

347+ , uniqueItemsClause

348+ , propertiesClause

349+ , maxPropertiesClause

350+ , minPropertiesClause

351+ ]

352+ )

354353

355354{- TODO: ReadOnly/WriteOnly #68 -}

356355

@@ -369,8 +368,8 @@ checkOneOfDisjoint schs = do

369368runProcessM :: Traced (Definitions Schema) -> ProcessM a -> (a, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

370369runProcessM defs = runWriter . (`runReaderT` defs) . runMemo ()

371370

372−schemaToFormula

373− :: Traced (Definitions Schema)

374− -> Traced Schema

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

371+schemaToFormula ::

372+ Traced (Definitions Schema) ->

373+ Traced Schema ->

374+ (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

376375schemaToFormula defs rs = runProcessM defs $ processSchema rs

src/Data/OpenApi/Compare/Validate/Schema/Traced.hs+12−12

@@ -1,18 +1,18 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module 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

4+ ( Step (..),

5+ tracedAllOf,

6+ tracedAnyOf,

7+ tracedOneOf,

8+ tracedItems,

9+ tracedAdditionalProperties,

10+ tracedDiscriminator,

11+ tracedProperties,

12+ tracedConjunct,

13+ PartitionLocation (..),

14+ PartitionChoice (..),

15+ Partition,

1616 )

1717where

1818

src/Data/OpenApi/Compare/Validate/Schema/TypedJson.hs+25−23

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

11module Data.OpenApi.Compare.Validate.Schema.TypedJson

2− ( JsonType (..)

3− , describeJSONType

4− , TypedValue (..)

5− , untypeValue

6− , ForeachType (..)

7− , foldType

8− , forType_

2+ ( JsonType (..),

3+ describeJSONType,

4+ TypedValue (..),

5+ untypeValue,

6+ ForeachType (..),

7+ foldType,

8+ forType_,

99 )

1010where

1111

@@ -88,24 +88,26 @@ forType_ :: Applicative m => (forall x. Typeable x => JsonType -> (ForeachType f

8888forType_ k = getAp $ foldType (\ty proj -> Ap $ k ty proj)

8989

9090broadcastType :: (forall x. Typeable x => f x) -> ForeachType f

91−broadcastType k = ForeachType

92− { forNull = k

93− , forBoolean = k

94− , forNumber = k

95− , forString = k

96− , forArray = k

97− , forObject = k

98− }

91+broadcastType k =

92+ ForeachType

93+ { forNull = k

94+ , forBoolean = k

95+ , forNumber = k

96+ , forString = k

97+ , forArray = k

98+ , forObject = k

99+ }

99100

100101zipType :: (forall x. Typeable x => f x -> g x -> h x) -> ForeachType f -> ForeachType g -> ForeachType h

101−zipType k f1 f2 = ForeachType

102− { forNull = k (forNull f1) (forNull f2)

103− , forBoolean = k (forBoolean f1) (forBoolean f2)

104− , forNumber = k (forNumber f1) (forNumber f2)

105− , forString = k (forString f1) (forString f2)

106− , forArray = k (forArray f1) (forArray f2)

107− , forObject = k (forObject f1) (forObject f2)

108− }

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+ }

109111

110112instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where

111113 (\/) = zipType (\/)

src/Data/OpenApi/Compare/Validate/SecurityRequirement.hs+9−8

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

22{-# OPTIONS_GHC -Wno-orphans #-}

33

44module Data.OpenApi.Compare.Validate.SecurityRequirement

5− ( Issue (..)

5+ ( Issue (..),

66 )

77where

88

@@ -41,18 +41,19 @@ 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 ())

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

4950 normalized

5051 pure ()

5152 checkSemanticCompatibility env bhv' pc = do

5253 let schemes = getH @(ProdCons (Traced (Definitions SecurityScheme))) env

5354 ( ProdCons pErrs cErrs

54− , (ProdCons pSchemes cSchemes)

55− :: ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]

55+ , (ProdCons pSchemes cSchemes) ::

56+ ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]

5657 ) =

5758 NE.unzip $

5859 partitionEithers <$> do

src/Data/OpenApi/Compare/Validate/Server.hs+10−9

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Validate.Server

4− ( Issue (..)

4+ ( Issue (..),

55 )

66where

77

@@ -31,9 +31,9 @@ import Data.Traversable

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

@@ -63,11 +63,12 @@ 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))

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

7172 . sequence

7273 sequenceA_ pErrs

7374 sequenceA_ cErrs

src/Data/OpenApi/Compare/Validate/Sums.hs+12−11

@@ -1,24 +1,25 @@

11module Data.OpenApi.Compare.Validate.Sums

2− ( checkSums

3− ) where

2+ ( checkSums,

3+ )

4+where

45

56import Data.Foldable

67import Data.Map.Strict (Map)

78import qualified Data.Map.Strict as M

89import Data.OpenApi.Compare.Behavior

9−import Data.OpenApi.Compare.Subtree

1010import Data.OpenApi.Compare.Paths

11+import Data.OpenApi.Compare.Subtree

1112

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

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

1920checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

2021 case M.lookup key c of

2122 Nothing -> issueAt xs $ noElt key

2223 Just consElt ->

2324 let sumElts = ProdCons prodElt consElt

24− in check key sumElts

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

stack.yaml+18−6

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

1−resolver: lts-18.4

1+resolver: lts-22.34

2+

3+packages:

4+ - .

25

36extra-deps:

7+ - base16-bytestring-1.0.2.0

8+ - freer-simple-1.2.1.2

9+ - generics-sop-0.5.1.4

10+ - github-0.29

11+ - http-link-header-1.2.1

412 - open-union-0.4.0.0

13+ - th-abstraction-0.7.0.0

514 - type-fun-0.1.3

6− - github-0.26

7− - base16-bytestring-0.1.1.7

8− - http-link-header-1.0.3.1

15+ - typerep-map-0.6.0.0

16+

17+# Required for freer-simple and typerep-map

18+allow-newer: true

919

10−apply-ghc-options: everything

11−rebuild-ghc-options: true

20+nix:

21+# packages: [pkg-config yq zlib]

22+ shell-file: ./nix/shell.nix

23+ pure: false

stack.yaml.lock+4−4

@@ -41,7 +41,7 @@ packages:

4141 hackage: http-link-header-1.0.3.1

4242snapshots:

4343- completed:

44− size: 585817

45− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/4.yaml

46− sha256: ea3a318eafa9e9cc56bfbe46099fd0d54d32641ab7bbe1d182ed8f5de39f804c

47− original: lts-18.4

44+ size: 587393

45+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/25.yaml

46+ sha256: 1b74fb5e970497b5aefae56703f1bd44aa648bd1a5ef95c1eb8c29775087e2bf

47+ original: lts-18.25

test/Spec/Golden/Extra.hs+48−44

@@ -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,51 +39,55 @@ 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− -> FilePath -- ^ Root path

56− -> FilePath -- ^ Name of golden file

57− -> s

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

59− -> IO TestTree

60−goldenInputsTree name filepath golden inp f = do

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

62+goldenInputsTree name filepath golden inp f =

6163 runTestInputTree golden f <$> getGoldenInputs name filepath inp

6264

63−runTestInputTree

64− :: FilePath

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

66− -> TestInput t

67− -> TestTree

65+runTestInputTree ::

66+ FilePath ->

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

68+ TestInput t ->

69+ TestTree

6870runTestInputTree golden f (TestInputNode name rest) =

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

7072runTestInputTree golden f (TestInputLeaf name t path) =

7173 goldenVsStringDiff

7274 name

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

75+ (\ref new -> ["diff-yaml", ref, new])

7476 (path </> golden)

7577 (f t)

7678

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

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

8892goldenInputsTreeUniform name filepath golden inp h =

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

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

@@ -25,7 +25,7 @@ tests = do

2525 traceTreeTests <-

2626 goldenInputsTreeUniform

2727 "TraceTree"

28− "test/golden/common"

28+ "test/golden"

2929 "trace-tree.yaml"

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

3131 Yaml.decodeFileThrow

@@ -34,7 +34,7 @@ tests = do

3434 reportTests <-

3535 goldenInputsTreeUniform

3636 "Report"

37− "test/golden/common"

37+ "test/golden"

3838 "report.md"

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

4040 Yaml.decodeFileThrow

test/golden/common/bad-oneof-unchanged/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |

4−|--------------------|-------------------------|-------------------------------------------------------|

5−| 0 | 0 | 2 |

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

5+| 0 | 0 | 2 |

66

77# ❓ Unsupported feature changes

88

test/golden/common/enum-added/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

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

5+| 1 | 1 |

66

77# ❌ Breaking changes

88

test/golden/common/enum-anyof/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

5−| 0 | 0 |

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

5+| 0 | 0 |

test/golden/common/id/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

5−| 0 | 0 |

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

5+| 0 | 0 |

test/golden/common/json/recursive/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

5−| 0 | 0 |

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

5+| 0 | 0 |

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

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

5+| 1 | 1 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

5−| 1 | 0 |

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

5+| 1 | 0 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

5−| 0 | 1 |

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

5+| 0 | 1 |

66

77# ⚠️ Non-breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

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

5+| 1 | 1 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

5−| 0 | 0 |

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

5+| 0 | 0 |

test/golden/common/pathItem/operation/parameters/required/false/del/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

5−| 0 | 0 |

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

5+| 0 | 0 |

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

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

11# Summary

22

33| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

5−| 0 | 1 |

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

5+| 0 | 1 |

66

77# ⚠️ Non-breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

5−| 1 | 0 |

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

5+| 1 | 0 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

5−| 1 | 0 |

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

5+| 1 | 0 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

5−| 0 | 1 |

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

5+| 0 | 1 |

66

77# ⚠️ Non-breaking changes

88

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

5−| 0 | 1 |

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

5+| 0 | 1 |

66

77# ⚠️ Non-breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

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

5+| 1 | 1 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

5−| 1 | 0 |

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

5+| 1 | 0 |

66

77# ❌ Breaking changes

88

test/golden/common/pathItem/operation/requestBody/required/reset/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

5−| 0 | 1 |

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

5+| 0 | 1 |

66

77# ⚠️ Non-breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

5−| 1 | 0 |

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

5+| 1 | 0 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

5−| 1 | 0 |

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

5+| 1 | 0 |

66

77# ❌ Breaking changes

88

test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

5−| 0 | 1 |

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

5+| 0 | 1 |

66

77# ⚠️ Non-breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

5−| 1 | 0 |

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

5+| 1 | 0 |

66

77# ❌ Breaking changes

88

test/golden/common/pathItem/operation/responses/change/headers/optional/add/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

5−| 0 | 0 |

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

5+| 0 | 0 |

test/golden/common/pathItem/operation/responses/change/headers/optional/del/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

5−| 0 | 0 |

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

5+| 0 | 0 |

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

5−| 1 | 0 |

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

5+| 1 | 0 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

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

5+| 1 | 1 |

66

77# ❌ Breaking changes

88

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

5−| 0 | 1 |

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

5+| 0 | 1 |

66

77# ⚠️ Non-breaking changes

88

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

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

11# Summary

22

33| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

5−| 0 | 1 |

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

5+| 0 | 1 |

66

77# ⚠️ Non-breaking changes

88

test/golden/common/property-removed-additional/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 3 | 3 |

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

5+| 3 | 3 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

5−| 2 | 0 |

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

5+| 2 | 0 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

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

5+| 1 | 1 |

66

77# ❌ Breaking changes

88

test/golden/common/random-example/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 5 | 6 |

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

5+| 5 | 6 |

66

77# ❌ Breaking changes

88

test/golden/common/random-example/trace-tree.yaml+4−4

@@ -23,6 +23,10 @@ forwardChanges:

2323backwardChanges:

2424 AtPath "/pets":

2525 InOperation GetMethod:

26+ InParam "limit":

27+ InParamSchema:

28+ OfType Number: MatchingMaximumWeak (ProdCons {producer = Inclusive 30.0,

29+ consumer = Inclusive 20.0})

2630 WithStatusCode 200:

2731 ResponsePayload:

2832 PayloadSchema:

@@ -33,10 +37,6 @@ backwardChanges:

3337 - TypesRestricted [Number]

3438 - AdditionalToProperty

3539 - OfType Number: NoMatchingMultipleOf 1.0

36− InParam "limit":

37− InParamSchema:

38− OfType Number: MatchingMaximumWeak (ProdCons {producer = Inclusive 30.0,

39− consumer = Inclusive 20.0})

4040 InOperation PostMethod:

4141 InRequest:

4242 InPayload:

test/golden/common/recursive/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

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

5+| 1 | 1 |

66

77# ❌ Breaking changes

88

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

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 2 | 1 |

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

5+| 2 | 1 |

66

77# ❌ Breaking changes

88

test/golden/common/servers/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 3 | 1 |

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

5+| 3 | 1 |

66

77# ❌ Breaking changes

88

test/golden/common/tuple-items/heterogeneous-component-mismatch/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 2 | 2 |

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

5+| 2 | 2 |

66

77# ❌ Breaking changes

88

test/golden/common/tuple-items/heterogeneous-length-mismatch/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

5−| 2 | 0 |

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

5+| 2 | 0 |

66

77# ❌ Breaking changes

88

test/golden/common/tuple-items/homogeneous-component-mismatch/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 4 | 2 |

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

5+| 4 | 2 |

66

77# ❌ Breaking changes

88

test/golden/common/tuple-items/homogeneous-length-mismatch/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 5 | 5 |

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

5+| 5 | 5 |

66

77# ❌ Breaking changes

88

test/golden/common/tuple-items/homogeneous-vector/report.md+2−2

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

11# Summary

22

33| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

5−| 0 | 0 |

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

5+| 0 | 0 |

test/golden/common/type-changing/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 6 | 6 |

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

5+| 6 | 6 |

66

77# ❌ Breaking changes

88

test/golden/common/unguarded-recursive/a.yaml → test/golden/common/unguarded-recursive/basic/a.yamlrenamed

The content is the same.

test/golden/common/unguarded-recursive/b.yaml → test/golden/common/unguarded-recursive/basic/b.yamlrenamed

The content is the same.

test/golden/common/unguarded-recursive/report.md → test/golden/common/unguarded-recursive/basic/report.mdrenamed+2−2

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

11# Summary

22

33| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |

4−|--------------------|-------------------------|-------------------------------------------------------|

5−| 0 | 0 | 1 |

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

5+| 0 | 0 | 1 |

66

77# ❓ Unsupported feature changes

88

test/golden/common/unguarded-recursive/trace-tree.yaml → test/golden/common/unguarded-recursive/basic/trace-tree.yamlrenamed

The content is the same.

test/golden/common/unguarded-recursive/silent/a.yamlnew file+25

@@ -0,0 +1,25 @@

1+components:

2+ schemas:

3+ A:

4+ type: object

5+ properties:

6+ bar:

7+ $ref: "#/components/schemas/B"

8+ B:

9+ anyOf:

10+ - $ref: "#/components/schemas/B"

11+ type: object

12+openapi: 3.0.0

13+info:

14+ version: ""

15+ title: ""

16+paths:

17+ /foo:

18+ get:

19+ responses:

20+ "200":

21+ content:

22+ application/json;charset=utf-8:

23+ schema:

24+ $ref: "#/components/schemas/A"

25+ description: ""

test/golden/common/unguarded-recursive/silent/b.yamlnew file+19

@@ -0,0 +1,19 @@

1+components:

2+ schemas: {}

3+openapi: 3.0.0

4+info:

5+ version: ""

6+ title: ""

7+paths:

8+ /foo:

9+ get:

10+ responses:

11+ "200":

12+ content:

13+ application/json;charset=utf-8:

14+ schema:

15+ type: object

16+ properties:

17+ bar:

18+ type: object

19+ description: ""

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

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

1+# Summary

2+

3+| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |

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

5+| 0 | 0 | 1 |

6+

7+# ❓ Unsupported feature changes

8+

9+## **GET** /foo

10+

11+### ⬅️☁️ JSON Response – 200

12+

13+#### `$.bar`

14+

15+Encountered recursion that is too complex for CompaREST to untangle.

test/golden/common/unguarded-recursive/silent/trace-tree.yamlnew file+16

@@ -0,0 +1,16 @@

1+forwardChanges:

2+ AtPath "/foo":

3+ InOperation GetMethod:

4+ WithStatusCode 200:

5+ ResponsePayload:

6+ PayloadSchema:

7+ OfType Object:

8+ InProperty "bar": UnguardedRecursion

9+backwardChanges:

10+ AtPath "/foo":

11+ InOperation GetMethod:

12+ WithStatusCode 200:

13+ ResponsePayload:

14+ PayloadSchema:

15+ OfType Object:

16+ InProperty "bar": UnguardedRecursion

test/golden/common/variant-added/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

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

5+| 1 | 1 |

66

77# ❌ Breaking changes

88

test/golden/common/variant-changed/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 2 | 2 |

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

5+| 2 | 2 |

66

77# ❌ Breaking changes

88

test/golden/common/variant-deep-changed/report.md+2−2

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

11# Summary

22

33| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

5−| 2 | 2 |

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

5+| 2 | 2 |

66

77# ❌ Breaking changes

88