├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.haskell-ci ├── cabal.project ├── example ├── LICENSE ├── example.cabal ├── server │ └── Main.hs ├── src │ └── Todo.hs ├── swagger.json └── test │ ├── Spec.hs │ └── TodoSpec.hs ├── servant-openapi3.cabal ├── src └── Servant │ ├── OpenApi.hs │ └── OpenApi │ ├── Internal.hs │ ├── Internal │ ├── Orphans.hs │ ├── Test.hs │ ├── TypeLevel.hs │ └── TypeLevel │ │ ├── API.hs │ │ ├── Every.hs │ │ └── TMap.hs │ ├── Test.hs │ └── TypeLevel.hs ├── stack.yaml └── test ├── Servant └── OpenApiSpec.hs ├── Spec.hs └── doctests.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250506 12 | # 13 | # REGENDATA ("0.19.20250506",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-24.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:focal 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.1 36 | compilerKind: ghc 37 | compilerVersion: 9.12.1 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.2 41 | compilerKind: ghc 42 | compilerVersion: 9.10.2 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.1 46 | compilerKind: ghc 47 | compilerVersion: 9.8.1 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.3 51 | compilerKind: ghc 52 | compilerVersion: 9.6.3 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-9.0.2 66 | compilerKind: ghc 67 | compilerVersion: 9.0.2 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.10.7 71 | compilerKind: ghc 72 | compilerVersion: 8.10.7 73 | setup-method: ghcup 74 | allow-failure: false 75 | - compiler: ghc-8.8.4 76 | compilerKind: ghc 77 | compilerVersion: 8.8.4 78 | setup-method: ghcup 79 | allow-failure: false 80 | - compiler: ghc-8.6.5 81 | compilerKind: ghc 82 | compilerVersion: 8.6.5 83 | setup-method: ghcup 84 | allow-failure: false 85 | fail-fast: false 86 | steps: 87 | - name: apt-get install 88 | run: | 89 | apt-get update 90 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 91 | - name: Install GHCup 92 | run: | 93 | mkdir -p "$HOME/.ghcup/bin" 94 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 95 | chmod a+x "$HOME/.ghcup/bin/ghcup" 96 | - name: Install cabal-install 97 | run: | 98 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 99 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 100 | - name: Install GHC (GHCup) 101 | if: matrix.setup-method == 'ghcup' 102 | run: | 103 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 104 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 105 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 106 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 107 | echo "HC=$HC" >> "$GITHUB_ENV" 108 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 109 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 110 | env: 111 | HCKIND: ${{ matrix.compilerKind }} 112 | HCNAME: ${{ matrix.compiler }} 113 | HCVER: ${{ matrix.compilerVersion }} 114 | - name: Set PATH and environment variables 115 | run: | 116 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 117 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 118 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 119 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 120 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 121 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 122 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 123 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 124 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 125 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 126 | env: 127 | HCKIND: ${{ matrix.compilerKind }} 128 | HCNAME: ${{ matrix.compiler }} 129 | HCVER: ${{ matrix.compilerVersion }} 130 | - name: env 131 | run: | 132 | env 133 | - name: write cabal config 134 | run: | 135 | mkdir -p $CABAL_DIR 136 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 169 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 170 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 171 | rm -f cabal-plan.xz 172 | chmod a+x $HOME/.cabal/bin/cabal-plan 173 | cabal-plan --version 174 | - name: checkout 175 | uses: actions/checkout@v4 176 | with: 177 | path: source 178 | - name: initial cabal.project for sdist 179 | run: | 180 | touch cabal.project 181 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 182 | echo "packages: $GITHUB_WORKSPACE/source/example" >> cabal.project 183 | cat cabal.project 184 | - name: sdist 185 | run: | 186 | mkdir -p sdist 187 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 188 | - name: unpack 189 | run: | 190 | mkdir -p unpacked 191 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 192 | - name: generate cabal.project 193 | run: | 194 | PKGDIR_servant_openapi3="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/servant-openapi3-[0-9.]*')" 195 | echo "PKGDIR_servant_openapi3=${PKGDIR_servant_openapi3}" >> "$GITHUB_ENV" 196 | PKGDIR_example="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/example-[0-9.]*')" 197 | echo "PKGDIR_example=${PKGDIR_example}" >> "$GITHUB_ENV" 198 | rm -f cabal.project cabal.project.local 199 | touch cabal.project 200 | touch cabal.project.local 201 | echo "packages: ${PKGDIR_servant_openapi3}" >> cabal.project 202 | echo "packages: ${PKGDIR_example}" >> cabal.project 203 | echo "package servant-openapi3" >> cabal.project 204 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 205 | echo "package example" >> cabal.project 206 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 207 | cat >> cabal.project <> cabal.project.local 210 | cat cabal.project 211 | cat cabal.project.local 212 | - name: dump install plan 213 | run: | 214 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 215 | cabal-plan 216 | - name: restore cache 217 | uses: actions/cache/restore@v4 218 | with: 219 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 220 | path: ~/.cabal/store 221 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 222 | - name: install dependencies 223 | run: | 224 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 225 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 226 | - name: build w/o tests 227 | run: | 228 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 229 | - name: build 230 | run: | 231 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 232 | - name: tests 233 | run: | 234 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 235 | - name: cabal check 236 | run: | 237 | cd ${PKGDIR_servant_openapi3} || false 238 | ${CABAL} -vnormal check 239 | cd ${PKGDIR_example} || false 240 | ${CABAL} -vnormal check 241 | - name: haddock 242 | run: | 243 | if [ $((HCNUMVER < 90000 || HCNUMVER >= 90400)) -ne 0 ] ; then $CABAL v2-haddock --disable-documentation $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all ; fi 244 | - name: unconstrained build 245 | run: | 246 | rm -f cabal.project.local 247 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 248 | - name: prepare for constraint sets 249 | run: | 250 | rm -f cabal.project.local 251 | - name: constraint set servant-0.20 252 | run: | 253 | if [ $((HCNUMVER >= 81000 && HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.20.*' all --dry-run ; fi 254 | if [ $((HCNUMVER >= 81000 && HCNUMVER < 90800)) -ne 0 ] ; then cabal-plan topo | sort ; fi 255 | if [ $((HCNUMVER >= 81000 && HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.20.*' --dependencies-only -j2 all ; fi 256 | if [ $((HCNUMVER >= 81000 && HCNUMVER < 90800)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.20.*' all ; fi 257 | - name: constraint set servant-0.19 258 | run: | 259 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.19.*' all --dry-run ; fi 260 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90600)) -ne 0 ] ; then cabal-plan topo | sort ; fi 261 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.19.*' --dependencies-only -j2 all ; fi 262 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90600)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.19.*' all ; fi 263 | - name: constraint set servant-0.18.2 264 | run: | 265 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18.2' all --dry-run ; fi 266 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then cabal-plan topo | sort ; fi 267 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18.2' --dependencies-only -j2 all ; fi 268 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18.2' all ; fi 269 | - name: constraint set servant-0.18.1 270 | run: | 271 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18.1' all --dry-run ; fi 272 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then cabal-plan topo | sort ; fi 273 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18.1' --dependencies-only -j2 all ; fi 274 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18.1' all ; fi 275 | - name: constraint set servant-0.18 276 | run: | 277 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18' all --dry-run ; fi 278 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then cabal-plan topo | sort ; fi 279 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18' --dependencies-only -j2 all ; fi 280 | if [ $((HCNUMVER >= 80800 && HCNUMVER < 90000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.18' all ; fi 281 | - name: constraint set servant-0.17 282 | run: | 283 | if [ $((HCNUMVER < 81000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.17.*' all --dry-run ; fi 284 | if [ $((HCNUMVER < 81000)) -ne 0 ] ; then cabal-plan topo | sort ; fi 285 | if [ $((HCNUMVER < 81000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.17.*' --dependencies-only -j2 all ; fi 286 | if [ $((HCNUMVER < 81000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='servant ==0.17.*' all ; fi 287 | - name: save cache 288 | if: always() 289 | uses: actions/cache/save@v4 290 | with: 291 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 292 | path: ~/.cabal/store 293 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .DS_Store 3 | *.nix 4 | dist/ 5 | dist-newstyle/ 6 | .ghc.environment.* 7 | /foo.json 8 | servant-client-0.4.4/ 9 | cabal-dev 10 | *.o 11 | *.hi 12 | *.chi 13 | *.chs.h 14 | *.dyn_o 15 | *.dyn_hi 16 | .virtualenv 17 | .hpc 18 | .hsenv 19 | .cabal-sandbox/ 20 | cabal.sandbox.config 21 | *.prof 22 | *.aux 23 | *.hp 24 | .stack-work/ 25 | swagger.json 26 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 1.1.8 2 | ------- 3 | 4 | * Support `servant-0.17` 5 | 6 | 1.1.7.1 7 | ------- 8 | 9 | * Support `swagger2-2.4` 10 | 11 | 1.1.7 12 | ----- 13 | 14 | * Support servant-0.15 15 | - support for 'Stream' and 'StreamBody' combinators 16 | - orphan 'ToSchema (SourceT m a)' instance 17 | * Fix BodyTypes to work with generalized ReqBody' 18 | [#88](https://github.com/haskell-servant/servant-swagger/pull/88) 19 | 20 | 1.1.6 21 | ----- 22 | 23 | * Fixes: 24 | * `validateEveryToJSON` now prints validation errors 25 | 26 | * Notes: 27 | * GHC-8.6 compatible release 28 | 29 | 1.1.5 30 | ----- 31 | 32 | * Notes: 33 | * `servant-0.13` compatible release 34 | * Drops compatibility with previous `servant` versions. 35 | 36 | 1.1.4 37 | ----- 38 | 39 | * Notes: 40 | * `servant-0.12` compatible release 41 | 42 | 1.1.3.1 43 | --- 44 | 45 | * Notes: 46 | * GHC-8.2 compatible release 47 | 48 | 1.1.3 49 | --- 50 | 51 | * Notes: 52 | * `servant-0.11` compatible release 53 | 54 | 1.1.2.1 55 | --- 56 | 57 | * Notes: 58 | * `servant-0.10` compatible release 59 | 60 | 1.1.2 61 | --- 62 | 63 | * Minor fixes: 64 | * Support for aeson-1, insert-ordered-containers-0.2 65 | * CaptureAll instance 66 | 67 | 1.1.1 68 | --- 69 | 70 | * Minor fixes: 71 | * Fix `unused-imports` and `unused-foralls` warnings; 72 | * Fix tests to match `swagger2-2.1.1` (add `example` property for `UTCTime` schema). 73 | 74 | 1.1 75 | --- 76 | 77 | * Breaking changes: 78 | * Requires `swagger2 >= 2.1` 79 | * Requires `servant >= 0.5` 80 | 81 | * Notes: 82 | * GHC-8.0 compatible release 83 | 84 | 1.0.3 85 | --- 86 | 87 | * Fixes: 88 | * Improve compile-time performance of `BodyTypes` even further (see [18e0d95](https://github.com/haskell-servant/servant-swagger/commit/18e0d95ef6fe9076dd9621cb515d8d1a189f71d3))! 89 | 90 | 1.0.2 91 | --- 92 | 93 | * Minor changes: 94 | * Add GHC 7.8 support (see [#26](https://github.com/haskell-servant/servant-swagger/pull/26)). 95 | 96 | * Fixes: 97 | * Improve compile-time performance of `BodyTypes` (see [#25](https://github.com/haskell-servant/servant-swagger/issues/25)). 98 | 99 | 1.0.1 100 | --- 101 | 102 | * Fixes: 103 | * Stop using `Data.Swagger.Internal`; 104 | * Documentation fixes (links to examples). 105 | 106 | 1.0 107 | --- 108 | 109 | * Major changes (see [#24](https://github.com/haskell-servant/servant-swagger/pull/24)): 110 | * Switch to `swagger2-2.*`; 111 | * Add automatic `ToJSON`/`ToSchema` validation tests; 112 | * Add great documentation; 113 | * Export some type-level functions for servant API. 114 | 115 | * Minor changes: 116 | * Rework Todo API example; 117 | * Stop exporting `ToResponseHeader`, `AllAccept` and `AllToResponseHeader` (see [bd50db4](https://github.com/haskell-servant/servant-swagger/commit/bd50db48ca6a106e4366560ded70932d409de1e2)); 118 | * Change maintainer, update authors/copyrights (see [1a62681](https://github.com/haskell-servant/servant-swagger/commit/1a6268101dc826a92c42e832e402e251c0d32147)); 119 | * Include changelog and example files into `extra-source-files`. 120 | 121 | 0.1.2 122 | --- 123 | 124 | * Fixes: 125 | * Fix default spec for `ReqBody` param to be required (see [#22](https://github.com/haskell-servant/servant-swagger/issues/22)); 126 | * Set version bounds for `swagger2`. 127 | 128 | 0.1.1 129 | --- 130 | 131 | * Fixes: 132 | * Fix `subOperations` to filter endpoints also by method (see [#18](https://github.com/haskell-servant/servant-swagger/issues/18)); 133 | * Fix response schema in `ToSwagger` instance for `Header` (see [b59e557](https://github.com/haskell-servant/servant-swagger/commit/b59e557a05bc2669332c52b397879e7598747b82)). 134 | 135 | 0.1 136 | --- 137 | * Major changes 138 | * Use `swagger2` for data model (see [#9](https://github.com/dmjio/servant-swagger/pull/9)); this changes almost everything. 139 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2016, Servant contributors 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of servant-swagger nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # servant-openapi3 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/servant-openapi3.svg)](http://hackage.haskell.org/package/servant-openapi3) 4 | [![Build Status](https://travis-ci.org/biocad/servant-openapi3.svg?branch=master)](https://travis-ci.org/biocad/servant-openapi3) 5 | [![Stackage LTS](http://stackage.org/package/servant-openapi3/badge/lts)](http://stackage.org/lts/package/servant-openapi3) 6 | [![Stackage Nightly](http://stackage.org/package/servant-openapi3/badge/nightly)](http://stackage.org/nightly/package/servant-openapi3) 7 | 8 | OpenAPI 3.0 conforming json for [servant](https://github.com/haskell-servant/servant) APIs. 9 | 10 | ![servant-swagger robot](http://s16.postimg.org/rndz1wbyt/servant.png) 11 | 12 | ### Motivation 13 | 14 | Swagger is a project used to describe and document RESTful APIs. 15 | Unlike Servant it is language-agnostic and thus is quite popular among developers 16 | in different languages. It also exists for a longer time and has more tools to work with. 17 | 18 | This package provides means to generate Swagger specification for a Servant API 19 | and also to partially test whether API conforms with its specification. 20 | 21 | Generated Swagger specification then can be used for many things such as 22 | - displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/); 23 | - generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/); 24 | - and [many others](http://swagger.io/open-source-integrations/). 25 | 26 | ### Usage 27 | 28 | Please refer to [haddock documentation](http://hackage.haskell.org/package/servant-openapi3). 29 | 30 | Some examples can be found in [`example/` directory](/example). 31 | 32 | ### Try it out 33 | 34 | All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/). 35 | 36 | Ready-to-use specification can be served as JSON and interactive API documentation 37 | can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui). 38 | 39 | Many Swagger tools, including server and client code generation for many languages, can be found on 40 | [Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/). 41 | 42 | ### Contributing 43 | 44 | We are happy to receive bug reports, fixes, documentation enhancements, and other improvements. 45 | 46 | Please report bugs via the [github issue tracker](https://github.com/biocad/servant-openapi3/issues). 47 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | module Main (main) where 4 | 5 | #ifndef MIN_VERSION_cabal_doctest 6 | #define MIN_VERSION_cabal_doctest(x,y,z) 0 7 | #endif 8 | 9 | #if MIN_VERSION_cabal_doctest(1,0,0) 10 | 11 | import Distribution.Extra.Doctest ( defaultMainWithDoctests ) 12 | main :: IO () 13 | main = defaultMainWithDoctests "doctests" 14 | 15 | #else 16 | 17 | #ifdef MIN_VERSION_Cabal 18 | -- If the macro is defined, we have new cabal-install, 19 | -- but for some reason we don't have cabal-doctest in package-db 20 | -- 21 | -- Probably we are running cabal sdist, when otherwise using new-build 22 | -- workflow 23 | #warning You are configuring this package without cabal-doctest installed. \ 24 | The doctests test-suite will not work as a result. \ 25 | To fix this, install cabal-doctest before configuring. 26 | #endif 27 | 28 | import Distribution.Simple 29 | 30 | main :: IO () 31 | main = defaultMain 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | 3 | distribution: focal 4 | 5 | -- https://github.com/haskell-CI/haskell-ci/issues/658#issuecomment-1513692337 6 | haddock-components: libs 7 | 8 | -- Building docs on GHC 9.2 and 9.4 leads to myriad of different errors. 9 | -- See https://github.com/haskell/cabal/issues/7462, https://github.com/haskell/cabal/issues/8707 10 | -- and https://github.com/haskell/cabal/issues/8707 11 | haddock: < 9.0 || >= 9.4 12 | 13 | constraint-set servant-0.17 14 | ghc: >= 8.0 && <8.10 15 | constraints: servant ==0.17.* 16 | 17 | constraint-set servant-0.18 18 | ghc: >= 8.8 && <8.12 19 | constraints: servant ==0.18 20 | 21 | constraint-set servant-0.18.1 22 | ghc: >= 8.8 && <8.12 23 | constraints: servant ==0.18.1 24 | 25 | constraint-set servant-0.18.2 26 | ghc: >= 8.8 && <8.12 27 | constraints: servant ==0.18.2 28 | 29 | constraint-set servant-0.19 30 | ghc: >= 8.8 && <9.6 31 | constraints: servant ==0.19.* 32 | 33 | constraint-set servant-0.20 34 | ghc: >= 8.10 && <9.8 35 | constraints: servant ==0.20.* 36 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | servant-openapi3.cabal, 3 | example/example.cabal 4 | tests: true 5 | -------------------------------------------------------------------------------- /example/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2016, Servant contributors 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of servant-swagger nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | 29 | -------------------------------------------------------------------------------- /example/example.cabal: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 1.0 3 | synopsis: servant-openapi3 demonstration 4 | description: An example of how servant-openapi3 can be used. 5 | license: BSD3 6 | license-file: LICENSE 7 | author: David Johnson, Nickolay Kudasov 8 | maintainer: nickolay.kudasov@gmail.com 9 | copyright: (c) 2015-2020, Servant contributors 10 | category: Web 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | data-files: 14 | swagger.json 15 | 16 | tested-with: 17 | GHC ==8.6.5 18 | || ==8.8.4 19 | || ==8.10.7 20 | || ==9.0.2 21 | || ==9.2.8 22 | || ==9.4.8 23 | || ==9.6.3 24 | || ==9.8.1 25 | || ==9.10.2 26 | || ==9.12.1 27 | 28 | library 29 | ghc-options: -Wall 30 | hs-source-dirs: src/ 31 | exposed-modules: 32 | Todo 33 | build-depends: base < 5 34 | , aeson 35 | , aeson-pretty 36 | , bytestring 37 | , lens 38 | , servant 39 | , servant-server 40 | , servant-openapi3 41 | , openapi3 42 | , text 43 | , time 44 | default-language: Haskell2010 45 | 46 | executable swagger-server 47 | ghc-options: -Wall 48 | hs-source-dirs: server/ 49 | main-is: Main.hs 50 | build-depends: base 51 | , example 52 | , servant-server 53 | , warp 54 | default-language: Haskell2010 55 | 56 | test-suite swagger-server-spec 57 | ghc-options: -Wall 58 | type: exitcode-stdio-1.0 59 | hs-source-dirs: test 60 | main-is: Spec.hs 61 | other-modules: 62 | TodoSpec 63 | Paths_example 64 | build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.10 65 | build-depends: base == 4.* 66 | , base-compat >= 0.6.0 67 | , aeson >=0.11.2.0 68 | , bytestring 69 | , example 70 | , hspec 71 | , servant-openapi3 72 | , QuickCheck 73 | , quickcheck-instances 74 | default-language: Haskell2010 75 | -------------------------------------------------------------------------------- /example/server/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Network.Wai.Handler.Warp 4 | import Servant 5 | import Todo 6 | 7 | main :: IO () 8 | main = do 9 | putStrLn "Running on port 8000" 10 | run 8000 $ serve (Proxy :: Proxy API) server 11 | 12 | -------------------------------------------------------------------------------- /example/src/Todo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | module Todo where 8 | 9 | import Control.Lens 10 | import Data.Aeson 11 | import Data.Aeson.Encode.Pretty (encodePretty) 12 | import qualified Data.ByteString.Lazy.Char8 as BL8 13 | import Data.OpenApi hiding (Server) 14 | import Data.Proxy 15 | import Data.Text (Text) 16 | import Data.Time (UTCTime (..), fromGregorian) 17 | import Data.Typeable (Typeable) 18 | import GHC.Generics 19 | import Servant 20 | import Servant.OpenApi 21 | 22 | todoAPI :: Proxy TodoAPI 23 | todoAPI = Proxy 24 | 25 | -- | The API of a Todo service. 26 | type TodoAPI 27 | = "todo" :> Get '[JSON] [Todo] 28 | :<|> "todo" :> ReqBody '[JSON] Todo :> Post '[JSON] TodoId 29 | :<|> "todo" :> Capture "id" TodoId :> Get '[JSON] Todo 30 | :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Put '[JSON] TodoId 31 | 32 | -- | API for serving @swagger.json@. 33 | type SwaggerAPI = "swagger.json" :> Get '[JSON] OpenApi 34 | 35 | -- | Combined API of a Todo service with Swagger documentation. 36 | type API = SwaggerAPI :<|> TodoAPI 37 | 38 | -- | A single Todo entry. 39 | data Todo = Todo 40 | { created :: UTCTime -- ^ Creation datetime. 41 | , summary :: Text -- ^ Task summary. 42 | } deriving (Show, Generic, Typeable) 43 | 44 | -- | A unique Todo entry ID. 45 | newtype TodoId = TodoId Int 46 | deriving (Show, Generic, Typeable, ToJSON, FromHttpApiData) 47 | 48 | instance ToJSON Todo 49 | instance FromJSON Todo 50 | 51 | instance ToSchema Todo where 52 | declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy 53 | & mapped.schema.description ?~ "This is some real Todo right here" 54 | & mapped.schema.example ?~ toJSON (Todo (UTCTime (fromGregorian 2015 12 31) 0) "get milk") 55 | 56 | instance ToParamSchema TodoId 57 | instance ToSchema TodoId 58 | 59 | -- | Swagger spec for Todo API. 60 | todoSwagger :: OpenApi 61 | todoSwagger = toOpenApi todoAPI 62 | & info.title .~ "Todo API" 63 | & info.version .~ "1.0" 64 | & info.description ?~ "This is an API that tests swagger integration" 65 | & info.license ?~ ("MIT" & url ?~ URL "http://mit.com") 66 | 67 | -- | Combined server of a Todo service with Swagger documentation. 68 | server :: Server API 69 | server = return todoSwagger :<|> error "not implemented" 70 | 71 | -- | Output generated @swagger.json@ file for the @'TodoAPI'@. 72 | writeSwaggerJSON :: IO () 73 | writeSwaggerJSON = BL8.writeFile "example/swagger.json" (encodePretty todoSwagger) 74 | -------------------------------------------------------------------------------- /example/swagger.json: -------------------------------------------------------------------------------- 1 | { 2 | "openapi": "3.0.0", 3 | "info": { 4 | "version": "1.0", 5 | "title": "Todo API", 6 | "license": { 7 | "url": "http://mit.com", 8 | "name": "MIT" 9 | }, 10 | "description": "This is an API that tests swagger integration" 11 | }, 12 | "paths": { 13 | "/todo": { 14 | "get": { 15 | "responses": { 16 | "200": { 17 | "content": { 18 | "application/json;charset=utf-8": { 19 | "schema": { 20 | "items": { 21 | "$ref": "#/components/schemas/Todo" 22 | }, 23 | "type": "array" 24 | } 25 | } 26 | }, 27 | "description": "" 28 | } 29 | } 30 | }, 31 | "post": { 32 | "requestBody": { 33 | "content": { 34 | "application/json;charset=utf-8": { 35 | "schema": { 36 | "$ref": "#/components/schemas/Todo" 37 | } 38 | } 39 | } 40 | }, 41 | "responses": { 42 | "400": { 43 | "description": "Invalid `body`" 44 | }, 45 | "200": { 46 | "content": { 47 | "application/json;charset=utf-8": { 48 | "schema": { 49 | "$ref": "#/components/schemas/TodoId" 50 | } 51 | } 52 | }, 53 | "description": "" 54 | } 55 | } 56 | } 57 | }, 58 | "/todo/{id}": { 59 | "get": { 60 | "parameters": [ 61 | { 62 | "required": true, 63 | "schema": { 64 | "maximum": 9223372036854775807, 65 | "minimum": -9223372036854775808, 66 | "type": "integer" 67 | }, 68 | "in": "path", 69 | "name": "id" 70 | } 71 | ], 72 | "responses": { 73 | "404": { 74 | "description": "`id` not found" 75 | }, 76 | "200": { 77 | "content": { 78 | "application/json;charset=utf-8": { 79 | "schema": { 80 | "$ref": "#/components/schemas/Todo" 81 | } 82 | } 83 | }, 84 | "description": "" 85 | } 86 | } 87 | }, 88 | "put": { 89 | "parameters": [ 90 | { 91 | "required": true, 92 | "schema": { 93 | "maximum": 9223372036854775807, 94 | "minimum": -9223372036854775808, 95 | "type": "integer" 96 | }, 97 | "in": "path", 98 | "name": "id" 99 | } 100 | ], 101 | "requestBody": { 102 | "content": { 103 | "application/json;charset=utf-8": { 104 | "schema": { 105 | "$ref": "#/components/schemas/Todo" 106 | } 107 | } 108 | } 109 | }, 110 | "responses": { 111 | "404": { 112 | "description": "`id` not found" 113 | }, 114 | "400": { 115 | "description": "Invalid `body`" 116 | }, 117 | "200": { 118 | "content": { 119 | "application/json;charset=utf-8": { 120 | "schema": { 121 | "$ref": "#/components/schemas/TodoId" 122 | } 123 | } 124 | }, 125 | "description": "" 126 | } 127 | } 128 | } 129 | } 130 | }, 131 | "components": { 132 | "schemas": { 133 | "Todo": { 134 | "example": { 135 | "summary": "get milk", 136 | "created": "2015-12-31T00:00:00Z" 137 | }, 138 | "required": [ 139 | "created", 140 | "summary" 141 | ], 142 | "type": "object", 143 | "description": "This is some real Todo right here", 144 | "properties": { 145 | "summary": { 146 | "type": "string" 147 | }, 148 | "created": { 149 | "$ref": "#/components/schemas/UTCTime" 150 | } 151 | } 152 | }, 153 | "UTCTime": { 154 | "example": "2016-07-22T00:00:00Z", 155 | "format": "yyyy-mm-ddThh:MM:ssZ", 156 | "type": "string" 157 | }, 158 | "TodoId": { 159 | "maximum": 9223372036854775807, 160 | "minimum": -9223372036854775808, 161 | "type": "integer" 162 | } 163 | } 164 | } 165 | } 166 | -------------------------------------------------------------------------------- /example/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /example/test/TodoSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module TodoSpec where 3 | 4 | import Prelude () 5 | import Prelude.Compat 6 | 7 | import Data.Aeson 8 | import qualified Data.ByteString.Lazy.Char8 as BL8 9 | import Paths_example 10 | import Servant.OpenApi.Test 11 | import Test.Hspec 12 | import Test.QuickCheck 13 | import Test.QuickCheck.Instances () 14 | import Todo 15 | 16 | spec :: Spec 17 | spec = describe "Swagger" $ do 18 | context "ToJSON matches ToSchema" $ validateEveryToJSON todoAPI 19 | it "swagger.json is up-to-date" $ do 20 | path <- getDataFileName "swagger.json" 21 | swag <- eitherDecode <$> BL8.readFile path 22 | swag `shouldBe` Right todoSwagger 23 | 24 | instance Arbitrary Todo where 25 | arbitrary = Todo <$> arbitrary <*> arbitrary 26 | 27 | instance Arbitrary TodoId where 28 | arbitrary = TodoId <$> arbitrary 29 | -------------------------------------------------------------------------------- /servant-openapi3.cabal: -------------------------------------------------------------------------------- 1 | name: servant-openapi3 2 | version: 2.0.1.6 3 | synopsis: Generate a Swagger/OpenAPI/OAS 3.0 specification for your servant API. 4 | description: 5 | Swagger is a project used to describe and document RESTful APIs. The core of the 6 | project is the [OpenAPI Specification (OAS)](https://swagger.io/docs/specification/about/). 7 | This library implements v3.0 of the spec. Unlike Servant it is language-agnostic and thus is 8 | quite popular among developers in different languages. It has also existed for a longer time 9 | and has more helpful tooling. 10 | . 11 | This package provides means to generate a Swagger/OAS specification for a Servant API 12 | and also to partially test whether an API conforms with its specification. 13 | . 14 | Generated Swagger specification then can be used for many things such as 15 | . 16 | * displaying interactive documentation using [Swagger UI](http://swagger.io/swagger-ui/); 17 | . 18 | * generating clients and servers in many languages using [Swagger Codegen](http://swagger.io/swagger-codegen/); 19 | . 20 | * and [many others](http://swagger.io/open-source-integrations/). 21 | homepage: https://github.com/biocad/servant-openapi3 22 | bug-reports: https://github.com/biocad/servant-openapi3/issues 23 | license: BSD3 24 | license-file: LICENSE 25 | author: David Johnson, Nickolay Kudasov, Maxim Koltsov 26 | maintainer: nickolay.kudasov@gmail.com, kolmax94@gmail.com 27 | copyright: (c) 2015-2020, Servant contributors 28 | category: Web, Servant, Swagger 29 | build-type: Custom 30 | cabal-version: 1.18 31 | tested-with: 32 | GHC ==8.6.5 33 | || ==8.8.4 34 | || ==8.10.7 35 | || ==9.0.2 36 | || ==9.2.8 37 | || ==9.4.8 38 | || ==9.6.3 39 | || ==9.8.1 40 | || ==9.10.2 41 | || ==9.12.1 42 | 43 | extra-source-files: 44 | README.md 45 | , CHANGELOG.md 46 | , example/server/*.hs 47 | , example/src/*.hs 48 | , example/test/*.hs 49 | , example/*.cabal 50 | , example/swagger.json 51 | , example/LICENSE 52 | extra-doc-files: 53 | example/src/*.hs 54 | , example/test/*.hs 55 | 56 | source-repository head 57 | type: git 58 | location: https://github.com/biocad/servant-openapi3.git 59 | 60 | custom-setup 61 | setup-depends: 62 | base >=4.9 && <4.22, 63 | Cabal >= 1.24 && < 4, 64 | cabal-doctest >=1.0.6 && <1.1 65 | 66 | library 67 | ghc-options: -Wall 68 | exposed-modules: 69 | Servant.OpenApi 70 | Servant.OpenApi.Test 71 | Servant.OpenApi.TypeLevel 72 | 73 | -- Internal modules 74 | Servant.OpenApi.Internal 75 | Servant.OpenApi.Internal.Orphans 76 | Servant.OpenApi.Internal.Test 77 | Servant.OpenApi.Internal.TypeLevel 78 | Servant.OpenApi.Internal.TypeLevel.API 79 | Servant.OpenApi.Internal.TypeLevel.Every 80 | Servant.OpenApi.Internal.TypeLevel.TMap 81 | hs-source-dirs: src 82 | build-depends: aeson >=1.4.2.0 && <1.6 || >=2.0.1.0 && <2.3 83 | , aeson-pretty >=0.8.7 && <0.9 84 | , base >=4.9.1.0 && <4.22 85 | , base-compat >=0.10.5 && <0.15 86 | , bytestring >=0.10.8.1 && <0.13 87 | , http-media >=0.7.1.3 && <0.9 88 | , insert-ordered-containers >=0.2.1.0 && <0.3 89 | , lens >=4.17 && <5.4 90 | , servant >=0.17 && <0.21 91 | , singleton-bool >=0.1.4 && <0.2 92 | , openapi3 >=3.2.3 && <3.3 93 | , text >=1.2.3.0 && <3 94 | , unordered-containers >=0.2.9.0 && <0.3 95 | 96 | , hspec 97 | , QuickCheck 98 | default-language: Haskell2010 99 | 100 | test-suite doctests 101 | ghc-options: -Wall 102 | build-depends: 103 | base <5, 104 | directory >= 1.0, 105 | doctest >= 0.11.1 && <0.25, 106 | servant, 107 | QuickCheck, 108 | filepath 109 | default-language: Haskell2010 110 | hs-source-dirs: test 111 | main-is: doctests.hs 112 | type: exitcode-stdio-1.0 113 | 114 | test-suite spec 115 | ghc-options: -Wall 116 | type: exitcode-stdio-1.0 117 | hs-source-dirs: test 118 | main-is: Spec.hs 119 | build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.12 120 | build-depends: base <5 121 | , base-compat 122 | , aeson 123 | , hspec >=2.6.0 && <2.12 124 | , QuickCheck 125 | , lens 126 | , lens-aeson >=1.0.2 && <1.3 127 | , servant 128 | , servant-openapi3 129 | -- openapi3 3.1.0 fixes some ordering-related issues, making tests stable 130 | , openapi3 >= 3.1.0 131 | , text 132 | , template-haskell 133 | , utf8-string >=1.0.1.1 && <1.1 134 | , time 135 | , vector 136 | other-modules: 137 | Servant.OpenApiSpec 138 | default-language: Haskell2010 139 | -------------------------------------------------------------------------------- /src/Servant/OpenApi.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Servant.OpenApi 3 | -- License: BSD3 4 | -- Maintainer: Nickolay Kudasov 5 | -- Stability: experimental 6 | -- 7 | -- This module provides means to generate and manipulate 8 | -- OpenApi specification for servant APIs. 9 | -- 10 | -- OpenApi is a project used to describe and document RESTful APIs. 11 | -- 12 | -- The OpenApi specification defines a set of files required to describe such an API. 13 | -- These files can then be used by the OpenApi-UI project to display the API 14 | -- and OpenApi-Codegen to generate clients in various languages. 15 | -- Additional utilities can also take advantage of the resulting files, such as testing tools. 16 | -- 17 | -- For more information see . 18 | module Servant.OpenApi ( 19 | -- * How to use this library 20 | -- $howto 21 | 22 | -- ** Generate @'OpenApi'@ 23 | -- $generate 24 | 25 | -- ** Annotate 26 | -- $annotate 27 | 28 | -- ** Test 29 | -- $test 30 | 31 | -- ** Serve 32 | -- $serve 33 | 34 | -- * @'HasOpenApi'@ class 35 | HasOpenApi(..), 36 | 37 | -- * Manipulation 38 | subOperations, 39 | 40 | -- * Testing 41 | validateEveryToJSON, 42 | validateEveryToJSONWithPatternChecker, 43 | ) where 44 | 45 | import Servant.OpenApi.Internal 46 | import Servant.OpenApi.Test 47 | import Servant.OpenApi.Internal.Orphans () 48 | 49 | -- $setup 50 | -- >>> import Control.Applicative 51 | -- >>> import Control.Lens 52 | -- >>> import Data.Aeson 53 | -- >>> import Data.OpenApi 54 | -- >>> import Data.Typeable 55 | -- >>> import GHC.Generics 56 | -- >>> import Servant.API 57 | -- >>> import Test.Hspec 58 | -- >>> import Test.QuickCheck 59 | -- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8 60 | -- >>> import Servant.OpenApi.Internal.Test 61 | -- >>> :set -XDataKinds 62 | -- >>> :set -XDeriveDataTypeable 63 | -- >>> :set -XDeriveGeneric 64 | -- >>> :set -XGeneralizedNewtypeDeriving 65 | -- >>> :set -XOverloadedStrings 66 | -- >>> :set -XTypeOperators 67 | -- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable) 68 | -- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON) 69 | -- >>> instance ToJSON User 70 | -- >>> instance ToSchema User 71 | -- >>> instance ToSchema UserId 72 | -- >>> instance ToParamSchema UserId 73 | -- >>> type GetUsers = Get '[JSON] [User] 74 | -- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User 75 | -- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId 76 | -- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser 77 | 78 | -- $howto 79 | -- 80 | -- This section explains how to use this library to generate OpenApi specification, 81 | -- modify it and run automatic tests for a servant API. 82 | -- 83 | -- For the purposes of this section we will use this servant API: 84 | -- 85 | -- >>> data User = User { name :: String, age :: Int } deriving (Show, Generic, Typeable) 86 | -- >>> newtype UserId = UserId Integer deriving (Show, Generic, Typeable, ToJSON) 87 | -- >>> instance ToJSON User 88 | -- >>> instance ToSchema User 89 | -- >>> instance ToSchema UserId 90 | -- >>> instance ToParamSchema UserId 91 | -- >>> type GetUsers = Get '[JSON] [User] 92 | -- >>> type GetUser = Capture "user_id" UserId :> Get '[JSON] User 93 | -- >>> type PostUser = ReqBody '[JSON] User :> Post '[JSON] UserId 94 | -- >>> type UserAPI = GetUsers :<|> GetUser :<|> PostUser 95 | -- 96 | -- Here we define a user API with three endpoints. @GetUsers@ endpoint returns a list of all users. 97 | -- @GetUser@ returns a user given his\/her ID. @PostUser@ creates a new user and returns his\/her ID. 98 | 99 | -- $generate 100 | -- In order to generate @'OpenApi'@ specification for a servant API, just use @'toOpenApi'@: 101 | -- 102 | -- >>> BSL8.putStrLn $ encodePretty $ toOpenApi (Proxy :: Proxy UserAPI) 103 | -- { 104 | -- "components": { 105 | -- "schemas": { 106 | -- "User": { 107 | -- "properties": { 108 | -- "age": { 109 | -- "maximum": 9223372036854775807, 110 | -- "minimum": -9223372036854775808, 111 | -- "type": "integer" 112 | -- }, 113 | -- "name": { 114 | -- "type": "string" 115 | -- } 116 | -- }, 117 | -- "required": [ 118 | -- "name", 119 | -- "age" 120 | -- ], 121 | -- "type": "object" 122 | -- }, 123 | -- "UserId": { 124 | -- "type": "integer" 125 | -- } 126 | -- } 127 | -- }, 128 | -- "info": { 129 | -- "title": "", 130 | -- "version": "" 131 | -- }, 132 | -- "openapi": "3.0.0", 133 | -- "paths": { 134 | -- "/": { 135 | -- "get": { 136 | -- "responses": { 137 | -- "200": { 138 | -- "content": { 139 | -- "application/json;charset=utf-8": { 140 | -- "schema": { 141 | -- "items": { 142 | -- "$ref": "#/components/schemas/User" 143 | -- }, 144 | -- "type": "array" 145 | -- } 146 | -- } 147 | -- }, 148 | -- "description": "" 149 | -- } 150 | -- } 151 | -- }, 152 | -- "post": { 153 | -- "requestBody": { 154 | -- "content": { 155 | -- "application/json;charset=utf-8": { 156 | -- "schema": { 157 | -- "$ref": "#/components/schemas/User" 158 | -- } 159 | -- } 160 | -- } 161 | -- }, 162 | -- "responses": { 163 | -- "200": { 164 | -- "content": { 165 | -- "application/json;charset=utf-8": { 166 | -- "schema": { 167 | -- "$ref": "#/components/schemas/UserId" 168 | -- } 169 | -- } 170 | -- }, 171 | -- "description": "" 172 | -- }, 173 | -- "400": { 174 | -- "description": "Invalid `body`" 175 | -- } 176 | -- } 177 | -- } 178 | -- }, 179 | -- "/{user_id}": { 180 | -- "get": { 181 | -- "parameters": [ 182 | -- { 183 | -- "in": "path", 184 | -- "name": "user_id", 185 | -- "required": true, 186 | -- "schema": { 187 | -- "type": "integer" 188 | -- } 189 | -- } 190 | -- ], 191 | -- "responses": { 192 | -- "200": { 193 | -- "content": { 194 | -- "application/json;charset=utf-8": { 195 | -- "schema": { 196 | -- "$ref": "#/components/schemas/User" 197 | -- } 198 | -- } 199 | -- }, 200 | -- "description": "" 201 | -- }, 202 | -- "404": { 203 | -- "description": "`user_id` not found" 204 | -- } 205 | -- } 206 | -- } 207 | -- } 208 | -- } 209 | -- } 210 | -- 211 | -- By default @'toOpenApi'@ will generate specification for all API routes, parameters, headers, responses and data schemas. 212 | -- 213 | -- For some parameters it will also add 400 and/or 404 responses with a description mentioning parameter name. 214 | -- 215 | -- Data schemas come from @'ToParamSchema'@ and @'ToSchema'@ classes. 216 | 217 | -- $annotate 218 | -- While initially generated @'OpenApi'@ looks good, it lacks some information it can't get from a servant API. 219 | -- 220 | -- We can add this information using field lenses from @"Data.OpenApi"@: 221 | -- 222 | -- >>> :{ 223 | -- BSL8.putStrLn $ encodePretty $ toOpenApi (Proxy :: Proxy UserAPI) 224 | -- & info.title .~ "User API" 225 | -- & info.version .~ "1.0" 226 | -- & info.description ?~ "This is an API for the Users service" 227 | -- & info.license ?~ "MIT" 228 | -- & servers .~ ["https://example.com"] 229 | -- :} 230 | -- { 231 | -- "components": { 232 | -- "schemas": { 233 | -- "User": { 234 | -- "properties": { 235 | -- "age": { 236 | -- "maximum": 9223372036854775807, 237 | -- "minimum": -9223372036854775808, 238 | -- "type": "integer" 239 | -- }, 240 | -- "name": { 241 | -- "type": "string" 242 | -- } 243 | -- }, 244 | -- "required": [ 245 | -- "name", 246 | -- "age" 247 | -- ], 248 | -- "type": "object" 249 | -- }, 250 | -- "UserId": { 251 | -- "type": "integer" 252 | -- } 253 | -- } 254 | -- }, 255 | -- "info": { 256 | -- "description": "This is an API for the Users service", 257 | -- "license": { 258 | -- "name": "MIT" 259 | -- }, 260 | -- "title": "User API", 261 | -- "version": "1.0" 262 | -- }, 263 | -- "openapi": "3.0.0", 264 | -- "paths": { 265 | -- "/": { 266 | -- "get": { 267 | -- "responses": { 268 | -- "200": { 269 | -- "content": { 270 | -- "application/json;charset=utf-8": { 271 | -- "schema": { 272 | -- "items": { 273 | -- "$ref": "#/components/schemas/User" 274 | -- }, 275 | -- "type": "array" 276 | -- } 277 | -- } 278 | -- }, 279 | -- "description": "" 280 | -- } 281 | -- } 282 | -- }, 283 | -- "post": { 284 | -- "requestBody": { 285 | -- "content": { 286 | -- "application/json;charset=utf-8": { 287 | -- "schema": { 288 | -- "$ref": "#/components/schemas/User" 289 | -- } 290 | -- } 291 | -- } 292 | -- }, 293 | -- "responses": { 294 | -- "200": { 295 | -- "content": { 296 | -- "application/json;charset=utf-8": { 297 | -- "schema": { 298 | -- "$ref": "#/components/schemas/UserId" 299 | -- } 300 | -- } 301 | -- }, 302 | -- "description": "" 303 | -- }, 304 | -- "400": { 305 | -- "description": "Invalid `body`" 306 | -- } 307 | -- } 308 | -- } 309 | -- }, 310 | -- "/{user_id}": { 311 | -- "get": { 312 | -- "parameters": [ 313 | -- { 314 | -- "in": "path", 315 | -- "name": "user_id", 316 | -- "required": true, 317 | -- "schema": { 318 | -- "type": "integer" 319 | -- } 320 | -- } 321 | -- ], 322 | -- "responses": { 323 | -- "200": { 324 | -- "content": { 325 | -- "application/json;charset=utf-8": { 326 | -- "schema": { 327 | -- "$ref": "#/components/schemas/User" 328 | -- } 329 | -- } 330 | -- }, 331 | -- "description": "" 332 | -- }, 333 | -- "404": { 334 | -- "description": "`user_id` not found" 335 | -- } 336 | -- } 337 | -- } 338 | -- } 339 | -- }, 340 | -- "servers": [ 341 | -- { 342 | -- "url": "https://example.com" 343 | -- } 344 | -- ] 345 | -- } 346 | -- 347 | -- It is also useful to annotate or modify certain endpoints. 348 | -- @'subOperations'@ provides a convenient way to zoom into a part of an API. 349 | -- 350 | -- @'subOperations' sub api@ traverses all operations of the @api@ which are also present in @sub@. 351 | -- Furthermore, @sub@ is required to be an exact sub API of @api. Otherwise it will not typecheck. 352 | -- 353 | -- @"Data.OpenApi.Operation"@ provides some useful helpers that can be used with @'subOperations'@. 354 | -- One example is applying tags to certain endpoints: 355 | -- 356 | -- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI) 357 | -- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI) 358 | -- >>> :{ 359 | -- BSL8.putStrLn $ encodePretty $ toOpenApi (Proxy :: Proxy UserAPI) 360 | -- & applyTagsFor getOps ["get" & description ?~ "GET operations"] 361 | -- & applyTagsFor postOps ["post" & description ?~ "POST operations"] 362 | -- :} 363 | -- { 364 | -- "components": { 365 | -- "schemas": { 366 | -- "User": { 367 | -- "properties": { 368 | -- "age": { 369 | -- "maximum": 9223372036854775807, 370 | -- "minimum": -9223372036854775808, 371 | -- "type": "integer" 372 | -- }, 373 | -- "name": { 374 | -- "type": "string" 375 | -- } 376 | -- }, 377 | -- "required": [ 378 | -- "name", 379 | -- "age" 380 | -- ], 381 | -- "type": "object" 382 | -- }, 383 | -- "UserId": { 384 | -- "type": "integer" 385 | -- } 386 | -- } 387 | -- }, 388 | -- "info": { 389 | -- "title": "", 390 | -- "version": "" 391 | -- }, 392 | -- "openapi": "3.0.0", 393 | -- "paths": { 394 | -- "/": { 395 | -- "get": { 396 | -- "responses": { 397 | -- "200": { 398 | -- "content": { 399 | -- "application/json;charset=utf-8": { 400 | -- "schema": { 401 | -- "items": { 402 | -- "$ref": "#/components/schemas/User" 403 | -- }, 404 | -- "type": "array" 405 | -- } 406 | -- } 407 | -- }, 408 | -- "description": "" 409 | -- } 410 | -- }, 411 | -- "tags": [ 412 | -- "get" 413 | -- ] 414 | -- }, 415 | -- "post": { 416 | -- "requestBody": { 417 | -- "content": { 418 | -- "application/json;charset=utf-8": { 419 | -- "schema": { 420 | -- "$ref": "#/components/schemas/User" 421 | -- } 422 | -- } 423 | -- } 424 | -- }, 425 | -- "responses": { 426 | -- "200": { 427 | -- "content": { 428 | -- "application/json;charset=utf-8": { 429 | -- "schema": { 430 | -- "$ref": "#/components/schemas/UserId" 431 | -- } 432 | -- } 433 | -- }, 434 | -- "description": "" 435 | -- }, 436 | -- "400": { 437 | -- "description": "Invalid `body`" 438 | -- } 439 | -- }, 440 | -- "tags": [ 441 | -- "post" 442 | -- ] 443 | -- } 444 | -- }, 445 | -- "/{user_id}": { 446 | -- "get": { 447 | -- "parameters": [ 448 | -- { 449 | -- "in": "path", 450 | -- "name": "user_id", 451 | -- "required": true, 452 | -- "schema": { 453 | -- "type": "integer" 454 | -- } 455 | -- } 456 | -- ], 457 | -- "responses": { 458 | -- "200": { 459 | -- "content": { 460 | -- "application/json;charset=utf-8": { 461 | -- "schema": { 462 | -- "$ref": "#/components/schemas/User" 463 | -- } 464 | -- } 465 | -- }, 466 | -- "description": "" 467 | -- }, 468 | -- "404": { 469 | -- "description": "`user_id` not found" 470 | -- } 471 | -- }, 472 | -- "tags": [ 473 | -- "get" 474 | -- ] 475 | -- } 476 | -- } 477 | -- }, 478 | -- "tags": [ 479 | -- { 480 | -- "description": "GET operations", 481 | -- "name": "get" 482 | -- }, 483 | -- { 484 | -- "description": "POST operations", 485 | -- "name": "post" 486 | -- } 487 | -- ] 488 | -- } 489 | -- 490 | -- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API. 491 | 492 | -- $test 493 | -- Automatic generation of data schemas uses @'ToSchema'@ instances for the types 494 | -- used in a servant API. But to encode/decode actual data servant uses different classes. 495 | -- For instance in @UserAPI@ @User@ is always encoded/decoded using @'ToJSON'@ and @'FromJSON'@ instances. 496 | -- 497 | -- To be sure your Haskell server/client handles data properly you need to check 498 | -- that @'ToJSON'@ instance always generates values that satisfy schema produced 499 | -- by @'ToSchema'@ instance. 500 | -- 501 | -- With @'validateEveryToJSON'@ it is possible to test all those instances automatically, 502 | -- without having to write down every type: 503 | -- 504 | -- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary 505 | -- >>> instance Arbitrary UserId where arbitrary = UserId <$> arbitrary 506 | -- >>> hspec $ validateEveryToJSON (Proxy :: Proxy UserAPI) 507 | -- 508 | -- [User]... 509 | -- ... 510 | -- User... 511 | -- ... 512 | -- UserId... 513 | -- ... 514 | -- Finished in ... seconds 515 | -- ...3 examples, 0 failures... 516 | -- 517 | -- Although servant is great, chances are that your API clients don't use Haskell. 518 | -- In many cases @swagger.json@ serves as a specification, not a Haskell type. 519 | -- 520 | -- In this cases it is a good idea to store generated and annotated @'OpenApi'@ in a @swagger.json@ file 521 | -- under a version control system (such as Git, Subversion, Mercurial, etc.). 522 | -- 523 | -- It is also recommended to version API based on changes to the @swagger.json@ rather than changes 524 | -- to the Haskell API. 525 | -- 526 | -- See for an example of a complete test suite for a swagger specification. 527 | 528 | -- $serve 529 | -- If you're implementing a server for an API, you might also want to serve its @'OpenApi'@ specification. 530 | -- 531 | -- See for an example of a server. 532 | -------------------------------------------------------------------------------- /src/Servant/OpenApi/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | #if __GLASGOW_HASKELL__ >= 806 12 | {-# LANGUAGE UndecidableInstances #-} 13 | #endif 14 | {-# OPTIONS_GHC -Wno-orphans #-} 15 | module Servant.OpenApi.Internal where 16 | 17 | import Prelude () 18 | import Prelude.Compat 19 | 20 | #if MIN_VERSION_servant(0,18,1) 21 | import Control.Applicative ((<|>)) 22 | #endif 23 | import Control.Lens 24 | import Data.Aeson 25 | import Data.Foldable (toList) 26 | import Data.HashMap.Strict.InsOrd (InsOrdHashMap) 27 | import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap 28 | import Data.OpenApi hiding (Header, contentType) 29 | import qualified Data.OpenApi as OpenApi 30 | import Data.OpenApi.Declare 31 | import Data.Proxy 32 | import Data.Singletons.Bool 33 | import Data.Text (Text) 34 | import qualified Data.Text as Text 35 | import Data.Typeable (Typeable) 36 | import GHC.TypeLits 37 | import Network.HTTP.Media (MediaType) 38 | import Servant.API 39 | import Servant.API.Description (FoldDescription, reflectDescription) 40 | import Servant.API.Modifiers (FoldRequired) 41 | #if MIN_VERSION_servant(0,19,0) 42 | import Servant.API.Generic (ToServantApi) 43 | #endif 44 | 45 | import Servant.OpenApi.Internal.TypeLevel.API 46 | 47 | -- | Generate a OpenApi specification for a servant API. 48 | -- 49 | -- To generate OpenApi specification, your data types need 50 | -- @'ToParamSchema'@ and/or @'ToSchema'@ instances. 51 | -- 52 | -- @'ToParamSchema'@ is used for @'Capture'@, @'QueryParam'@ and @'Header'@. 53 | -- @'ToSchema'@ is used for @'ReqBody'@ and response data types. 54 | -- 55 | -- You can easily derive those instances via @Generic@. 56 | -- For more information, refer to 57 | -- . 58 | -- 59 | -- Example: 60 | -- 61 | -- @ 62 | -- newtype Username = Username String deriving (Generic, ToText) 63 | -- 64 | -- instance ToParamSchema Username 65 | -- 66 | -- data User = User 67 | -- { username :: Username 68 | -- , fullname :: String 69 | -- } deriving (Generic) 70 | -- 71 | -- instance ToJSON User 72 | -- instance ToSchema User 73 | -- 74 | -- type MyAPI = QueryParam "username" Username :> Get '[JSON] User 75 | -- 76 | -- myOpenApi :: OpenApi 77 | -- myOpenApi = toOpenApi (Proxy :: Proxy MyAPI) 78 | -- @ 79 | class HasOpenApi api where 80 | -- | Generate a OpenApi specification for a servant API. 81 | toOpenApi :: Proxy api -> OpenApi 82 | 83 | instance HasOpenApi Raw where 84 | toOpenApi _ = mempty & paths . at "/" ?~ mempty 85 | 86 | instance HasOpenApi EmptyAPI where 87 | toOpenApi _ = mempty 88 | 89 | -- | All operations of sub API. 90 | -- This is similar to @'operationsOf'@ but ensures that operations 91 | -- indeed belong to the API at compile time. 92 | subOperations :: (IsSubAPI sub api, HasOpenApi sub) => 93 | Proxy sub -- ^ Part of a servant API. 94 | -> Proxy api -- ^ The whole servant API. 95 | -> Traversal' OpenApi Operation 96 | subOperations sub _ = operationsOf (toOpenApi sub) 97 | 98 | -- | Make a singleton OpenApi spec (with only one endpoint). 99 | -- For endpoints with no content see 'mkEndpointNoContent'. 100 | mkEndpoint :: forall a cs hs proxy method status. 101 | (ToSchema a, AllAccept cs, AllToResponseHeader hs, OpenApiMethod method, KnownNat status) 102 | => FilePath -- ^ Endpoint path. 103 | -> proxy (Verb method status cs (Headers hs a)) -- ^ Method, content-types, headers and response. 104 | -> OpenApi 105 | mkEndpoint path proxy 106 | = mkEndpointWithSchemaRef (Just ref) path proxy 107 | & components.schemas .~ defs 108 | where 109 | (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty 110 | 111 | -- | Make a singletone 'OpenApi' spec (with only one endpoint) and with no content schema. 112 | mkEndpointNoContent :: forall nocontent cs hs proxy method status. 113 | (AllAccept cs, AllToResponseHeader hs, OpenApiMethod method, KnownNat status) 114 | => FilePath -- ^ Endpoint path. 115 | -> proxy (Verb method status cs (Headers hs nocontent)) -- ^ Method, content-types, headers and response. 116 | -> OpenApi 117 | mkEndpointNoContent path proxy 118 | = mkEndpointWithSchemaRef Nothing path proxy 119 | 120 | -- | Like @'mkEndpoint'@ but with explicit schema reference. 121 | -- Unlike @'mkEndpoint'@ this function does not update @'definitions'@. 122 | mkEndpointWithSchemaRef :: forall cs hs proxy method status a. 123 | (AllAccept cs, AllToResponseHeader hs, OpenApiMethod method, KnownNat status) 124 | => Maybe (Referenced Schema) 125 | -> FilePath 126 | -> proxy (Verb method status cs (Headers hs a)) 127 | -> OpenApi 128 | mkEndpointWithSchemaRef mref path _ = mempty 129 | & paths.at path ?~ 130 | (mempty & method ?~ (mempty 131 | & at code ?~ Inline (mempty 132 | & content .~ InsOrdHashMap.fromList 133 | [(t, mempty & schema .~ mref) | t <- responseContentTypes] 134 | & headers .~ responseHeaders))) 135 | where 136 | method = openApiMethod (Proxy :: Proxy method) 137 | code = fromIntegral (natVal (Proxy :: Proxy status)) 138 | responseContentTypes = allContentType (Proxy :: Proxy cs) 139 | responseHeaders = Inline <$> toAllResponseHeaders (Proxy :: Proxy hs) 140 | 141 | mkEndpointNoContentVerb :: forall proxy method. 142 | (OpenApiMethod method) 143 | => FilePath -- ^ Endpoint path. 144 | -> proxy (NoContentVerb method) -- ^ Method 145 | -> OpenApi 146 | mkEndpointNoContentVerb path _ = mempty 147 | & paths.at path ?~ 148 | (mempty & method ?~ (mempty 149 | & at code ?~ Inline mempty)) 150 | where 151 | method = openApiMethod (Proxy :: Proxy method) 152 | code = 204 -- hardcoded in servant-server 153 | 154 | -- | Add parameter to every operation in the spec. 155 | addParam :: Param -> OpenApi -> OpenApi 156 | addParam param = allOperations.parameters %~ (Inline param :) 157 | 158 | -- | Add RequestBody to every operations in the spec. 159 | addRequestBody :: RequestBody -> OpenApi -> OpenApi 160 | addRequestBody rb = allOperations . requestBody ?~ Inline rb 161 | 162 | -- | Format given text as inline code in Markdown. 163 | markdownCode :: Text -> Text 164 | markdownCode s = "`" <> s <> "`" 165 | 166 | addDefaultResponse404 :: ParamName -> OpenApi -> OpenApi 167 | addDefaultResponse404 pname = setResponseWith (\old _new -> alter404 old) 404 (return response404) 168 | where 169 | sname = markdownCode pname 170 | description404 = sname <> " not found" 171 | alter404 = description %~ ((sname <> " or ") <>) 172 | response404 = mempty & description .~ description404 173 | 174 | addDefaultResponse400 :: ParamName -> OpenApi -> OpenApi 175 | addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400) 176 | where 177 | sname = markdownCode pname 178 | description400 = "Invalid " <> sname 179 | alter400 = description %~ (<> (" or " <> sname)) 180 | response400 = mempty & description .~ description400 181 | 182 | -- | Methods, available for OpenApi. 183 | class OpenApiMethod method where 184 | openApiMethod :: proxy method -> Lens' PathItem (Maybe Operation) 185 | 186 | instance OpenApiMethod 'GET where openApiMethod _ = get 187 | instance OpenApiMethod 'PUT where openApiMethod _ = put 188 | instance OpenApiMethod 'POST where openApiMethod _ = post 189 | instance OpenApiMethod 'DELETE where openApiMethod _ = delete 190 | instance OpenApiMethod 'OPTIONS where openApiMethod _ = options 191 | instance OpenApiMethod 'HEAD where openApiMethod _ = head_ 192 | instance OpenApiMethod 'PATCH where openApiMethod _ = patch 193 | 194 | #if MIN_VERSION_servant(0,18,1) 195 | instance HasOpenApi (UVerb method cs '[]) where 196 | toOpenApi _ = mempty 197 | 198 | -- | @since <2.0.1.0> 199 | instance 200 | {-# OVERLAPPABLE #-} 201 | ( ToSchema a, 202 | HasStatus a, 203 | AllAccept cs, 204 | OpenApiMethod method, 205 | HasOpenApi (UVerb method cs as) 206 | ) => 207 | HasOpenApi (UVerb method cs (a ': as)) 208 | where 209 | toOpenApi _ = 210 | toOpenApi (Proxy :: Proxy (Verb method (StatusOf a) cs a)) 211 | `combineSwagger` toOpenApi (Proxy :: Proxy (UVerb method cs as)) 212 | where 213 | -- workaround for https://github.com/GetShopTV/swagger2/issues/218 214 | combinePathItem :: PathItem -> PathItem -> PathItem 215 | combinePathItem s t = PathItem 216 | { _pathItemGet = _pathItemGet s <> _pathItemGet t 217 | , _pathItemPut = _pathItemPut s <> _pathItemPut t 218 | , _pathItemPost = _pathItemPost s <> _pathItemPost t 219 | , _pathItemDelete = _pathItemDelete s <> _pathItemDelete t 220 | , _pathItemOptions = _pathItemOptions s <> _pathItemOptions t 221 | , _pathItemHead = _pathItemHead s <> _pathItemHead t 222 | , _pathItemPatch = _pathItemPatch s <> _pathItemPatch t 223 | , _pathItemTrace = _pathItemTrace s <> _pathItemTrace t 224 | , _pathItemParameters = _pathItemParameters s <> _pathItemParameters t 225 | , _pathItemSummary = _pathItemSummary s <|> _pathItemSummary t 226 | , _pathItemDescription = _pathItemDescription s <|> _pathItemDescription t 227 | , _pathItemServers = _pathItemServers s <> _pathItemServers t 228 | } 229 | 230 | combineSwagger :: OpenApi -> OpenApi -> OpenApi 231 | combineSwagger s t = OpenApi 232 | { _openApiOpenapi = _openApiOpenapi s <> _openApiOpenapi t 233 | , _openApiInfo = _openApiInfo s <> _openApiInfo t 234 | , _openApiServers = _openApiServers s <> _openApiServers t 235 | , _openApiPaths = InsOrdHashMap.unionWith combinePathItem (_openApiPaths s) (_openApiPaths t) 236 | , _openApiComponents = _openApiComponents s <> _openApiComponents t 237 | , _openApiSecurity = _openApiSecurity s <> _openApiSecurity t 238 | , _openApiTags = _openApiTags s <> _openApiTags t 239 | , _openApiExternalDocs = _openApiExternalDocs s <|> _openApiExternalDocs t 240 | } 241 | 242 | instance (Typeable (WithStatus s a), ToSchema a) => ToSchema (WithStatus s a) where 243 | declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a) 244 | #endif 245 | 246 | instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, KnownNat status, OpenApiMethod method) => HasOpenApi (Verb method status cs a) where 247 | toOpenApi _ = toOpenApi (Proxy :: Proxy (Verb method status cs (Headers '[] a))) 248 | 249 | -- | @since 1.1.7 250 | instance (ToSchema a, Accept ct, KnownNat status, OpenApiMethod method) => HasOpenApi (Stream method status fr ct a) where 251 | toOpenApi _ = toOpenApi (Proxy :: Proxy (Verb method status '[ct] (Headers '[] a))) 252 | 253 | instance {-# OVERLAPPABLE #-} (ToSchema a, AllAccept cs, AllToResponseHeader hs, KnownNat status, OpenApiMethod method) 254 | => HasOpenApi (Verb method status cs (Headers hs a)) where 255 | toOpenApi = mkEndpoint "/" 256 | 257 | -- ATTENTION: do not remove this instance! 258 | -- A similar instance above will always use the more general 259 | -- polymorphic -- HasOpenApi instance and will result in a type error 260 | -- since 'NoContent' does not have a 'ToSchema' instance. 261 | instance (AllAccept cs, KnownNat status, OpenApiMethod method) => HasOpenApi (Verb method status cs NoContent) where 262 | toOpenApi _ = toOpenApi (Proxy :: Proxy (Verb method status cs (Headers '[] NoContent))) 263 | 264 | instance (AllAccept cs, AllToResponseHeader hs, KnownNat status, OpenApiMethod method) 265 | => HasOpenApi (Verb method status cs (Headers hs NoContent)) where 266 | toOpenApi = mkEndpointNoContent "/" 267 | 268 | instance (OpenApiMethod method) => HasOpenApi (NoContentVerb method) where 269 | toOpenApi = mkEndpointNoContentVerb "/" 270 | 271 | instance (HasOpenApi a, HasOpenApi b) => HasOpenApi (a :<|> b) where 272 | toOpenApi _ = toOpenApi (Proxy :: Proxy a) <> toOpenApi (Proxy :: Proxy b) 273 | 274 | -- | @'Vault'@ combinator does not change our specification at all. 275 | instance (HasOpenApi sub) => HasOpenApi (Vault :> sub) where 276 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 277 | 278 | -- | @'IsSecure'@ combinator does not change our specification at all. 279 | instance (HasOpenApi sub) => HasOpenApi (IsSecure :> sub) where 280 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 281 | 282 | -- | @'RemoteHost'@ combinator does not change our specification at all. 283 | instance (HasOpenApi sub) => HasOpenApi (RemoteHost :> sub) where 284 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 285 | 286 | -- | @'HttpVersion'@ combinator does not change our specification at all. 287 | instance (HasOpenApi sub) => HasOpenApi (HttpVersion :> sub) where 288 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 289 | 290 | #if MIN_VERSION_servant(0,20,0) 291 | -- | @'WithResource'@ combinator does not change our specification at all. 292 | instance (HasOpenApi sub) => HasOpenApi (WithResource res :> sub) where 293 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 294 | #endif 295 | 296 | -- | @'WithNamedContext'@ combinator does not change our specification at all. 297 | instance (HasOpenApi sub) => HasOpenApi (WithNamedContext x c sub) where 298 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 299 | 300 | instance (KnownSymbol sym, HasOpenApi sub) => HasOpenApi (sym :> sub) where 301 | toOpenApi _ = prependPath piece (toOpenApi (Proxy :: Proxy sub)) 302 | where 303 | piece = symbolVal (Proxy :: Proxy sym) 304 | 305 | instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub, KnownSymbol (FoldDescription mods)) => HasOpenApi (Capture' mods sym a :> sub) where 306 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 307 | & addParam param 308 | & prependPath capture 309 | & addDefaultResponse404 tname 310 | where 311 | pname = symbolVal (Proxy :: Proxy sym) 312 | tname = Text.pack pname 313 | transDesc "" = Nothing 314 | transDesc desc = Just (Text.pack desc) 315 | capture = "{" <> pname <> "}" 316 | param = mempty 317 | & name .~ tname 318 | & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) 319 | & required ?~ True 320 | & in_ .~ ParamPath 321 | & schema ?~ Inline (toParamSchema (Proxy :: Proxy a)) 322 | 323 | -- | OpenApi Spec doesn't have a notion of CaptureAll, this instance is the best effort. 324 | instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub) => HasOpenApi (CaptureAll sym a :> sub) where 325 | toOpenApi _ = toOpenApi (Proxy :: Proxy (Capture sym a :> sub)) 326 | 327 | instance (KnownSymbol desc, HasOpenApi api) => HasOpenApi (Description desc :> api) where 328 | toOpenApi _ = toOpenApi (Proxy :: Proxy api) 329 | & allOperations.description %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) 330 | 331 | instance (KnownSymbol desc, HasOpenApi api) => HasOpenApi (Summary desc :> api) where 332 | toOpenApi _ = toOpenApi (Proxy :: Proxy api) 333 | & allOperations.summary %~ (Just (Text.pack (symbolVal (Proxy :: Proxy desc))) <>) 334 | 335 | instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasOpenApi (QueryParam' mods sym a :> sub) where 336 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 337 | & addParam param 338 | & addDefaultResponse400 tname 339 | where 340 | tname = Text.pack (symbolVal (Proxy :: Proxy sym)) 341 | transDesc "" = Nothing 342 | transDesc desc = Just (Text.pack desc) 343 | param = mempty 344 | & name .~ tname 345 | & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) 346 | & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods)) 347 | & in_ .~ ParamQuery 348 | & schema ?~ Inline sch 349 | sch = toParamSchema (Proxy :: Proxy a) 350 | 351 | instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub) => HasOpenApi (QueryParams sym a :> sub) where 352 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 353 | & addParam param 354 | & addDefaultResponse400 tname 355 | where 356 | tname = Text.pack (symbolVal (Proxy :: Proxy sym)) 357 | param = mempty 358 | & name .~ tname 359 | & in_ .~ ParamQuery 360 | & schema ?~ Inline pschema 361 | pschema = mempty 362 | & type_ ?~ OpenApiArray 363 | & items ?~ OpenApiItemsObject (Inline $ toParamSchema (Proxy :: Proxy a)) 364 | 365 | instance (KnownSymbol sym, HasOpenApi sub) => HasOpenApi (QueryFlag sym :> sub) where 366 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 367 | & addParam param 368 | & addDefaultResponse400 tname 369 | where 370 | tname = Text.pack (symbolVal (Proxy :: Proxy sym)) 371 | param = mempty 372 | & name .~ tname 373 | & in_ .~ ParamQuery 374 | & allowEmptyValue ?~ True 375 | & schema ?~ (Inline $ (toParamSchema (Proxy :: Proxy Bool)) 376 | & default_ ?~ toJSON False) 377 | 378 | instance (KnownSymbol sym, ToParamSchema a, HasOpenApi sub, SBoolI (FoldRequired mods), KnownSymbol (FoldDescription mods)) => HasOpenApi (Header' mods sym a :> sub) where 379 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 380 | & addParam param 381 | & addDefaultResponse400 tname 382 | where 383 | tname = Text.pack (symbolVal (Proxy :: Proxy sym)) 384 | transDesc "" = Nothing 385 | transDesc desc = Just (Text.pack desc) 386 | param = mempty 387 | & name .~ tname 388 | & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) 389 | & required ?~ reflectBool (Proxy :: Proxy (FoldRequired mods)) 390 | & in_ .~ ParamHeader 391 | & schema ?~ (Inline $ toParamSchema (Proxy :: Proxy a)) 392 | 393 | instance (ToSchema a, AllAccept cs, HasOpenApi sub, KnownSymbol (FoldDescription mods)) => HasOpenApi (ReqBody' mods cs a :> sub) where 394 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 395 | & addRequestBody reqBody 396 | & addDefaultResponse400 tname 397 | & components.schemas %~ (<> defs) 398 | where 399 | tname = "body" 400 | transDesc "" = Nothing 401 | transDesc desc = Just (Text.pack desc) 402 | (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty 403 | reqBody = (mempty :: RequestBody) 404 | & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) 405 | & content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ ref) | t <- allContentType (Proxy :: Proxy cs)] 406 | 407 | -- | This instance is an approximation. 408 | -- 409 | -- @since 1.1.7 410 | instance (ToSchema a, Accept ct, HasOpenApi sub, KnownSymbol (FoldDescription mods)) => HasOpenApi (StreamBody' mods fr ct a :> sub) where 411 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 412 | & addRequestBody reqBody 413 | & addDefaultResponse400 tname 414 | & components.schemas %~ (<> defs) 415 | where 416 | tname = "body" 417 | transDesc "" = Nothing 418 | transDesc desc = Just (Text.pack desc) 419 | (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty 420 | reqBody = (mempty :: RequestBody) 421 | & description .~ transDesc (reflectDescription (Proxy :: Proxy mods)) 422 | & content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ ref) | t <- toList $ contentTypes (Proxy :: Proxy ct)] 423 | 424 | #if MIN_VERSION_servant(0,18,2) 425 | instance (HasOpenApi sub) => HasOpenApi (Fragment a :> sub) where 426 | toOpenApi _ = toOpenApi (Proxy :: Proxy sub) 427 | #endif 428 | 429 | #if MIN_VERSION_servant(0,19,0) 430 | instance (HasOpenApi (ToServantApi sub)) => HasOpenApi (NamedRoutes sub) where 431 | toOpenApi _ = toOpenApi (Proxy :: Proxy (ToServantApi sub)) 432 | #endif 433 | 434 | -- ======================================================================= 435 | -- Below are the definitions that should be in Servant.API.ContentTypes 436 | -- ======================================================================= 437 | 438 | class AllAccept cs where 439 | allContentType :: Proxy cs -> [MediaType] 440 | 441 | instance AllAccept '[] where 442 | allContentType _ = [] 443 | 444 | instance (Accept c, AllAccept cs) => AllAccept (c ': cs) where 445 | allContentType _ = contentType (Proxy :: Proxy c) : allContentType (Proxy :: Proxy cs) 446 | 447 | class ToResponseHeader h where 448 | toResponseHeader :: Proxy h -> (HeaderName, OpenApi.Header) 449 | 450 | instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) where 451 | toResponseHeader _ = (hname, mempty & schema ?~ hschema) 452 | where 453 | hname = Text.pack (symbolVal (Proxy :: Proxy sym)) 454 | hschema = Inline $ toParamSchema (Proxy :: Proxy a) 455 | 456 | class AllToResponseHeader hs where 457 | toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName OpenApi.Header 458 | 459 | instance AllToResponseHeader '[] where 460 | toAllResponseHeaders _ = mempty 461 | 462 | instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where 463 | toAllResponseHeaders _ = InsOrdHashMap.insert headerName headerBS hdrs 464 | where 465 | (headerName, headerBS) = toResponseHeader (Proxy :: Proxy h) 466 | hdrs = toAllResponseHeaders (Proxy :: Proxy hs) 467 | 468 | instance AllToResponseHeader hs => AllToResponseHeader (HList hs) where 469 | toAllResponseHeaders _ = toAllResponseHeaders (Proxy :: Proxy hs) 470 | -------------------------------------------------------------------------------- /src/Servant/OpenApi/Internal/Orphans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | module Servant.OpenApi.Internal.Orphans where 6 | 7 | import Data.OpenApi 8 | import Data.Proxy (Proxy (..)) 9 | import Data.Typeable (Typeable) 10 | import Servant.Types.SourceT (SourceT) 11 | 12 | -- | Pretend that 'SourceT m a' is '[a]'. 13 | -- 14 | -- @since 1.1.7 15 | -- 16 | instance (Typeable (SourceT m a), ToSchema a) => ToSchema (SourceT m a) where 17 | declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a]) 18 | -------------------------------------------------------------------------------- /src/Servant/OpenApi/Internal/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | module Servant.OpenApi.Internal.Test where 8 | 9 | import Data.Aeson (ToJSON (..)) 10 | import qualified Data.Aeson.Encode.Pretty as P 11 | import qualified Data.ByteString.Lazy as BSL 12 | import Data.OpenApi (Pattern, ToSchema, toSchema) 13 | import Data.OpenApi.Schema.Validation 14 | import Data.Text (Text) 15 | import qualified Data.Text.Lazy as TL 16 | import qualified Data.Text.Lazy.Encoding as TL 17 | import Data.Typeable 18 | import Test.Hspec 19 | import Test.Hspec.QuickCheck 20 | import Test.QuickCheck (Arbitrary, Property, counterexample, property) 21 | 22 | import Servant.API 23 | import Servant.OpenApi.Internal.TypeLevel 24 | 25 | -- $setup 26 | -- >>> import Control.Applicative 27 | -- >>> import GHC.Generics 28 | -- >>> import Test.QuickCheck 29 | -- >>> :set -XDeriveGeneric 30 | -- >>> :set -XGeneralizedNewtypeDeriving 31 | -- >>> :set -XDataKinds 32 | -- >>> :set -XTypeOperators 33 | 34 | -- | Verify that every type used with @'JSON'@ content type in a servant API 35 | -- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@. 36 | -- 37 | -- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation. 38 | -- See @'validateEveryToJSONWithPatternChecker'@. 39 | -- 40 | -- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API. 41 | -- Each type only gets one test, even if it occurs multiple times in the API. 42 | -- 43 | -- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable) 44 | -- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary) 45 | -- >>> instance ToJSON User 46 | -- >>> instance ToSchema User 47 | -- >>> instance ToSchema UserId 48 | -- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary 49 | -- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId) 50 | -- 51 | -- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI) 52 | -- 53 | -- ToJSON matches ToSchema 54 | -- User... 55 | -- ... 56 | -- UserId... 57 | -- ... 58 | -- Finished in ... seconds 59 | -- ...2 examples, 0 failures... 60 | -- 61 | -- For the test to compile all body types should have the following instances: 62 | -- 63 | -- * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation; 64 | -- * @'Typeable'@ is used to name the test for each type; 65 | -- * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@. 66 | -- * @'Arbitrary'@ is used to arbitrarily generate values. 67 | -- 68 | -- If any of the instances is missing, you'll get a descriptive type error: 69 | -- 70 | -- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic) 71 | -- >>> instance ToJSON Contact 72 | -- >>> instance ToSchema Contact 73 | -- >>> type ContactAPI = Get '[JSON] Contact 74 | -- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI) 75 | -- ... 76 | -- ...No instance for ...Arbitrary Contact... 77 | -- ... arising from a use of ‘validateEveryToJSON’ 78 | -- ... 79 | validateEveryToJSON 80 | :: forall proxy api . 81 | TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) 82 | (BodyTypes JSON api) 83 | => proxy api -- ^ Servant API. 84 | -> Spec 85 | validateEveryToJSON _ = props 86 | (Proxy :: Proxy [ToJSON, ToSchema]) 87 | (maybeCounterExample . prettyValidateWith validateToJSON) 88 | (Proxy :: Proxy (BodyTypes JSON api)) 89 | 90 | -- | Verify that every type used with @'JSON'@ content type in a servant API 91 | -- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@. 92 | -- 93 | -- For validation without patterns see @'validateEveryToJSON'@. 94 | validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) => 95 | (Pattern -> Text -> Bool) -- ^ @'Pattern'@ checker. 96 | -> proxy api -- ^ Servant API. 97 | -> Spec 98 | validateEveryToJSONWithPatternChecker checker _ = props 99 | (Proxy :: Proxy [ToJSON, ToSchema]) 100 | (maybeCounterExample . prettyValidateWith (validateToJSONWithPatternChecker checker)) 101 | (Proxy :: Proxy (BodyTypes JSON api)) 102 | 103 | -- * QuickCheck-related stuff 104 | 105 | -- | Construct property tests for each type in a list. 106 | -- The name for each property is the name of the corresponding type. 107 | -- 108 | -- >>> :{ 109 | -- hspec $ 110 | -- context "read . show == id" $ 111 | -- props 112 | -- (Proxy :: Proxy [Eq, Show, Read]) 113 | -- (\x -> read (show x) === x) 114 | -- (Proxy :: Proxy [Bool, Int, String]) 115 | -- :} 116 | -- 117 | -- read . show == id 118 | -- Bool... 119 | -- ... 120 | -- Int... 121 | -- ... 122 | -- [Char]... 123 | -- ... 124 | -- Finished in ... seconds 125 | -- ...3 examples, 0 failures... 126 | props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs => 127 | p cs -- ^ A list of constraints. 128 | -> (forall x. EveryTF cs x => x -> Property) -- ^ Property predicate. 129 | -> p'' xs -- ^ A list of types. 130 | -> Spec 131 | props _ f px = sequence_ specs 132 | where 133 | specs :: [Spec] 134 | specs = tmapEvery (Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) aprop px 135 | 136 | aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec 137 | aprop _ = prop (show (typeOf (undefined :: a))) (f :: a -> Property) 138 | 139 | -- | Pretty print validation errors 140 | -- together with actual JSON and OpenApi Schema 141 | -- (using 'encodePretty'). 142 | -- 143 | -- >>> import Data.Aeson 144 | -- >>> import Data.Foldable (traverse_) 145 | -- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic) 146 | -- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ] 147 | -- >>> instance ToSchema Person 148 | -- >>> let person = Person { name = "John", phone = 123456 } 149 | -- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person 150 | -- Validation against the schema fails: 151 | -- * property "phone" is required, but not found in "{\"name\":\"John\"}" 152 | -- 153 | -- JSON value: 154 | -- { 155 | -- "name": "John" 156 | -- } 157 | -- 158 | -- OpenApi Schema: 159 | -- { 160 | -- "properties": { 161 | -- "name": { 162 | -- "type": "string" 163 | -- }, 164 | -- "phone": { 165 | -- "type": "integer" 166 | -- } 167 | -- }, 168 | -- "required": [ 169 | -- "name", 170 | -- "phone" 171 | -- ], 172 | -- "type": "object" 173 | -- } 174 | -- 175 | -- 176 | -- FIXME: this belongs in "Data.OpenApi.Schema.Validation" (in @swagger2@). 177 | prettyValidateWith 178 | :: forall a. (ToJSON a, ToSchema a) 179 | => (a -> [ValidationError]) -> a -> Maybe String 180 | prettyValidateWith f x = 181 | case f x of 182 | [] -> Nothing 183 | errors -> Just $ unlines 184 | [ "Validation against the schema fails:" 185 | , unlines (map (" * " ++) errors) 186 | , "JSON value:" 187 | , ppJSONString json 188 | , "" 189 | , "OpenApi Schema:" 190 | , ppJSONString (toJSON schema) 191 | ] 192 | where 193 | ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty 194 | 195 | json = toJSON x 196 | schema = toSchema (Proxy :: Proxy a) 197 | 198 | -- | Provide a counterexample if there is any. 199 | maybeCounterExample :: Maybe String -> Property 200 | maybeCounterExample Nothing = property True 201 | maybeCounterExample (Just s) = counterexample s (property False) 202 | 203 | encodePretty :: ToJSON a => a -> BSL.ByteString 204 | encodePretty = P.encodePretty' $ P.defConfig { P.confCompare = P.compare } 205 | -------------------------------------------------------------------------------- /src/Servant/OpenApi/Internal/TypeLevel.hs: -------------------------------------------------------------------------------- 1 | module Servant.OpenApi.Internal.TypeLevel ( 2 | module Servant.OpenApi.Internal.TypeLevel.API, 3 | module Servant.OpenApi.Internal.TypeLevel.Every, 4 | module Servant.OpenApi.Internal.TypeLevel.TMap, 5 | ) where 6 | 7 | import Servant.OpenApi.Internal.TypeLevel.API 8 | import Servant.OpenApi.Internal.TypeLevel.Every 9 | import Servant.OpenApi.Internal.TypeLevel.TMap 10 | -------------------------------------------------------------------------------- /src/Servant/OpenApi/Internal/TypeLevel/API.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | module Servant.OpenApi.Internal.TypeLevel.API where 10 | 11 | import GHC.Exts (Constraint) 12 | import Servant.API 13 | #if MIN_VERSION_servant(0,19,0) 14 | import Servant.API.Generic (ToServantApi) 15 | #endif 16 | 17 | -- | Build a list of endpoints from an API. 18 | type family EndpointsList api where 19 | EndpointsList (a :<|> b) = AppendList (EndpointsList a) (EndpointsList b) 20 | EndpointsList (e :> a) = MapSub e (EndpointsList a) 21 | #if MIN_VERSION_servant(0,19,0) 22 | EndpointsList (NamedRoutes api) = EndpointsList (ToServantApi api) 23 | #endif 24 | EndpointsList a = '[a] 25 | 26 | -- | Check whether @sub@ is a sub API of @api@. 27 | type family IsSubAPI sub api :: Constraint where 28 | IsSubAPI sub api = AllIsElem (EndpointsList sub) api 29 | 30 | -- | Check that every element of @xs@ is an endpoint of @api@. 31 | type family AllIsElem xs api :: Constraint where 32 | AllIsElem '[] api = () 33 | AllIsElem (x ': xs) api = (IsIn x api, AllIsElem xs api) 34 | 35 | -- | Apply @(e :>)@ to every API in @xs@. 36 | type family MapSub e xs where 37 | MapSub e '[] = '[] 38 | MapSub e (x ': xs) = (e :> x) ': MapSub e xs 39 | 40 | -- | Append two type-level lists. 41 | type family AppendList xs ys where 42 | AppendList '[] ys = ys 43 | AppendList (x ': xs) ys = x ': AppendList xs ys 44 | 45 | type family Or (a :: Constraint) (b :: Constraint) :: Constraint where 46 | Or () b = () 47 | Or a () = () 48 | 49 | type family IsIn sub api :: Constraint where 50 | IsIn e (a :<|> b) = Or (IsIn e a) (IsIn e b) 51 | IsIn (e :> a) (e :> b) = IsIn a b 52 | #if MIN_VERSION_servant(0,19,0) 53 | IsIn e (NamedRoutes api) = IsIn e (ToServantApi api) 54 | #endif 55 | IsIn e e = () 56 | 57 | -- | Check whether a type is a member of a list of types. 58 | -- This is a type-level analogue of @'elem'@. 59 | type family Elem x xs where 60 | Elem x '[] = 'False 61 | Elem x (x ': xs) = 'True 62 | Elem x (y ': xs) = Elem x xs 63 | 64 | -- | Remove duplicates from a type-level list. 65 | type family Nub xs where 66 | Nub '[] = '[] 67 | Nub (x ': xs) = x ': Nub (Remove x xs) 68 | 69 | -- | Remove element from a type-level list. 70 | type family Remove x xs where 71 | Remove x '[] = '[] 72 | Remove x (x ': ys) = Remove x ys 73 | Remove x (y ': ys) = y ': Remove x ys 74 | 75 | -- | Extract a list of unique "body" types for a specific content-type from a servant API. 76 | type BodyTypes c api = Nub (BodyTypes' c api) 77 | 78 | -- | @'AddBodyType' c cs a as@ adds type @a@ to the list @as@ 79 | -- only if @c@ is in @cs@. 80 | type AddBodyType c cs a as = If (Elem c cs) (a ': as) as 81 | 82 | -- | Extract a list of "body" types for a specific content-type from a servant API. 83 | -- To extract unique types see @'BodyTypes'@. 84 | -- 85 | -- @'NoContent'@ is removed from the list and not tested. (This allows for leaving the body 86 | -- completely empty on responses to requests that only accept 'application/json', while 87 | -- setting the content-type in the response accordingly.) 88 | type family BodyTypes' c api :: [*] where 89 | BodyTypes' c (Verb verb b cs (Headers hdrs a)) = AddBodyType c cs a '[] 90 | BodyTypes' c (Verb verb b cs NoContent) = '[] 91 | BodyTypes' c (Verb verb b cs a) = AddBodyType c cs a '[] 92 | BodyTypes' c (ReqBody' mods cs a :> api) = AddBodyType c cs a (BodyTypes' c api) 93 | BodyTypes' c (e :> api) = BodyTypes' c api 94 | BodyTypes' c (a :<|> b) = AppendList (BodyTypes' c a) (BodyTypes' c b) 95 | #if MIN_VERSION_servant(0,19,0) 96 | BodyTypes' c (NamedRoutes api) = BodyTypes' c (ToServantApi api) 97 | #endif 98 | BodyTypes' c api = '[] 99 | -------------------------------------------------------------------------------- /src/Servant/OpenApi/Internal/TypeLevel/Every.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE InstanceSigs #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | #if __GLASGOW_HASKELL__ >= 800 17 | {-# LANGUAGE UndecidableSuperClasses #-} 18 | #endif 19 | module Servant.OpenApi.Internal.TypeLevel.Every where 20 | 21 | import Data.Proxy 22 | import GHC.Exts (Constraint) 23 | 24 | import Servant.OpenApi.Internal.TypeLevel.TMap 25 | 26 | -- $setup 27 | -- >>> :set -XDataKinds 28 | -- >>> :set -XFlexibleContexts 29 | -- >>> :set -XGADTs 30 | -- >>> :set -XRankNTypes 31 | -- >>> :set -XScopedTypeVariables 32 | -- >>> import GHC.TypeLits 33 | -- >>> import Data.List 34 | 35 | -- | Apply multiple constraint constructors to a type. 36 | -- 37 | -- @ 38 | -- EveryTF '[Show, Read] a ~ (Show a, Read a) 39 | -- @ 40 | -- 41 | -- Note that since this is a type family, you have to alway fully apply @'EveryTF'@. 42 | -- 43 | -- For partial application of multiple constraint constructors see @'Every'@. 44 | type family EveryTF cs x :: Constraint where 45 | EveryTF '[] x = () 46 | EveryTF (c ': cs) x = (c x, EveryTF cs x) 47 | 48 | -- | Apply multiple constraint constructors to a type as a class. 49 | -- 50 | -- This is different from @'EveryTF'@ in that it allows partial application. 51 | class EveryTF cs x => Every (cs :: [* -> Constraint]) (x :: *) where 52 | 53 | instance Every '[] x where 54 | instance (c x, Every cs x) => Every (c ': cs) x where 55 | 56 | -- | Like @'tmap'@, but uses @'Every'@ for multiple constraints. 57 | -- 58 | -- >>> let zero :: forall p a. (Show a, Num a) => p a -> String; zero _ = show (0 :: a) 59 | -- >>> tmapEvery (Proxy :: Proxy [Show, Num]) zero (Proxy :: Proxy [Int, Float]) :: [String] 60 | -- ["0","0.0"] 61 | tmapEvery :: forall a cs p p'' xs. (TMap (Every cs) xs) => 62 | p cs -> (forall x p'. Every cs x => p' x -> a) -> p'' xs -> [a] 63 | tmapEvery _ = tmap (Proxy :: Proxy (Every cs)) 64 | -------------------------------------------------------------------------------- /src/Servant/OpenApi/Internal/TypeLevel/TMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | module Servant.OpenApi.Internal.TypeLevel.TMap where 12 | 13 | import Data.Proxy 14 | import GHC.Exts (Constraint) 15 | 16 | -- $setup 17 | -- >>> :set -XDataKinds 18 | -- >>> :set -XFlexibleContexts 19 | -- >>> :set -XGADTs 20 | -- >>> :set -XRankNTypes 21 | -- >>> :set -XScopedTypeVariables 22 | -- >>> import GHC.TypeLits 23 | -- >>> import Data.List 24 | 25 | -- | Map a list of constrained types to a list of values. 26 | -- 27 | -- >>> tmap (Proxy :: Proxy KnownSymbol) symbolVal (Proxy :: Proxy ["hello", "world"]) 28 | -- ["hello","world"] 29 | class TMap (q :: k -> Constraint) (xs :: [k]) where 30 | tmap :: p q -> (forall x p'. q x => p' x -> a) -> p'' xs -> [a] 31 | 32 | instance TMap q '[] where 33 | tmap _ _ _ = [] 34 | 35 | instance (q x, TMap q xs) => TMap q (x ': xs) where 36 | tmap q f _ = f (Proxy :: Proxy x) : tmap q f (Proxy :: Proxy xs) 37 | 38 | -------------------------------------------------------------------------------- /src/Servant/OpenApi/Test.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Servant.OpenApi.Test 3 | -- License: BSD3 4 | -- Maintainer: Nickolay Kudasov 5 | -- Stability: experimental 6 | -- 7 | -- Automatic tests for servant API against OpenApi spec. 8 | module Servant.OpenApi.Test ( 9 | validateEveryToJSON, 10 | validateEveryToJSONWithPatternChecker, 11 | ) where 12 | 13 | import Servant.OpenApi.Internal.Test 14 | -------------------------------------------------------------------------------- /src/Servant/OpenApi/TypeLevel.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Servant.OpenApi.TypeLevel 3 | -- License: BSD3 4 | -- Maintainer: Nickolay Kudasov 5 | -- Stability: experimental 6 | -- 7 | -- Useful type families for servant APIs. 8 | module Servant.OpenApi.TypeLevel ( 9 | IsSubAPI, 10 | EndpointsList, 11 | BodyTypes, 12 | ) where 13 | 14 | import Servant.OpenApi.Internal.TypeLevel 15 | 16 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.8 2 | packages: 3 | - '.' 4 | - example/ 5 | -------------------------------------------------------------------------------- /test/Servant/OpenApiSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE PackageImports #-} 9 | #if MIN_VERSION_servant(0,18,1) 10 | {-# LANGUAGE TypeFamilies #-} 11 | #endif 12 | module Servant.OpenApiSpec where 13 | 14 | import Control.Lens 15 | import Data.Aeson (ToJSON (toJSON), Value, encode, genericToJSON) 16 | import Data.Aeson.QQ.Simple 17 | import qualified Data.Aeson.Types as JSON 18 | import Data.Char (toLower) 19 | import Data.Int (Int64) 20 | import Data.OpenApi 21 | import Data.Proxy 22 | import Data.Text (Text) 23 | import Data.Time 24 | import GHC.Generics 25 | import Servant.API 26 | import Servant.OpenApi 27 | import Servant.Test.ComprehensiveAPI (comprehensiveAPI) 28 | import Test.Hspec hiding (example) 29 | 30 | checkAPI :: HasCallStack => HasOpenApi api => Proxy api -> Value -> IO () 31 | checkAPI proxy = checkOpenApi (toOpenApi proxy) 32 | 33 | checkOpenApi :: HasCallStack => OpenApi -> Value -> IO () 34 | checkOpenApi swag js = encode (toJSON swag) `shouldBe` (encode js) 35 | 36 | spec :: Spec 37 | spec = describe "HasOpenApi" $ do 38 | it "Todo API" $ checkAPI (Proxy :: Proxy TodoAPI) todoAPI 39 | it "Hackage API (with tags)" $ checkOpenApi hackageOpenApiWithTags hackageAPI 40 | it "GetPost API (test subOperations)" $ checkOpenApi getPostOpenApi getPostAPI 41 | it "Comprehensive API" $ do 42 | let _x = toOpenApi comprehensiveAPI 43 | True `shouldBe` True -- type-level test 44 | #if MIN_VERSION_servant(0,18,1) 45 | it "UVerb API" $ checkOpenApi uverbOpenApi uverbAPI 46 | #endif 47 | 48 | main :: IO () 49 | main = hspec spec 50 | 51 | -- ======================================================================= 52 | -- Todo API 53 | -- ======================================================================= 54 | 55 | data Todo = Todo 56 | { created :: UTCTime 57 | , title :: String 58 | , summary :: Maybe String 59 | } deriving (Generic) 60 | 61 | instance ToJSON Todo 62 | instance ToSchema Todo 63 | 64 | newtype TodoId = TodoId String deriving (Generic) 65 | instance ToParamSchema TodoId 66 | 67 | type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo 68 | 69 | todoAPI :: Value 70 | todoAPI = [aesonQQ| 71 | { 72 | "openapi": "3.0.0", 73 | "info": { 74 | "version": "", 75 | "title": "" 76 | }, 77 | "components": { 78 | "schemas": { 79 | "Todo": { 80 | "required": [ 81 | "created", 82 | "title" 83 | ], 84 | "type": "object", 85 | "properties": { 86 | "summary": { 87 | "type": "string" 88 | }, 89 | "created": { 90 | "$ref": "#/components/schemas/UTCTime" 91 | }, 92 | "title": { 93 | "type": "string" 94 | } 95 | } 96 | }, 97 | "UTCTime": { 98 | "example": "2016-07-22T00:00:00Z", 99 | "format": "yyyy-mm-ddThh:MM:ssZ", 100 | "type": "string" 101 | } 102 | } 103 | }, 104 | "paths": { 105 | "/todo/{id}": { 106 | "get": { 107 | "responses": { 108 | "404": { 109 | "description": "`id` not found" 110 | }, 111 | "200": { 112 | "content": { 113 | "application/json;charset=utf-8": { 114 | "schema": { 115 | "$ref": "#/components/schemas/Todo" 116 | } 117 | } 118 | }, 119 | "description": "" 120 | } 121 | }, 122 | "parameters": [ 123 | { 124 | "required": true, 125 | "schema": { 126 | "type": "string" 127 | }, 128 | "in": "path", 129 | "name": "id" 130 | } 131 | ] 132 | } 133 | } 134 | } 135 | } 136 | |] 137 | 138 | -- ======================================================================= 139 | -- Hackage API 140 | -- ======================================================================= 141 | 142 | type HackageAPI 143 | = HackageUserAPI 144 | :<|> HackagePackagesAPI 145 | 146 | type HackageUserAPI = 147 | "users" :> Get '[JSON] [UserSummary] 148 | :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed 149 | 150 | type HackagePackagesAPI 151 | = "packages" :> Get '[JSON] [Package] 152 | 153 | type Username = Text 154 | 155 | data UserSummary = UserSummary 156 | { summaryUsername :: Username 157 | , summaryUserid :: Int64 -- Word64 would make sense too 158 | } deriving (Eq, Show, Generic) 159 | 160 | lowerCutPrefix :: String -> String -> String 161 | lowerCutPrefix s = map toLower . drop (length s) 162 | 163 | instance ToJSON UserSummary where 164 | toJSON = genericToJSON JSON.defaultOptions { JSON.fieldLabelModifier = lowerCutPrefix "summary" } 165 | 166 | instance ToSchema UserSummary where 167 | declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions { fieldLabelModifier = lowerCutPrefix "summary" } proxy 168 | & mapped.schema.example ?~ toJSON UserSummary 169 | { summaryUsername = "JohnDoe" 170 | , summaryUserid = 123 } 171 | 172 | type Group = Text 173 | 174 | data UserDetailed = UserDetailed 175 | { username :: Username 176 | , userid :: Int64 177 | , groups :: [Group] 178 | } deriving (Eq, Show, Generic) 179 | instance ToSchema UserDetailed 180 | 181 | newtype Package = Package { packageName :: Text } 182 | deriving (Eq, Show, Generic) 183 | instance ToSchema Package 184 | 185 | hackageOpenApiWithTags :: OpenApi 186 | hackageOpenApiWithTags = toOpenApi (Proxy :: Proxy HackageAPI) 187 | & servers .~ ["https://hackage.haskell.org"] 188 | & applyTagsFor usersOps ["users" & description ?~ "Operations about user"] 189 | & applyTagsFor packagesOps ["packages" & description ?~ "Query packages"] 190 | where 191 | usersOps, packagesOps :: Traversal' OpenApi Operation 192 | usersOps = subOperations (Proxy :: Proxy HackageUserAPI) (Proxy :: Proxy HackageAPI) 193 | packagesOps = subOperations (Proxy :: Proxy HackagePackagesAPI) (Proxy :: Proxy HackageAPI) 194 | 195 | hackageAPI :: Value 196 | hackageAPI = [aesonQQ| 197 | { 198 | "openapi": "3.0.0", 199 | "servers": [ 200 | { 201 | "url": "https://hackage.haskell.org" 202 | } 203 | ], 204 | "components": { 205 | "schemas": { 206 | "UserDetailed": { 207 | "required": [ 208 | "username", 209 | "userid", 210 | "groups" 211 | ], 212 | "type": "object", 213 | "properties": { 214 | "groups": { 215 | "items": { 216 | "type": "string" 217 | }, 218 | "type": "array" 219 | }, 220 | "username": { 221 | "type": "string" 222 | }, 223 | "userid": { 224 | "maximum": 9223372036854775807, 225 | "format": "int64", 226 | "minimum": -9223372036854775808, 227 | "type": "integer" 228 | } 229 | } 230 | }, 231 | "Package": { 232 | "required": [ 233 | "packageName" 234 | ], 235 | "type": "object", 236 | "properties": { 237 | "packageName": { 238 | "type": "string" 239 | } 240 | } 241 | }, 242 | "UserSummary": { 243 | "example": { 244 | "username": "JohnDoe", 245 | "userid": 123 246 | }, 247 | "required": [ 248 | "username", 249 | "userid" 250 | ], 251 | "type": "object", 252 | "properties": { 253 | "username": { 254 | "type": "string" 255 | }, 256 | "userid": { 257 | "maximum": 9223372036854775807, 258 | "format": "int64", 259 | "minimum": -9223372036854775808, 260 | "type": "integer" 261 | } 262 | } 263 | } 264 | } 265 | }, 266 | "info": { 267 | "version": "", 268 | "title": "" 269 | }, 270 | "paths": { 271 | "/users": { 272 | "get": { 273 | "responses": { 274 | "200": { 275 | "content": { 276 | "application/json;charset=utf-8": { 277 | "schema": { 278 | "items": { 279 | "$ref": "#/components/schemas/UserSummary" 280 | }, 281 | "type": "array" 282 | } 283 | } 284 | }, 285 | "description": "" 286 | } 287 | }, 288 | "tags": [ 289 | "users" 290 | ] 291 | } 292 | }, 293 | "/packages": { 294 | "get": { 295 | "responses": { 296 | "200": { 297 | "content": { 298 | "application/json;charset=utf-8": { 299 | "schema": { 300 | "items": { 301 | "$ref": "#/components/schemas/Package" 302 | }, 303 | "type": "array" 304 | } 305 | } 306 | }, 307 | "description": "" 308 | } 309 | }, 310 | "tags": [ 311 | "packages" 312 | ] 313 | } 314 | }, 315 | "/user/{username}": { 316 | "get": { 317 | "responses": { 318 | "404": { 319 | "description": "`username` not found" 320 | }, 321 | "200": { 322 | "content": { 323 | "application/json;charset=utf-8": { 324 | "schema": { 325 | "$ref": "#/components/schemas/UserDetailed" 326 | } 327 | } 328 | }, 329 | "description": "" 330 | } 331 | }, 332 | "parameters": [ 333 | { 334 | "required": true, 335 | "schema": { 336 | "type": "string" 337 | }, 338 | "in": "path", 339 | "name": "username" 340 | } 341 | ], 342 | "tags": [ 343 | "users" 344 | ] 345 | } 346 | } 347 | }, 348 | "tags": [ 349 | { 350 | "name": "users", 351 | "description": "Operations about user" 352 | }, 353 | { 354 | "name": "packages", 355 | "description": "Query packages" 356 | } 357 | ] 358 | } 359 | |] 360 | 361 | 362 | -- ======================================================================= 363 | -- Get/Post API (test for subOperations) 364 | -- ======================================================================= 365 | 366 | type GetPostAPI = Get '[JSON] String :<|> Post '[JSON] String 367 | 368 | getPostOpenApi :: OpenApi 369 | getPostOpenApi = toOpenApi (Proxy :: Proxy GetPostAPI) 370 | & applyTagsFor getOps ["get" & description ?~ "GET operations"] 371 | where 372 | getOps :: Traversal' OpenApi Operation 373 | getOps = subOperations (Proxy :: Proxy (Get '[JSON] String)) (Proxy :: Proxy GetPostAPI) 374 | 375 | getPostAPI :: Value 376 | getPostAPI = [aesonQQ| 377 | { 378 | "components": {}, 379 | "openapi": "3.0.0", 380 | "info": { 381 | "version": "", 382 | "title": "" 383 | }, 384 | "paths": { 385 | "/": { 386 | "post": { 387 | "responses": { 388 | "200": { 389 | "content": { 390 | "application/json;charset=utf-8": { 391 | "schema": { 392 | "type": "string" 393 | } 394 | } 395 | }, 396 | "description": "" 397 | } 398 | } 399 | }, 400 | "get": { 401 | "responses": { 402 | "200": { 403 | "content": { 404 | "application/json;charset=utf-8": { 405 | "schema": { 406 | "type": "string" 407 | } 408 | } 409 | }, 410 | "description": "" 411 | } 412 | }, 413 | "tags": [ 414 | "get" 415 | ] 416 | } 417 | } 418 | }, 419 | "tags": [ 420 | { 421 | "name": "get", 422 | "description": "GET operations" 423 | } 424 | ] 425 | } 426 | |] 427 | 428 | -- ======================================================================= 429 | -- UVerb API 430 | -- ======================================================================= 431 | 432 | #if MIN_VERSION_servant(0,18,1) 433 | 434 | data FisxUser = FisxUser {name :: String} 435 | deriving (Eq, Show, Generic) 436 | 437 | instance ToSchema FisxUser 438 | 439 | instance HasStatus FisxUser where 440 | type StatusOf FisxUser = 203 441 | 442 | data ArianUser = ArianUser 443 | deriving (Eq, Show, Generic) 444 | 445 | instance ToSchema ArianUser 446 | 447 | type UVerbAPI = "fisx" :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String] 448 | :<|> "arian" :> UVerb 'POST '[JSON] '[WithStatus 201 ArianUser] 449 | 450 | uverbOpenApi :: OpenApi 451 | uverbOpenApi = toOpenApi (Proxy :: Proxy UVerbAPI) 452 | 453 | uverbAPI :: Value 454 | uverbAPI = [aesonQQ| 455 | { 456 | "openapi": "3.0.0", 457 | "info": { 458 | "version": "", 459 | "title": "" 460 | }, 461 | "components": { 462 | "schemas": { 463 | "ArianUser": { 464 | "type": "string", 465 | "enum": [ 466 | "ArianUser" 467 | ] 468 | }, 469 | "FisxUser": { 470 | "required": [ 471 | "name" 472 | ], 473 | "type": "object", 474 | "properties": { 475 | "name": { 476 | "type": "string" 477 | } 478 | } 479 | } 480 | } 481 | }, 482 | "paths": { 483 | "/arian": { 484 | "post": { 485 | "responses": { 486 | "201": { 487 | "content": { 488 | "application/json;charset=utf-8": { 489 | "schema": { 490 | "$ref": "#/components/schemas/ArianUser" 491 | } 492 | } 493 | }, 494 | "description": "" 495 | } 496 | } 497 | } 498 | }, 499 | "/fisx": { 500 | "get": { 501 | "responses": { 502 | "303": { 503 | "content": { 504 | "application/json;charset=utf-8": { 505 | "schema": { 506 | "type": "string" 507 | } 508 | } 509 | }, 510 | "description": "" 511 | }, 512 | "203": { 513 | "content": { 514 | "application/json;charset=utf-8": { 515 | "schema": { 516 | "$ref": "#/components/schemas/FisxUser" 517 | } 518 | } 519 | }, 520 | "description": "" 521 | } 522 | } 523 | } 524 | } 525 | } 526 | } 527 | |] 528 | 529 | #endif 530 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Build_doctests (flags, pkgs, module_sources) 4 | import Data.Foldable (traverse_) 5 | import Test.DocTest 6 | 7 | main :: IO () 8 | main = do 9 | traverse_ putStrLn args 10 | doctest args 11 | where 12 | args = flags ++ pkgs ++ module_sources 13 | --------------------------------------------------------------------------------