git.iko.soy/typeable/openapi3
on 644f61d help sign in
.github/workflows/haskell-ci.ymldeleted−243
since splitsnapshots
unifiedsplit
@@ -1,243 +0,0 @@
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.14.3
12−#
13−# REGENDATA ("0.14.3",["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-18.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.2.2
36− compilerKind: ghc
37− compilerVersion: 9.2.2
38− setup-method: ghcup
39− allow-failure: true
40− - compiler: ghc-9.0.2
41− compilerKind: ghc
42− compilerVersion: 9.0.2
43− setup-method: ghcup
44− allow-failure: false
45− - compiler: ghc-8.10.7
46− compilerKind: ghc
47− compilerVersion: 8.10.7
48− setup-method: ghcup
49− allow-failure: false
50− - compiler: ghc-8.8.4
51− compilerKind: ghc
52− compilerVersion: 8.8.4
53− setup-method: hvr-ppa
54− allow-failure: false
55− - compiler: ghc-8.6.5
56− compilerKind: ghc
57− compilerVersion: 8.6.5
58− setup-method: hvr-ppa
59− allow-failure: false
60− - compiler: ghc-8.4.4
61− compilerKind: ghc
62− compilerVersion: 8.4.4
63− setup-method: hvr-ppa
64− allow-failure: false
65− fail-fast: false
66− steps:
67− - name: apt
68− run: |
69− apt-get update
70− apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
71− if [ "${{ matrix.setup-method }}" = ghcup ]; then
72− mkdir -p "$HOME/.ghcup/bin"
73− curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup"
74− chmod a+x "$HOME/.ghcup/bin/ghcup"
75− "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
76− "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
77− else
78− apt-add-repository -y 'ppa:hvr/ghc'
79− apt-get update
80− apt-get install -y "$HCNAME"
81− mkdir -p "$HOME/.ghcup/bin"
82− curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup"
83− chmod a+x "$HOME/.ghcup/bin/ghcup"
84− "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
85− fi
86− env:
87− HCKIND: ${{ matrix.compilerKind }}
88− HCNAME: ${{ matrix.compiler }}
89− HCVER: ${{ matrix.compilerVersion }}
90− - name: Set PATH and environment variables
91− run: |
92− echo "$HOME/.cabal/bin" >> $GITHUB_PATH
93− echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
94− echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
95− echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
96− HCDIR=/opt/$HCKIND/$HCVER
97− if [ "${{ matrix.setup-method }}" = ghcup ]; then
98− HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
99− echo "HC=$HC" >> "$GITHUB_ENV"
100− echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
101− echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
102− echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
103− else
104− HC=$HCDIR/bin/$HCKIND
105− echo "HC=$HC" >> "$GITHUB_ENV"
106− echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
107− echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
108− echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
109− fi
110−
111− HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
112− echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
113− echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
114− echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
115− echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
116− echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
117− echo "GHCJSARITH=0" >> "$GITHUB_ENV"
118− env:
119− HCKIND: ${{ matrix.compilerKind }}
120− HCNAME: ${{ matrix.compiler }}
121− HCVER: ${{ matrix.compilerVersion }}
122− - name: env
123− run: |
124− env
125− - name: write cabal config
126− run: |
127− mkdir -p $CABAL_DIR
128− cat >> $CABAL_CONFIG <<EOF
129− remote-build-reporting: anonymous
130− write-ghc-environment-files: never
131− remote-repo-cache: $CABAL_DIR/packages
132− logs-dir: $CABAL_DIR/logs
133− world-file: $CABAL_DIR/world
134− extra-prog-path: $CABAL_DIR/bin
135− symlink-bindir: $CABAL_DIR/bin
136− installdir: $CABAL_DIR/bin
137− build-summary: $CABAL_DIR/logs/build.log
138− store-dir: $CABAL_DIR/store
139− install-dirs user
140− prefix: $CABAL_DIR
141− repository hackage.haskell.org
142− url: http://hackage.haskell.org/
143− EOF
144− cat >> $CABAL_CONFIG <<EOF
145− program-default-options
146− ghc-options: $GHCJOBS +RTS -M3G -RTS
147− EOF
148− cat $CABAL_CONFIG
149− - name: versions
150− run: |
151− $HC --version || true
152− $HC --print-project-git-commit-id || true
153− $CABAL --version || true
154− - name: update cabal index
155− run: |
156− $CABAL v2-update -v
157− - name: install cabal-plan
158− run: |
159− mkdir -p $HOME/.cabal/bin
160− curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz
161− echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c -
162− xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
163− rm -f cabal-plan.xz
164− chmod a+x $HOME/.cabal/bin/cabal-plan
165− cabal-plan --version
166− - name: checkout
167− uses: actions/checkout@v2
168− with:
169− path: source
170− - name: initial cabal.project for sdist
171− run: |
172− touch cabal.project
173− echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
174− cat cabal.project
175− - name: sdist
176− run: |
177− mkdir -p sdist
178− $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
179− - name: unpack
180− run: |
181− mkdir -p unpacked
182− find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
183− - name: generate cabal.project
184− run: |
185− PKGDIR_openapi3="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/openapi3-[0-9.]*')"
186− echo "PKGDIR_openapi3=${PKGDIR_openapi3}" >> "$GITHUB_ENV"
187− rm -f cabal.project cabal.project.local
188− touch cabal.project
189− touch cabal.project.local
190− echo "packages: ${PKGDIR_openapi3}" >> cabal.project
191− echo "package openapi3" >> cabal.project
192− echo " ghc-options: -Werror=missing-methods" >> cabal.project
193− cat >> cabal.project <<EOF
194− allow-newer: http-media:base
195− EOF
196− $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(openapi3)$/; }' >> cabal.project.local
197− cat cabal.project
198− cat cabal.project.local
199− - name: dump install plan
200− run: |
201− $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
202− cabal-plan
203− - name: cache
204− uses: actions/cache@v2
205− with:
206− key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
207− path: ~/.cabal/store
208− restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
209− - name: install dependencies
210− run: |
211− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
212− $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
213− - name: build w/o tests
214− run: |
215− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
216− - name: build
217− run: |
218− $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
219− - name: tests
220− run: |
221− $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
222− - name: cabal check
223− run: |
224− cd ${PKGDIR_openapi3} || false
225− ${CABAL} -vnormal check
226− - name: haddock
227− run: |
228− $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
229− - name: unconstrained build
230− run: |
231− rm -f cabal.project.local
232− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
233− - name: prepare for constraint sets
234− run: |
235− rm -f cabal.project.local
236− - name: constraint set aeson-2
237− run: |
238− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson >=2.0' --dependencies-only -j2 all
239− $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson >=2.0' all
240− - name: constraint set aeson-1
241− run: |
242− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson <2.0' --dependencies-only -j2 all ; fi
243− if [ $((HCNUMVER < 90200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson <2.0' all ; fi
.gitignore−2
@@ -1,6 +1,4 @@
1dist
1dist
2−dist-newstyle
3−.ghc.environment.*
4cabal-dev
2cabal-dev
5*.o
3*.o
6*.hi
4*.hi
.travis.ymlnew file+41
@@ -0,0 +1,41 @@
1+language: c
2+
3+# explicitly request container-based infrastructure
4+sudo: false
5+
6+matrix:
7+ include:
8+ - env: CABALVER=1.18 GHCVER=7.8.4 HAPPYVER=1.19.4
9+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.4], sources: [hvr-ghc]}}
10+ - env: CABALVER=1.22 GHCVER=7.10.1 HAPPYVER=1.19.5
11+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5],sources: [hvr-ghc]}}
12+ - env: CABALVER=head GHCVER=head HAPPYVER=head
13+ addons: {apt: {packages: [cabal-install-head,ghc-head,happy-head], sources: [hvr-ghc]}}
14+
15+ allow_failures:
16+ - env: CABALVER=1.18 GHCVER=7.8.4 HAPPYVER=1.19.4
17+ - env: CABALVER=head GHCVER=head HAPPYVER=head
18+
19+before_install:
20+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH:/opt/happy/$HAPPYVER/bin
21+
22+install:
23+ - cabal --version
24+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
25+ - travis_retry cabal update
26+ - cabal install --only-dependencies --enable-tests --enable-benchmarks
27+
28+# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
29+script:
30+ - if [ -f configure.ac ]; then autoreconf -i; fi
31+ - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
32+ - cabal build --ghc-options="-O0" # this builds all libraries and executables (including tests/benchmarks)
33+ - cabal test
34+ - cabal check
35+ - cabal sdist # tests that a source-distribution can be generated
36+
37+# Check that the resulting source distribution can be built & installed.
38+# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
39+# `cabal install --force-reinstalls dist/*-*.tar.gz`
40+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
41+ (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
CHANGELOG.md+1−248
@@ -1,254 +1,7 @@
1−Unreleased
2−----------
3−
4−3.2.2
5−-----
6−
7−- Fix bug with infinite recursion in GToSchema [#37](https://github.com/biocad/openapi3/pull/37).
8−
9−3.2.1
10−-----
11−
12−- Support aeson-2.0.3.
13−- Support GHC-9.2 (doctests still fail).
14−
15−3.2.0
16−-----
17−
18−- Support aeson-2 [#34](https://github.com/biocad/openapi3/pull/34).
19−- Use `SecurityDefinitions` type for `_componentsSecuritySchemes`
20− [#32](https://github.com/biocad/openapi3/pull/32).
21−
22−3.1.0
23−-----
24−
25−- Use `format: date-time` for `ToParamSchema ZonedTime` instance (see
26− [#20](https://github.com/biocad/openapi3/pull/20)).
27−- Support generating schema for any polymorphic types via `Typeable` (see
28− [#19](https://github.com/biocad/openapi3/pull/19)).
29−- Allow `hashable-1.3.1`, prettify doctests (see [#18](https://github.com/biocad/openapi3/pull/18)).
30−
31−3.0.2.0
32−-------
33−
34−- Fix definition for HTTP security scheme (see [#10](https://github.com/biocad/openapi3/pull/10));
35−- Fix error message in `exclusiveMaximum` / `exclusiveMinimum` validation (see
36− [#15](https://github.com/biocad/openapi3/pull/15));
37−
38−3.0.1.0
39−-------
40−
41−- Support polymorphic types in schema generator.
42−
43−3.0.0
44−-----
45−
46−- Switch to OpenAPI 3.0 specification.
47−
48−2.6.1
49−-----
50−
51−- More GHC-8.10 related cleanup, tighten lower bound on some dependencies.
52− (see [#216]( https://github.com/GetShopTV/swagger2/pull/216 ));
53−- Add "format" field for uint32 and uint64
54− (see [#215]( https://github.com/GetShopTV/swagger2/pull/215 ));
55−
56−2.6
57−---
58−
59−- GHC 8.10 support (see [#210]( https://github.com/GetShopTV/swagger2/pull/210 ));
60−- Move `aeson-pretty` to other dependencies (see [#206]( https://github.com/GetShopTV/swagger2/pull/206 ));
61−- Merge OAuth2 scopes (see [#151]( https://github.com/GetShopTV/swagger2/pull/151 ));
62−
63−2.5
64−---
65−
66−Highlights:
67−- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));
68−- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));
69−- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));
70−
71−Fixes and minor changes:
72−- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));
73−- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));
74−- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));
75−
76−2.4
77−---
78−
79−- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5
80−- Tags aren't sorted
81− (see [#165](https://github.com/GetShopTV/swagger2/issues/165))
82−- Schema type is optional
83− (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))
84−- Take concrete 'Proxy' as argument
85− (see [#180](https://github.com/GetShopTV/swagger2/pull/180))
86−- GHC-8.8 preparations
87−
88−2.3.1.1
89−-------
90−
91−- Allow `network-3.0`
92−
93−2.3.1
94−-----
95−
96−- Add a quickcheck generator for aeson Values that match a swagger schema
97− (see [#162](https://github.com/GetShopTV/swagger2/pull/162))
98−- Add `ToParamSchema` instance for `SetCookie`
99− (see [#173](https://github.com/GetShopTV/swagger2/pull/173))
100−- Make nullary schemas valid
101− (see [#168](https://github.com/GetShopTV/swagger2/pull/168))
102−
103−2.3.0.1
104−-------
105−
106−- Support GHC-8.6
107−
108−2.3
109−---
110−
111−Major changes:
112−
113−- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));
114−- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));
115−
116−Dependencies and CI:
117−
118−- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));
119−- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));
120−- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));
121−- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));
122−
123−2.2.2
124−-----
125−
126−* Add `ToSchema Version` instance
127−* Use base-compat-batteries (0.10)
128−* PVP bounds
129−
130−2.2.1
131−-----
132−
133−* Add `Semigroup` instances
134−* GHC-8.4 compatibility
135−* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141))
136−* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142))
137−* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139))
138−* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132))
139−
140−2.2
141−---
142−
143−* Treat unknown properties as validation errors in `validateToJSON` (see [#126](https://github.com/GetShopTV/swagger2/pull/126));
144−* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes (see [#126](https://github.com/GetShopTV/swagger2/pull/126));
145−* Add more `Schema` helpers (see [#126](https://github.com/GetShopTV/swagger2/pull/126)):
146− * `genericNameSchema` — to give a custom schema `Generic`-based name;
147− * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s;
148− * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys;
149−* Add a few tests with invalid `Schema`.
150−
151−2.1.6
152−-----
153−
154−* Add `ToParamSchema` and `ToSchema` instances for `Fixed` (see [#121](https://github.com/GetShopTV/swagger2/pull/121)) and `Natural` (see [#123](https://github.com/GetShopTV/swagger2/pull/123));
155−* Fix instance for `NominalDiffTime` (see [#121](https://github.com/GetShopTV/swagger2/pull/121));
156−* Fix build for `aeson-1.2.2.0` (see [#125](https://github.com/GetShopTV/swagger2/pull/125)).
157−
158−2.1.5
159−-----
160−
161−* Type error by default when deriving Generic-based instances for mixed sum types (see [#118](https://github.com/GetShopTV/swagger2/pull/118));
162−* Adjust `allOf` to accept referenced schemas (see [#119](https://github.com/GetShopTV/swagger2/issues/119));
163−* Add instances for `Identity` (see [#116](https://github.com/GetShopTV/swagger2/pull/116));
164−* Add Gitter chat badge (see [#114](https://github.com/GetShopTV/swagger2/pull/114)).
165−
166−2.1.4.1
167−-------
168−
169−* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95), [#106](https://github.com/GetShopTV/swagger2/pull/106) and [#108](https://github.com/GetShopTV/swagger2/pull/108));
170−* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105));
171−* Allow `generics-sop-0.3` (see [#102](https://github.com/GetShopTV/swagger2/pull/102));
172−* Fix `ToSchema` example in docs (see [#104](https://github.com/GetShopTV/swagger2/pull/104)).
173−
174−2.1.4
175−-----
176−
177−* Add `liftDeclare` (see [#100](https://github.com/GetShopTV/swagger2/pull/100));
178−* Add `MonadDeclare` instances for all monad transformers (see [#100](https://github.com/GetShopTV/swagger2/pull/100)).
179−
180−2.1.3
181−-----
182−
183−* Add [`UUID`](http://hackage.haskell.org/package/uuid-types/docs/Data-UUID-Types.html#t:UUID) instances (see [#81](https://github.com/GetShopTV/swagger2/pull/81)).
184−* Add [`TypeError`](https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-TypeLits.html#g:4) `ToSchema` and `ToParamSchema ByteString` instances (see [#78](https://github.com/GetShopTV/swagger2/pull/78))
185−* Improve documentation for generic sum type instance derivation (see [#75](https://github.com/GetShopTV/swagger2/pull/75))
186−* Compile warning free (see [#82](https://github.com/GetShopTV/swagger2/pull/82))
187−
188−2.1.2.1
189−-------
190−
191−* Bug fix previous release
192−
193−2.1.2
194−---
195−
196−* Minor changes:
197− * Support `aeson-1.0.0.0` (see [#70](https://github.com/GetShopTV/swagger2/pull/70)).
198−
199−2.1.1
200−---
201−
202−* Minor changes:
203− * Proper `Schema` examples for `Char`, `Day`, `LocalTime`, `ZonedTime` and `UTCTime`.
204−
205−2.1
206−---
207−
208−* Major changes:
209− * Use `InsOrdHashMap` to preserve insertion order for endpoints and definitions (see [#56](https://github.com/GetShopTV/swagger2/pull/56));
210− * Add support for GHC 8.0 (see [#65](https://github.com/GetShopTV/swagger2/pull/65)).
211−
212−2.0.2
213−---
214−
215−* Fixes:
216− * Fix `additionalProperties` to allow references;
217− * Fix `ToSchema` instances for `Map` and `HashMap` (prevent infinite recursion for recursive values).
218−
219−2.0.1
220−---
221−
222−* Fixes:
223− * Re-export `Pattern` synonym from `Data.Swagger`;
224− * Documentation fixes.
225−
226−2.0
227−---
228−
229−* Major changes:
230− * GHC 7.8 support (see [#49](https://github.com/GetShopTV/swagger2/pull/49));
231− * Switch to classy field lenses (see [#41](https://github.com/GetShopTV/swagger2/pull/41));
232− * Add `Data.Swagger.Schema.Validation` (see [#18](https://github.com/GetShopTV/swagger2/pull/18));
233− * Add `Data.Swagger.Operation` with helpers (see [#50](https://github.com/GetShopTV/swagger2/pull/50));
234− * Add `IsString` instances for some types (see [#47](https://github.com/GetShopTV/swagger2/pull/47));
235− * Add helpers to sketch `Schema` from JSON (see [#48](https://github.com/GetShopTV/swagger2/pull/48)).
236−
237−* Minor changes:
238− * Make `NamedSchema` a `data` rather than `type` (see [#42](https://github.com/GetShopTV/swagger2/pull/42));
239− * Change `Definitions` to `Definitions Schema`;
240− * Add schema templates for `"binary"`, `"byte"` and `"password"` formats (see [63ed597](https://github.com/GetShopTV/swagger2/commit/63ed59736dc4f942f0e2a7d668d7cee513fa9eaf));
241− * Add `Monoid` instance for `Contact`;
242− * Change `tags` to be `Set` rather than list.
243−
244−* Fixes:
245− * Fix schema for `()` and nullary constructors (see [ab65c4a](https://github.com/GetShopTV/swagger2/commit/ab65c4a48253c34f8a88221a53dc97bf5e6e8d29));
246− * Fix `Operation` `FromJSON` instance to allow missing `tags` and `parameters` properties.
247−
2481.2.1
11.2.1
249---
2---
250
3
251−* Minor changes:
4+* Minor change:
252 * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.
5 * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.
253
6
254* Fixes:
7* Fixes:
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015-2017, GetShopTV
1+Copyright (c) 2015, GetShopTV
2All rights reserved.
2All rights reserved.
3
3
4Redistribution and use in source and binary forms, with or without
4Redistribution and use in source and binary forms, with or without
README.md+10−14
@@ -1,22 +1,19 @@
1−# OpenApi 3
1+# swagger2
2
2
3−[![Hackage](https://img.shields.io/hackage/v/openapi3.svg)](http://hackage.haskell.org/package/openapi3)
3+[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
4−[![Build Status](https://travis-ci.org/biocad/openapi3.svg?branch=master)](https://travis-ci.org/biocad/openapi3)
4+[![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)
5−[![Stackage LTS](http://stackage.org/package/openapi3/badge/lts)](http://stackage.org/lts/package/opeopenapi3)
5+[![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2)
6−[![Stackage Nightly](http://stackage.org/package/openapi3/badge/nightly)](http://stackage.org/nightly/package/openapi3)
6+[![Stackage Nightly](http://stackage.org/package/swagger2/badge/nightly)](http://stackage.org/nightly/package/swagger2)
7
7
8−OpenAPI 3.0 data model.
8+Swagger 2.0 data model.
9
9
10−The original OpenAPI 3.0 specification is available at http://swagger.io/specification/.
10+The original Swagger 2.0 specification is available at http://swagger.io/specification/.
11−
12−This package is heavily based on excellent work on Swagger 2.0 at
13−https://github.com/GetShopTV/swagger2.
14
11
15## Usage
12## Usage
16
13
17−This library is intended to be used for decoding and encoding OpenApi 3.0.3 specifications as well as manipulating them.
14+This library is inteded to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them.
18
15
19−Please refer to [haddock documentation](http://hackage.haskell.org/package/openapi3).
16+Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2).
20
17
21Some examples can be found in [`examples/` directory](/examples).
18Some examples can be found in [`examples/` directory](/examples).
22
19
@@ -34,8 +31,7 @@ Many Swagger tools, including server and client code generation for many languag
34
31
35We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.
32We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.
36
33
37−Please report bugs via the [github issue tracker](https://github.com/biocad/openapi3/issues).
34+Please report bugs via the [github issue tracker](https://github.com/GetShopTV/swagger2/issues).
38
35
39*GetShopTV Team*
36*GetShopTV Team*
40
37
41−*Biocad Team*
Setup.hs−31
@@ -1,33 +1,2 @@
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−
28import Distribution.Simple
1import Distribution.Simple
29−
30−main :: IO ()
31main = defaultMain
2main = defaultMain
32−
33−#endif
cabal.haskell-cideleted−11
@@ -1,11 +0,0 @@
1−branches: master
2−
3−distribution: focal
4−allow-failures: >=9.2
5−
6−constraint-set aeson-1
7− constraints: aeson <2.0
8− ghc: <9.2
9−
10−constraint-set aeson-2
11− constraints: aeson >=2.0
cabal.projectdeleted−4
@@ -1,4 +0,0 @@
1−packages: .
2−tests: true
3−
4−allow-newer: http-media:base
examples/hackage.hs+32−44
@@ -10,31 +10,16 @@ import Data.Proxy
10import Data.Text (Text)
10import Data.Text (Text)
11import GHC.Generics
11import GHC.Generics
12
12
13−import Data.OpenApi
13+import Data.Swagger
14−import Data.OpenApi.Declare
14+import Data.Swagger.Declare
15−import Data.OpenApi.Lens
15+import Data.Swagger.Lens
16−import Data.OpenApi.Operation
17
16
18type Username = Text
17type Username = Text
19
18
20data UserSummary = UserSummary
19data UserSummary = UserSummary
21 { summaryUsername :: Username
20 { summaryUsername :: Username
22 , summaryUserid :: Int
21 , summaryUserid :: Int
23− } deriving (Generic)
22+ } deriving (Generic, ToSchema)
24−
25−instance ToSchema UserSummary where
26− declareNamedSchema _ = do
27− usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
28− useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
29− return $ NamedSchema (Just "UserSummary") $ mempty
30− & type_ ?~ OpenApiObject
31− & properties .~
32− [ ("summaryUsername", usernameSchema )
33− , ("summaryUserid" , useridSchema )
34− ]
35− & required .~ [ "summaryUsername"
36− , "summaryUserid" ]
37−
38
23
39type Group = Text
24type Group = Text
40
25
@@ -47,36 +32,39 @@ data UserDetailed = UserDetailed
47newtype Package = Package { packageName :: Text }
32newtype Package = Package { packageName :: Text }
48 deriving (Generic, ToSchema)
33 deriving (Generic, ToSchema)
49
34
50−hackageOpenApi :: OpenApi
35+hackageSwagger :: Swagger
51−hackageOpenApi = spec & components.schemas .~ defs
36+hackageSwagger = spec & definitions .~ defs
52 where
37 where
53− (defs, spec) = runDeclare declareHackageOpenApi mempty
38+ (defs, spec) = runDeclare declareHackageSwagger mempty
54
39
55−declareHackageOpenApi :: Declare (Definitions Schema) OpenApi
40+declareHackageSwagger :: Declare Definitions Swagger
56−declareHackageOpenApi = do
41+declareHackageSwagger = do
57− -- param schemas
58 let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)
42 let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)
59−
43+ userSummarySchemaRef <- declareSchemaRef (Proxy :: Proxy UserSummary)
60− -- responses
44+ userDetailedSchemaRef <- declareSchemaRef (Proxy :: Proxy UserDetailed)
61− userSummaryResponse <- declareResponse "application/json" (Proxy :: Proxy UserSummary)
45+ packagesSchemaRef <- declareSchemaRef (Proxy :: Proxy [Package])
62− userDetailedResponse <- declareResponse "application/json" (Proxy :: Proxy UserDetailed)
63− packagesResponse <- declareResponse "application/json" (Proxy :: Proxy [Package])
64−
65 return $ mempty
46 return $ mempty
66− & paths .~
47+ & paths.pathsMap .~
67− [ ("/users", mempty & get ?~ (mempty
48+ [ ("/users", mempty & pathItemGet ?~ (mempty
68− & at 200 ?~ Inline userSummaryResponse))
49+ & operationProduces ?~ MimeList ["application/json"]
50+ & operationResponses .~ (mempty
51+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ userSummarySchemaRef))))
69− , ("/user/{username}", mempty & get ?~ (mempty
52+ , ("/user/{username}", mempty & pathItemGet ?~ (mempty
53+ & operationProduces ?~ MimeList ["application/json"]
70− & parameters .~ [ Inline $ mempty
54+ & operationParameters .~ [ Inline $ mempty
71− & name .~ "username"
55+ & paramName .~ "username"
72− & required ?~ True
56+ & paramRequired ?~ True
57+ & paramSchema .~ ParamOther (mempty
73− & in_ .~ ParamPath
58+ & paramOtherSchemaIn .~ ParamPath
74− & schema ?~ Inline usernameParamSchema ]
59+ & paramOtherSchemaParamSchema .~ usernameParamSchema) ]
75− & at 200 ?~ Inline userDetailedResponse))
60+ & operationResponses .~ (mempty
61+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ userDetailedSchemaRef))))
76− , ("/packages", mempty & get ?~ (mempty
62+ , ("/packages", mempty & pathItemGet ?~ (mempty
77− & at 200 ?~ Inline packagesResponse))
63+ & operationProduces ?~ MimeList ["application/json"]
64+ & operationResponses .~ (mempty
65+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ packagesSchemaRef))))
78 ]
66 ]
79
67
80main :: IO ()
68main :: IO ()
81−main = putStrLn . read . show . encode $ hackageOpenApi
69+main = putStrLn . read . show . encode $ hackageSwagger
82
70
hackage-docs.shdeleted−78
@@ -1,78 +0,0 @@
1−#!/bin/bash
2−set -e
3−
4−# This if stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh
5−
6−if [ "$#" -ne 1 ]; then
7− echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
8− exit 1
9−fi
10−
11−user=$1
12−
13−cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
14−if [ ! -f "$cabal_file" ]; then
15− echo "Run this script in the top-level package directory"
16− exit 1
17−fi
18−
19−pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
20−ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
21−
22−if [ -z "$pkg" ]; then
23− echo "Unable to determine package name"
24− exit 1
25−fi
26−
27−if [ -z "$ver" ]; then
28− echo "Unable to determine package version"
29− exit 1
30−fi
31−
32−echo "Detected package: $pkg-$ver"
33−
34−dir=$(mktemp -d build-docs.XXXXXX)
35−trap 'rm -r "$dir"' EXIT
36−
37−export PATH=$(stack path --bin-path)
38−
39−ghc --version
40−cabal --version
41−stack --version
42−
43−if haddock --hyperlinked-source >/dev/null
44−then
45− echo "Using fancy hyperlinked source"
46− HYPERLINK_FLAG="--haddock-option=--hyperlinked-source"
47−else
48− echo "Using boring hyperlinked source"
49− HYPERLINK_FLAG="--hyperlink-source"
50−fi
51−
52−# Cabal dist in temporary location
53−builddir=$dir/dist
54−
55−# Build dependencies haddocks with stack, so we get links
56−stack haddock --only-dependencies
57−
58−# Configure using stack databases
59−snapshotpkgdb=$(stack path --snapshot-pkg-db)
60−localpkgdb=$(stack path --local-pkg-db)
61−cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb
62−
63−# Build Hadckage compatible docs
64−cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
65−
66−# Copy into right directory
67−cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs
68−
69−# Tar and gzip
70−tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
71−
72−# Upload
73−curl -X PUT \
74− -H 'Content-Type: application/x-tar' \
75− -H 'Content-Encoding: gzip' \
76− -u "$user" \
77− --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
78− "https://hackage.haskell.org/package/$pkg-$ver/docs"
openapi3.cabaldeleted−160
@@ -1,160 +0,0 @@
1−cabal-version: >=1.10
2−name: openapi3
3−version: 3.2.2
4−
5−synopsis: OpenAPI 3.0 data model
6−category: Web, Swagger, OpenApi
7−description:
8− This library is intended to be used for decoding and encoding OpenAPI 3.0 API
9− specifications as well as manipulating them.
10− .
11− The original OpenAPI 3.0 specification is available at http://swagger.io/specification/.
12−
13−homepage: https://github.com/biocad/openapi3
14−bug-reports: https://github.com/biocad/openapi3/issues
15−license: BSD3
16−license-file: LICENSE
17−author: Nickolay Kudasov, Maxim Koltsov
18−maintainer: nickolay@getshoptv.com, kolmax94@gmail.com
19−copyright: (c) 2015-2016, GetShopTV, (c) 2020, Biocad
20−build-type: Custom
21−extra-source-files:
22− README.md
23− , CHANGELOG.md
24− , examples/*.hs
25−tested-with:
26− GHC ==8.4.4
27− || ==8.6.5
28− || ==8.8.4
29− || ==8.10.7
30− || ==9.0.2
31− || ==9.2.2
32−
33−custom-setup
34− setup-depends:
35− base, Cabal, cabal-doctest >=1.0.6 && <1.1
36−
37−library
38− hs-source-dirs: src
39− exposed-modules:
40− Data.OpenApi
41− Data.OpenApi.Declare
42− Data.OpenApi.Lens
43− Data.OpenApi.Operation
44− Data.OpenApi.Optics
45− Data.OpenApi.ParamSchema
46− Data.OpenApi.Schema
47− Data.OpenApi.Schema.Generator
48− Data.OpenApi.Schema.Validation
49− Data.OpenApi.SchemaOptions
50−
51− -- internal modules
52− Data.OpenApi.Internal
53− Data.OpenApi.Internal.Schema
54− Data.OpenApi.Internal.Schema.Validation
55− Data.OpenApi.Internal.ParamSchema
56− Data.OpenApi.Internal.Utils
57− Data.OpenApi.Internal.AesonUtils
58− Data.OpenApi.Internal.TypeShape
59−
60− Data.OpenApi.Aeson.Compat
61−
62− -- GHC boot libraries
63− build-depends:
64− base >=4.11.1.0 && <4.17
65− , bytestring >=0.10.8.2 && <0.12
66− , containers >=0.5.11.0 && <0.7
67− , template-haskell >=2.13.0.0 && <2.19
68− , time >=1.8.0.2 && <1.14
69− , transformers >=0.5.5.0 && <0.6
70−
71− build-depends:
72− mtl >=2.2.2 && <2.3
73− , text >=1.2.3.1 && <2.1
74−
75− -- other dependencies
76− build-depends:
77− base-compat-batteries >=0.11.1 && <0.13
78− , aeson >=1.4.2.0 && <1.6 || >=2.0.1.0 && < 2.1
79− , aeson-pretty >=0.8.7 && <0.9
80− -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
81− , cookie >=0.4.3 && <0.5
82− , generics-sop >=0.5.1.0 && <0.6
83− , hashable >=1.2.7.0 && <1.5
84− , http-media >=0.8.0.0 && <0.9
85− , insert-ordered-containers >=0.2.3 && <0.3
86− , lens >=4.16.1 && <5.2
87− , network >=2.6.3.5 && <3.2
88− , optics-core >=0.2 && <0.5
89− , optics-th >=0.2 && <0.5
90− , scientific >=0.3.6.2 && <0.4
91− , unordered-containers >=0.2.9.0 && <0.3
92− , uuid-types >=1.0.3 && <1.1
93− , vector >=0.12.0.1 && <0.13
94− , QuickCheck >=2.10.1 && <2.15
95−
96− default-language: Haskell2010
97−
98−test-suite spec
99− type: exitcode-stdio-1.0
100− hs-source-dirs: test
101− main-is: Spec.hs
102−
103− -- From library parat
104− -- We need aeson's toEncoding for doctests too
105− build-depends:
106− base
107− , QuickCheck
108− , aeson
109− , base-compat-batteries
110− , bytestring
111− , containers
112− , hashable
113− , insert-ordered-containers
114− , lens
115− , mtl
116− , openapi3
117− , template-haskell
118− , text
119− , time
120− , unordered-containers
121− , vector
122−
123− -- test-suite only dependencies
124− build-depends:
125− hspec >=2.5.5 && <2.10
126− , HUnit >=1.6.0.0 && <1.7
127− , quickcheck-instances >=0.3.19 && <0.14
128− , utf8-string >=1.0.1.1 && <1.1
129−
130− -- https://github.com/haskell/cabal/issues/3708
131− build-tool-depends:
132− hspec-discover:hspec-discover >=2.5.5 && <2.10
133−
134− other-modules:
135− SpecCommon
136− Data.OpenApiSpec
137− Data.OpenApi.CommonTestTypes
138− Data.OpenApi.ParamSchemaSpec
139− Data.OpenApi.SchemaSpec
140− Data.OpenApi.Schema.ValidationSpec
141− Data.OpenApi.Schema.GeneratorSpec
142− default-language: Haskell2010
143−
144−test-suite doctests
145− -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes
146− build-depends: base, doctest, Glob, QuickCheck
147− default-language: Haskell2010
148− hs-source-dirs: test
149− main-is: doctests.hs
150− type: exitcode-stdio-1.0
151−
152−executable example
153− hs-source-dirs: examples
154− main-is: hackage.hs
155− default-language: Haskell2010
156− build-depends: base, aeson, lens, openapi3, text
157−
158−source-repository head
159− type: git
160− location: https://github.com/biocad/openapi3.git
src/Data/OpenApi.hsdeleted−428
@@ -1,428 +0,0 @@
1−-- |
2−-- Module: Data.OpenApi
3−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4−-- Stability: experimental
5−--
6−-- Swagger™ is a project used to describe and document RESTful APIs.
7−--
8−-- The Swagger specification defines a set of files required to describe such an API.
9−-- These files can then be used by the Swagger-UI project to display the API
10−-- and Swagger-Codegen to generate clients in various languages.
11−-- Additional utilities can also take advantage of the resulting files, such as testing tools.
12−module Data.OpenApi (
13− -- * How to use this library
14− -- $howto
15−
16− -- ** @'Monoid'@ instances
17− -- $monoids
18−
19− -- ** Lenses and prisms
20− -- $lens
21−
22− -- ** Schema specification
23− -- $schema
24−
25− -- ** Manipulation
26− -- $manipulation
27−
28− -- ** Validation
29− -- $validation
30−
31− -- * Re-exports
32− module Data.OpenApi.Lens,
33− module Data.OpenApi.Optics,
34− module Data.OpenApi.Operation,
35− module Data.OpenApi.ParamSchema,
36− module Data.OpenApi.Schema,
37− module Data.OpenApi.Schema.Validation,
38−
39− -- * Swagger specification
40− OpenApi(..),
41− Server(..),
42− ServerVariable(..),
43− Components(..),
44−
45− -- ** Info types
46− Info(..),
47− Contact(..),
48− License(..),
49−
50− -- ** PathItem
51− PathItem(..),
52−
53− -- ** Operations
54− Operation(..),
55− Tag(..),
56− TagName,
57−
58− -- ** Types and formats
59− OpenApiType(..),
60− Format,
61− Definitions,
62− Style(..),
63−
64− -- ** Parameters
65− Param(..),
66− ParamLocation(..),
67− ParamName,
68− Header(..),
69− HeaderName,
70− Example(..),
71− RequestBody(..),
72− MediaTypeObject(..),
73− Encoding(..),
74−
75− -- ** Schemas
76− Schema(..),
77− NamedSchema(..),
78− OpenApiItems(..),
79− Xml(..),
80− Pattern,
81− AdditionalProperties(..),
82− Discriminator(..),
83−
84− -- ** Responses
85− Responses(..),
86− Response(..),
87− HttpStatusCode,
88− Link(..),
89− Callback(..),
90−
91− -- ** Security
92− SecurityScheme(..),
93− SecuritySchemeType(..),
94− HttpSchemeType(..),
95− SecurityDefinitions(..),
96− SecurityRequirement(..),
97−
98− -- *** API key
99− ApiKeyParams(..),
100− ApiKeyLocation(..),
101−
102− -- *** OAuth2
103− OAuth2Flows(..),
104− OAuth2Flow(..),
105− OAuth2ImplicitFlow(..),
106− OAuth2PasswordFlow(..),
107− OAuth2ClientCredentialsFlow(..),
108− OAuth2AuthorizationCodeFlow(..),
109− AuthorizationURL,
110− TokenURL,
111−
112− -- ** External documentation
113− ExternalDocs(..),
114−
115− -- ** References
116− Reference(..),
117− Referenced(..),
118−
119− -- ** Miscellaneous
120− MimeList(..),
121− URL(..),
122−) where
123−
124−import Data.OpenApi.Lens
125−import Data.OpenApi.Optics ()
126−import Data.OpenApi.Operation
127−import Data.OpenApi.ParamSchema
128−import Data.OpenApi.Schema
129−import Data.OpenApi.Schema.Validation
130−
131−import Data.OpenApi.Internal
132−
133−-- $setup
134−-- >>> import Control.Lens
135−-- >>> import Data.Aeson
136−-- >>> import Data.Monoid
137−-- >>> import Data.Proxy
138−-- >>> import GHC.Generics
139−-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
140−-- >>> import Data.OpenApi.Internal.Utils
141−-- >>> :set -XDeriveGeneric
142−-- >>> :set -XOverloadedStrings
143−-- >>> :set -XOverloadedLists
144−-- >>> :set -fno-warn-missing-methods
145−
146−-- $howto
147−--
148−-- This section explains how to use this library to work with Swagger specification.
149−
150−-- $monoids
151−--
152−-- Virtually all types representing Swagger specification have @'Monoid'@ instances.
153−-- The @'Monoid'@ type class provides two methods — @'mempty'@ and @'mappend'@.
154−--
155−-- In this library you can use @'mempty'@ for a default/empty value. For instance:
156−--
157−-- >>> BSL.putStrLn $ encodePretty (mempty :: OpenApi)
158−-- {
159−-- "components": {},
160−-- "info": {
161−-- "title": "",
162−-- "version": ""
163−-- },
164−-- "openapi": "3.0.0",
165−-- "paths": {}
166−-- }
167−--
168−-- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty.
169−-- That is because these properties are actually required ones.
170−--
171−-- You /should/ always override the default (empty) value for these properties,
172−-- although it is not strictly necessary:
173−--
174−-- >>> BSL.putStrLn $ encodePretty mempty { _infoTitle = "Todo API", _infoVersion = "1.0" }
175−-- {
176−-- "title": "Todo API",
177−-- "version": "1.0"
178−-- }
179−--
180−-- You can merge two values using @'mappend'@ or its infix version @('<>')@:
181−--
182−-- >>> BSL.putStrLn $ encodePretty $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" }
183−-- {
184−-- "title": "Todo API",
185−-- "version": "1.0"
186−-- }
187−
188−--
189−-- This can be useful for combining specifications of endpoints into a whole API specification:
190−--
191−-- @
192−-- \-\- /account subAPI specification
193−-- accountAPI :: OpenApi
194−--
195−-- \-\- /task subAPI specification
196−-- taskAPI :: OpenApi
197−--
198−-- \-\- while API specification is just a combination
199−-- \-\- of subAPIs' specifications
200−-- api :: OpenApi
201−-- api = accountAPI <> taskAPI
202−-- @
203−
204−-- $lens
205−--
206−-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.OpenApi.Optics".
207−--
208−-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
209−-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
210−-- make it fairly simple to construct/modify any part of the specification:
211−--
212−-- >>> :{
213−-- BSL.putStrLn $ encodePretty $ (mempty :: OpenApi)
214−-- & components . schemas .~ [ ("User", mempty & type_ ?~ OpenApiString) ]
215−-- & paths .~
216−-- [ ("/user", mempty & get ?~ (mempty
217−-- & at 200 ?~ ("OK" & _Inline.content.at "application/json" ?~ (mempty & schema ?~ Ref (Reference "User")))
218−-- & at 404 ?~ "User info not found")) ]
219−-- :}
220−-- {
221−-- "components": {
222−-- "schemas": {
223−-- "User": {
224−-- "type": "string"
225−-- }
226−-- }
227−-- },
228−-- "info": {
229−-- "title": "",
230−-- "version": ""
231−-- },
232−-- "openapi": "3.0.0",
233−-- "paths": {
234−-- "/user": {
235−-- "get": {
236−-- "responses": {
237−-- "200": {
238−-- "content": {
239−-- "application/json": {
240−-- "schema": {
241−-- "$ref": "#/components/schemas/User"
242−-- }
243−-- }
244−-- },
245−-- "description": "OK"
246−-- },
247−-- "404": {
248−-- "description": "User info not found"
249−-- }
250−-- }
251−-- }
252−-- }
253−-- }
254−-- }
255−--
256−-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
257−-- which produces @application/json@ output. It should respond with code @200@ and body specified
258−-- by schema @User@ which is defined in @'definitions'@ property of swagger specification.
259−-- Alternatively it may respond with code @404@ meaning that user info is not found.
260−--
261−-- For convenience, @swagger2@ uses /classy field lenses/. It means that
262−-- field accessor names can be overloaded for different types. One such
263−-- common field is @'description'@. Many components of a Swagger specification
264−-- can have descriptions, and you can use the same name for them:
265−--
266−-- >>> BSL.putStrLn $ encodePretty $ (mempty :: Response) & description .~ "No content"
267−-- {
268−-- "description": "No content"
269−-- }
270−-- >>> :{
271−-- BSL.putStrLn $ encodePretty $ (mempty :: Schema)
272−-- & type_ ?~ OpenApiBoolean
273−-- & description ?~ "To be or not to be"
274−-- :}
275−-- {
276−-- "description": "To be or not to be",
277−-- "type": "boolean"
278−-- }
279−--
280−-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
281−-- have direct access to it via @'at' code@. Example:
282−--
283−-- >>> :{
284−-- BSL.putStrLn $ encodePretty $ (mempty :: Operation)
285−-- & at 404 ?~ "Not found"
286−-- :}
287−-- {
288−-- "responses": {
289−-- "404": {
290−-- "description": "Not found"
291−-- }
292−-- }
293−-- }
294−--
295−-- You might've noticed that @'type_'@ has an extra underscore in its name
296−-- compared to, say, @'description'@ field accessor.
297−-- This is because @type@ is a keyword in Haskell.
298−-- A few other field accessors are modified in this way:
299−--
300−-- - @'in_'@, @'type_'@, @'default_'@ (as keywords);
301−-- - @'maximum_'@, @'minimum_'@, @'head_'@ (as conflicting with @Prelude@);
302−-- - @'enum_'@ (as conflicting with @Control.Lens@).
303−
304−-- $schema
305−--
306−-- @'ParamSchema'@ and @'Schema'@ are the two core types for data model specification.
307−--
308−-- @'ParamSchema' t@ specifies all the common properties, available for every data schema.
309−-- The @t@ parameter imposes some restrictions on @type@ and @items@ properties (see @'OpenApiType'@ and @'OpenApiItems'@).
310−--
311−-- @'Schema'@ is used for request and response bodies and allows specifying objects
312−-- with properties in addition to what @'ParamSchema'@ provides.
313−--
314−-- In most cases you will have a Haskell data type for which you would like to
315−-- define a corresponding schema. To facilitate this use case
316−-- @swagger2@ provides two classes for schema encoding.
317−-- Both these classes provide means to encode /types/ as Swagger /schemas/.
318−--
319−-- @'ToParamSchema'@ is intended to be used for primitive API endpoint parameters,
320−-- such as query parameters, headers and URL path pieces.
321−-- Its corresponding value-encoding class is @'ToHttpApiData'@ (from @http-api-data@ package).
322−--
323−-- @'ToSchema'@ is used for request and response bodies and mostly differ from
324−-- primitive parameters by allowing objects/mappings in addition to primitive types and arrays.
325−-- Its corresponding value-encoding class is @'ToJSON'@ (from @aeson@ package).
326−--
327−-- While lenses and prisms make it easy to define schemas, it might be that you don't need to:
328−-- @'ToSchema'@ and @'ToParamSchema'@ classes both have default @'Generic'@-based implementations!
329−--
330−-- @'ToSchema'@ default implementation is also aligned with @'ToJSON'@ default implementation with
331−-- the only difference being for sum encoding. @'ToJSON'@ defaults sum encoding to @'defaultTaggedObject'@,
332−-- while @'ToSchema'@ defaults to something which corresponds to @'ObjectWithSingleField'@. This is due to
333−-- @'defaultTaggedObject'@ behavior being hard to specify in Swagger.
334−--
335−-- Here's an example showing @'ToJSON'@–@'ToSchema'@ correspondance:
336−--
337−-- >>> data Person = Person { name :: String, age :: Integer } deriving Generic
338−-- >>> instance ToJSON Person
339−-- >>> instance ToSchema Person
340−-- >>> BSL.putStrLn $ encodePretty (Person "David" 28)
341−-- {
342−-- "age": 28,
343−-- "name": "David"
344−-- }
345−-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Person)
346−-- {
347−-- "properties": {
348−-- "age": {
349−-- "type": "integer"
350−-- },
351−-- "name": {
352−-- "type": "string"
353−-- }
354−-- },
355−-- "required": [
356−-- "name",
357−-- "age"
358−-- ],
359−-- "type": "object"
360−-- }
361−--
362−-- This package implements OpenAPI 3.0 spec, which supports @oneOf@ in schemas, allowing any sum types
363−-- to be faithfully represented. All sum encodings supported by @aeson@ are supported here as well, with
364−-- an exception of 'Data.Aeson.TwoElemArray', since OpenAPI spec does not support heterogeneous arrays.
365−--
366−-- An example with 'Data.Aeson.TaggedObject' encoding:
367−--
368−-- >>> data Error = ErrorNoUser { userId :: Int } | ErrorAccessDenied { requiredPermission :: String } deriving Generic
369−-- >>> instance ToJSON Error
370−-- >>> instance ToSchema Error
371−-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Error)
372−-- {
373−-- "oneOf": [
374−-- {
375−-- "properties": {
376−-- "tag": {
377−-- "enum": [
378−-- "ErrorNoUser"
379−-- ],
380−-- "type": "string"
381−-- },
382−-- "userId": {
383−-- "maximum": 9223372036854775807,
384−-- "minimum": -9223372036854775808,
385−-- "type": "integer"
386−-- }
387−-- },
388−-- "required": [
389−-- "userId",
390−-- "tag"
391−-- ],
392−-- "type": "object"
393−-- },
394−-- {
395−-- "properties": {
396−-- "requiredPermission": {
397−-- "type": "string"
398−-- },
399−-- "tag": {
400−-- "enum": [
401−-- "ErrorAccessDenied"
402−-- ],
403−-- "type": "string"
404−-- }
405−-- },
406−-- "required": [
407−-- "requiredPermission",
408−-- "tag"
409−-- ],
410−-- "type": "object"
411−-- }
412−-- ],
413−-- "type": "object"
414−-- }
415−
416−-- $manipulation
417−-- Sometimes you have to work with an imported or generated @'Swagger'@.
418−-- For instance, <servant-swagger http://hackage.haskell.org/package/servant-swagger> generates basic @'Swagger'@
419−-- for a type-level servant API.
420−--
421−-- Lenses and prisms can be used to manipulate such specification to add additional information, tags, extra responses, etc.
422−-- To facilitate common needs, @"Data.OpenApi.Operation"@ module provides useful helpers.
423−
424−-- $validation
425−-- While @'ToParamSchema'@ and @'ToSchema'@ provide means to easily obtain schemas for Haskell types,
426−-- there is no static mechanism to ensure those instances correspond to the @'ToHttpApiData'@ or @'ToJSON'@ instances.
427−--
428−-- @"Data.OpenApi.Schema.Validation"@ addresses @'ToJSON'@/@'ToSchema'@ validation.
src/Data/OpenApi/Aeson/Compat.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−module Data.OpenApi.Aeson.Compat where
4−
5−#if MIN_VERSION_aeson(2,0,0)
6−import Data.Aeson (Key)
7−import qualified Data.Aeson.Key as Key
8−import qualified Data.Aeson.KeyMap as KeyMap
9−#else
10−import qualified Data.HashMap.Strict as HM
11−#endif
12−import Data.Bifunctor (first)
13−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
14−import qualified Data.Text as T
15−
16−#if MIN_VERSION_aeson(2,0,0)
17−deleteKey :: Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v
18−deleteKey = KeyMap.delete
19−
20−objectToList :: KeyMap.KeyMap v -> [(Key, v)]
21−objectToList = KeyMap.toList
22−
23−objectKeys :: KeyMap.KeyMap v -> [T.Text]
24−objectKeys = map Key.toText . KeyMap.keys
25−
26−stringToKey :: String -> Key
27−stringToKey = Key.fromString
28−
29−keyToString :: Key -> String
30−keyToString = Key.toString
31−
32−keyToText :: Key -> T.Text
33−keyToText = Key.toText
34−
35−toInsOrdHashMap :: KeyMap.KeyMap v -> InsOrdHashMap.InsOrdHashMap T.Text v
36−toInsOrdHashMap = InsOrdHashMap.fromList . fmap (first Key.toText) . KeyMap.toList
37−
38−fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> KeyMap.KeyMap v
39−fromInsOrdHashMap = KeyMap.fromList . fmap (first Key.fromText) . InsOrdHashMap.toList
40−
41−lookupKey :: T.Text -> KeyMap.KeyMap v -> Maybe v
42−lookupKey = KeyMap.lookup . Key.fromText
43−
44−hasKey :: T.Text -> KeyMap.KeyMap a -> Bool
45−hasKey = KeyMap.member . Key.fromText
46−#else
47−deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v
48−deleteKey = HM.delete
49−
50−objectToList :: HM.HashMap T.Text v -> [(T.Text, v)]
51−objectToList = HM.toList
52−
53−objectKeys :: HM.HashMap T.Text v -> [T.Text]
54−objectKeys = HM.keys
55−
56−stringToKey :: String -> T.Text
57−stringToKey = T.pack
58−
59−keyToString :: T.Text -> String
60−keyToString = T.unpack
61−
62−keyToText :: T.Text -> T.Text
63−keyToText = id
64−
65−toInsOrdHashMap :: HM.HashMap T.Text v -> InsOrdHashMap.InsOrdHashMap T.Text v
66−toInsOrdHashMap = InsOrdHashMap.fromHashMap
67−
68−fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> HM.HashMap T.Text v
69−fromInsOrdHashMap = InsOrdHashMap.toHashMap
70−
71−lookupKey :: T.Text -> HM.HashMap T.Text v -> Maybe v
72−lookupKey = HM.lookup
73−
74−hasKey :: T.Text -> HM.HashMap T.Text a -> Bool
75−hasKey = HM.member
76−#endif
src/Data/OpenApi/Internal.hsdeleted−1619
@@ -1,1619 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE DeriveTraversable #-}
6−{-# LANGUAGE FlexibleContexts #-}
7−{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE GADTs #-}
9−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10−{-# LANGUAGE OverloadedStrings #-}
11−{-# LANGUAGE RecordWildCards #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
14−{-# LANGUAGE TemplateHaskell #-}
15−{-# LANGUAGE TypeFamilies #-}
16−{-# LANGUAGE UndecidableInstances #-}
17−module Data.OpenApi.Internal where
18−
19−import Prelude ()
20−import Prelude.Compat
21−
22−import Control.Applicative
23−import Control.Lens ((&), (.~), (?~))
24−import Data.Aeson hiding (Encoding)
25−#if MIN_VERSION_aeson(2,0,0)
26−import qualified Data.Aeson.KeyMap as KeyMap
27−#endif
28−import qualified Data.Aeson.Types as JSON
29−import Data.Data (Constr, Data (..), DataType, Fixity (..), Typeable,
30− constrIndex, mkConstr, mkDataType)
31−import Data.Hashable (Hashable (..))
32−import qualified Data.HashMap.Strict as HashMap
33−import Data.HashSet.InsOrd (InsOrdHashSet)
34−import Data.Map (Map)
35−import qualified Data.Map as Map
36−import Data.Monoid (Monoid (..))
37−import Data.Scientific (Scientific)
38−import Data.Semigroup.Compat (Semigroup (..))
39−import Data.String (IsString (..))
40−import Data.Text (Text)
41−import qualified Data.Text as Text
42−import Data.Text.Encoding (encodeUtf8)
43−import GHC.Generics (Generic)
44−import Network.HTTP.Media (MediaType, mainType, parameters, parseAccept, subType, (//),
45− (/:))
46−import Network.Socket (HostName, PortNumber)
47−import Text.Read (readMaybe)
48−
49−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
50−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
51−
52−import Data.OpenApi.Aeson.Compat (deleteKey)
53−import Data.OpenApi.Internal.AesonUtils (AesonDefaultValue (..), HasSwaggerAesonOptions (..),
54− mkSwaggerAesonOptions, saoAdditionalPairs, saoSubObject,
55− sopSwaggerGenericParseJSON, sopSwaggerGenericToEncoding,
56− sopSwaggerGenericToJSON, sopSwaggerGenericToJSONWithOpts)
57−import Data.OpenApi.Internal.Utils
58−import Generics.SOP.TH (deriveGeneric)
59−
60−-- $setup
61−-- >>> :seti -XDataKinds
62−-- >>> import Data.Aeson
63−-- >>> import Data.ByteString.Lazy.Char8 as BSL
64−-- >>> import Data.OpenApi.Internal.Utils
65−
66−-- | A list of definitions that can be used in references.
67−type Definitions = InsOrdHashMap Text
68−
69−-- | This is the root document object for the API specification.
70−data OpenApi = OpenApi
71− { -- | Provides metadata about the API.
72− -- The metadata can be used by the clients if needed.
73− _openApiInfo :: Info
74−
75− -- | An array of Server Objects, which provide connectivity information
76− -- to a target server. If the servers property is not provided, or is an empty array,
77− -- the default value would be a 'Server' object with a url value of @/@.
78− , _openApiServers :: [Server]
79−
80− -- | The available paths and operations for the API.
81− , _openApiPaths :: InsOrdHashMap FilePath PathItem
82−
83− -- | An element to hold various schemas for the specification.
84− , _openApiComponents :: Components
85−
86− -- | A declaration of which security mechanisms can be used across the API.
87− -- The list of values includes alternative security requirement objects that can be used.
88− -- Only one of the security requirement objects need to be satisfied to authorize a request.
89− -- Individual operations can override this definition.
90− -- To make security optional, an empty security requirement can be included in the array.
91− , _openApiSecurity :: [SecurityRequirement]
92−
93− -- | A list of tags used by the specification with additional metadata.
94− -- The order of the tags can be used to reflect on their order by the parsing tools.
95− -- Not all tags that are used by the 'Operation' Object must be declared.
96− -- The tags that are not declared MAY be organized randomly or based on the tools' logic.
97− -- Each tag name in the list MUST be unique.
98− , _openApiTags :: InsOrdHashSet Tag
99−
100− -- | Additional external documentation.
101− , _openApiExternalDocs :: Maybe ExternalDocs
102− } deriving (Eq, Show, Generic, Data, Typeable)
103−
104−-- | The object provides metadata about the API.
105−-- The metadata MAY be used by the clients if needed,
106−-- and MAY be presented in editing or documentation generation tools for convenience.
107−data Info = Info
108− { -- | The title of the API.
109− _infoTitle :: Text
110−
111− -- | A short description of the API.
112− -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.
113− , _infoDescription :: Maybe Text
114−
115− -- | A URL to the Terms of Service for the API. MUST be in the format of a URL.
116− , _infoTermsOfService :: Maybe Text
117−
118− -- | The contact information for the exposed API.
119− , _infoContact :: Maybe Contact
120−
121− -- | The license information for the exposed API.
122− , _infoLicense :: Maybe License
123−
124− -- | The version of the OpenAPI document (which is distinct from the
125− -- OpenAPI Specification version or the API implementation version).
126− , _infoVersion :: Text
127− } deriving (Eq, Show, Generic, Data, Typeable)
128−
129−-- | Contact information for the exposed API.
130−data Contact = Contact
131− { -- | The identifying name of the contact person/organization.
132− _contactName :: Maybe Text
133−
134− -- | The URL pointing to the contact information.
135− , _contactUrl :: Maybe URL
136−
137− -- | The email address of the contact person/organization.
138− , _contactEmail :: Maybe Text
139− } deriving (Eq, Show, Generic, Data, Typeable)
140−
141−-- | License information for the exposed API.
142−data License = License
143− { -- | The license name used for the API.
144− _licenseName :: Text
145−
146− -- | A URL to the license used for the API.
147− , _licenseUrl :: Maybe URL
148− } deriving (Eq, Show, Generic, Data, Typeable)
149−
150−instance IsString License where
151− fromString s = License (fromString s) Nothing
152−
153−-- | An object representing a Server.
154−data Server = Server
155− { -- | A URL to the target host. This URL supports Server Variables and MAY be relative,
156− -- to indicate that the host location is relative to the location where
157− -- the OpenAPI document is being served. Variable substitutions will be made when
158− -- a variable is named in @{brackets}@.
159− _serverUrl :: Text
160−
161− -- | An optional string describing the host designated by the URL.
162− -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.
163− , _serverDescription :: Maybe Text
164−
165− -- | A map between a variable name and its value.
166− -- The value is used for substitution in the server's URL template.
167− , _serverVariables :: InsOrdHashMap Text ServerVariable
168− } deriving (Eq, Show, Generic, Data, Typeable)
169−
170−data ServerVariable = ServerVariable
171− { -- | An enumeration of string values to be used if the substitution options
172− -- are from a limited set. The array SHOULD NOT be empty.
173− _serverVariableEnum :: Maybe (InsOrdHashSet Text) -- TODO NonEmpty
174−
175− -- | The default value to use for substitution, which SHALL be sent if an alternate value
176− -- is not supplied. Note this behavior is different than the 'Schema\ Object's treatment
177− -- of default values, because in those cases parameter values are optional.
178− -- If the '_serverVariableEnum' is defined, the value SHOULD exist in the enum's values.
179− , _serverVariableDefault :: Text
180−
181− -- | An optional description for the server variable.
182− -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.
183− , _serverVariableDescription :: Maybe Text
184− } deriving (Eq, Show, Generic, Data, Typeable)
185−
186−instance IsString Server where
187− fromString s = Server (fromString s) Nothing mempty
188−
189−-- | Holds a set of reusable objects for different aspects of the OAS.
190−-- All objects defined within the components object will have no effect on the API
191−-- unless they are explicitly referenced from properties outside the components object.
192−data Components = Components
193− { _componentsSchemas :: Definitions Schema
194− , _componentsResponses :: Definitions Response
195− , _componentsParameters :: Definitions Param
196− , _componentsExamples :: Definitions Example
197− , _componentsRequestBodies :: Definitions RequestBody
198− , _componentsHeaders :: Definitions Header
199− , _componentsSecuritySchemes :: SecurityDefinitions
200− , _componentsLinks :: Definitions Link
201− , _componentsCallbacks :: Definitions Callback
202− } deriving (Eq, Show, Generic, Data, Typeable)
203−
204−-- | Describes the operations available on a single path.
205−-- A @'PathItem'@ may be empty, due to ACL constraints.
206−-- The path itself is still exposed to the documentation viewer
207−-- but they will not know which operations and parameters are available.
208−data PathItem = PathItem
209− { -- | An optional, string summary, intended to apply to all operations in this path.
210− _pathItemSummary :: Maybe Text
211−
212− -- | An optional, string description, intended to apply to all operations in this path.
213− -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.
214− , _pathItemDescription :: Maybe Text
215−
216− -- | A definition of a GET operation on this path.
217− , _pathItemGet :: Maybe Operation
218−
219− -- | A definition of a PUT operation on this path.
220− , _pathItemPut :: Maybe Operation
221−
222− -- | A definition of a POST operation on this path.
223− , _pathItemPost :: Maybe Operation
224−
225− -- | A definition of a DELETE operation on this path.
226− , _pathItemDelete :: Maybe Operation
227−
228− -- | A definition of a OPTIONS operation on this path.
229− , _pathItemOptions :: Maybe Operation
230−
231− -- | A definition of a HEAD operation on this path.
232− , _pathItemHead :: Maybe Operation
233−
234− -- | A definition of a PATCH operation on this path.
235− , _pathItemPatch :: Maybe Operation
236−
237− -- | A definition of a TRACE operation on this path.
238− , _pathItemTrace :: Maybe Operation
239−
240− -- | An alternative server array to service all operations in this path.
241− , _pathItemServers :: [Server]
242−
243− -- | A list of parameters that are applicable for all the operations described under this path.
244− -- These parameters can be overridden at the operation level, but cannot be removed there.
245− -- The list MUST NOT include duplicated parameters.
246− -- A unique parameter is defined by a combination of a name and location.
247− , _pathItemParameters :: [Referenced Param]
248− } deriving (Eq, Show, Generic, Data, Typeable)
249−
250−-- | Describes a single API operation on a path.
251−data Operation = Operation
252− { -- | A list of tags for API documentation control.
253− -- Tags can be used for logical grouping of operations by resources or any other qualifier.
254− _operationTags :: InsOrdHashSet TagName
255−
256− -- | A short summary of what the operation does.
257− -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
258− , _operationSummary :: Maybe Text
259−
260− -- | A verbose explanation of the operation behavior.
261− -- [CommonMark syntax](https://spec.commonmark.org/) can be used for rich text representation.
262− , _operationDescription :: Maybe Text
263−
264− -- | Additional external documentation for this operation.
265− , _operationExternalDocs :: Maybe ExternalDocs
266−
267− -- | Unique string used to identify the operation.
268− -- The id MUST be unique among all operations described in the API.
269− -- The operationId value is **case-sensitive**.
270− -- Tools and libraries MAY use the operationId to uniquely identify an operation, therefore,
271− -- it is RECOMMENDED to follow common programming naming conventions.
272− , _operationOperationId :: Maybe Text
273−
274− -- | A list of parameters that are applicable for this operation.
275− -- If a parameter is already defined at the @'PathItem'@,
276− -- the new definition will override it, but can never remove it.
277− -- The list MUST NOT include duplicated parameters.
278− -- A unique parameter is defined by a combination of a name and location.
279− , _operationParameters :: [Referenced Param]
280−
281− -- | The request body applicable for this operation.
282− -- The requestBody is only supported in HTTP methods where the HTTP 1.1
283− -- specification [RFC7231](https://tools.ietf.org/html/rfc7231#section-4.3.1)
284− -- has explicitly defined semantics for request bodies.
285− -- In other cases where the HTTP spec is vague, requestBody SHALL be ignored by consumers.
286− , _operationRequestBody :: Maybe (Referenced RequestBody)
287−
288− -- | The list of possible responses as they are returned from executing this operation.
289− , _operationResponses :: Responses
290−
291− -- | A map of possible out-of band callbacks related to the parent operation.
292− -- The key is a unique identifier for the 'Callback' Object.
293− -- Each value in the map is a 'Callback' Object that describes a request
294− -- that may be initiated by the API provider and the expected responses.
295− , _operationCallbacks :: InsOrdHashMap Text (Referenced Callback)
296−
297− -- | Declares this operation to be deprecated.
298− -- Usage of the declared operation should be refrained.
299− -- Default value is @False@.
300− , _operationDeprecated :: Maybe Bool
301−
302− -- | A declaration of which security schemes are applied for this operation.
303− -- The list of values describes alternative security schemes that can be used
304− -- (that is, there is a logical OR between the security requirements).
305− -- This definition overrides any declared top-level security.
306− -- To remove a top-level security declaration, @Just []@ can be used.
307− , _operationSecurity :: [SecurityRequirement]
308−
309− -- | An alternative server array to service this operation.
310− -- If an alternative server object is specified at the 'PathItem' Object or Root level,
311− -- it will be overridden by this value.
312− , _operationServers :: [Server]
313− } deriving (Eq, Show, Generic, Data, Typeable)
314−
315−-- This instance should be in @http-media@.
316−instance Data MediaType where
317− gunfold k z c = case constrIndex c of
318− 1 -> k (k (k (z (\main sub params -> foldl (/:) (main // sub) (Map.toList params)))))
319− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MediaType."
320−
321− toConstr _ = mediaTypeConstr
322−
323− dataTypeOf _ = mediaTypeData
324−
325−mediaTypeConstr = mkConstr mediaTypeData "MediaType" [] Prefix
326−mediaTypeData = mkDataType "MediaType" [mediaTypeConstr]
327−
328−instance Hashable MediaType where
329− hashWithSalt salt mt = salt `hashWithSalt` show mt
330−
331−-- | Describes a single request body.
332−data RequestBody = RequestBody
333− { -- | A brief description of the request body. This could contain examples of use.
334− -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.
335− _requestBodyDescription :: Maybe Text
336−
337− -- | The content of the request body.
338− -- The key is a media type or media type range and the value describes it.
339− -- For requests that match multiple keys, only the most specific key is applicable.
340− -- e.g. @text/plain@ overrides @text/\*@
341− , _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject
342−
343− -- | Determines if the request body is required in the request.
344− -- Defaults to 'False'.
345− , _requestBodyRequired :: Maybe Bool
346− } deriving (Eq, Show, Generic, Data, Typeable)
347−
348−-- | Each Media Type Object provides schema and examples for the media type identified by its key.
349−data MediaTypeObject = MediaTypeObject
350− { _mediaTypeObjectSchema :: Maybe (Referenced Schema)
351−
352− -- | Example of the media type.
353− -- The example object SHOULD be in the correct format as specified by the media type.
354− , _mediaTypeObjectExample :: Maybe Value
355−
356− -- | Examples of the media type.
357− -- Each example object SHOULD match the media type and specified schema if present.
358− , _mediaTypeObjectExamples :: InsOrdHashMap Text (Referenced Example)
359−
360− -- | A map between a property name and its encoding information.
361− -- The key, being the property name, MUST exist in the schema as a property.
362− -- The encoding object SHALL only apply to 'RequestBody' objects when the media type
363− -- is @multipart@ or @application/x-www-form-urlencoded@.
364− , _mediaTypeObjectEncoding :: InsOrdHashMap Text Encoding
365− } deriving (Eq, Show, Generic, Data, Typeable)
366−
367−-- | In order to support common ways of serializing simple parameters, a set of style values are defined.
368−data Style
369− = StyleMatrix
370− -- ^ Path-style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7).
371− | StyleLabel
372− -- ^ Label style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7).
373− | StyleForm
374− -- ^ Form style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7).
375− -- This option replaces @collectionFormat@ with a @csv@ (when @explode@ is false) or @multi@
376− -- (when explode is true) value from OpenAPI 2.0.
377− | StyleSimple
378− -- ^ Simple style parameters defined by [RFC6570](https://tools.ietf.org/html/rfc6570#section-3.2.7).
379− -- This option replaces @collectionFormat@ with a @csv@ value from OpenAPI 2.0.
380− | StyleSpaceDelimited
381− -- ^ Space separated array values.
382− -- This option replaces @collectionFormat@ equal to @ssv@ from OpenAPI 2.0.
383− | StylePipeDelimited
384− -- ^ Pipe separated array values.
385− -- This option replaces @collectionFormat@ equal to @pipes@ from OpenAPI 2.0.
386− | StyleDeepObject
387− -- ^ Provides a simple way of rendering nested objects using form parameters.
388− deriving (Eq, Show, Generic, Data, Typeable)
389−
390−data Encoding = Encoding
391− { -- | The Content-Type for encoding a specific property.
392− -- Default value depends on the property type: for @string@
393− -- with format being @binary@ – @application/octet-stream@;
394− -- for other primitive types – @text/plain@; for object - @application/json@;
395− -- for array – the default is defined based on the inner type.
396− -- The value can be a specific media type (e.g. @application/json@),
397− -- a wildcard media type (e.g. @image/\*@), or a comma-separated list of the two types.
398− _encodingContentType :: Maybe MediaType
399−
400− -- | A map allowing additional information to be provided as headers,
401− -- for example @Content-Disposition@. @Content-Type@ is described separately
402− -- and SHALL be ignored in this section.
403− -- This property SHALL be ignored if the request body media type is not a @multipart@.
404− , _encodingHeaders :: InsOrdHashMap Text (Referenced Header)
405−
406− -- | Describes how a specific property value will be serialized depending on its type.
407− -- See 'Param' Object for details on the style property.
408− -- The behavior follows the same values as query parameters, including default values.
409− -- This property SHALL be ignored if the request body media type
410− -- is not @application/x-www-form-urlencoded@.
411− , _encodingStyle :: Maybe Style
412−
413− -- | When this is true, property values of type @array@ or @object@ generate
414− -- separate parameters for each value of the array,
415− -- or key-value-pair of the map.
416− -- For other types of properties this property has no effect.
417− -- When style is form, the default value is @true@. For all other styles,
418− -- the default value is @false@. This property SHALL be ignored
419− -- if the request body media type is not @application/x-www-form-urlencoded@.
420− , _encodingExplode :: Maybe Bool
421−
422− -- | Determines whether the parameter value SHOULD allow reserved characters,
423− -- as defined by [RFC3986](https://tools.ietf.org/html/rfc3986#section-2.2)
424− -- @:/?#[]@!$&'()*+,;=@ to be included without percent-encoding.
425− -- The default value is @false@. This property SHALL be ignored if the request body media type
426− -- is not @application/x-www-form-urlencoded@.
427− , _encodingAllowReserved :: Maybe Bool
428− } deriving (Eq, Show, Generic, Data, Typeable)
429−
430−newtype MimeList = MimeList { getMimeList :: [MediaType] }
431− deriving (Eq, Show, Semigroup, Monoid, Typeable)
432−
433−mimeListConstr :: Constr
434−mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
435−
436−mimeListDataType :: DataType
437−mimeListDataType = mkDataType "Data.OpenApi.MimeList" [mimeListConstr]
438−
439−instance Data MimeList where
440− gunfold k z c = case constrIndex c of
441− 1 -> k (z (MimeList . map fromString))
442− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MimeList."
443− toConstr (MimeList _) = mimeListConstr
444− dataTypeOf _ = mimeListDataType
445−
446−-- | Describes a single operation parameter.
447−-- A unique parameter is defined by a combination of a name and location.
448−data Param = Param
449− { -- | The name of the parameter.
450− -- Parameter names are case sensitive.
451− _paramName :: Text
452−
453− -- | A brief description of the parameter.
454− -- This could contain examples of use.
455− -- CommonMark syntax MAY be used for rich text representation.
456− , _paramDescription :: Maybe Text
457−
458− -- | Determines whether this parameter is mandatory.
459− -- If the parameter is in "path", this property is required and its value MUST be true.
460− -- Otherwise, the property MAY be included and its default value is @False@.
461− , _paramRequired :: Maybe Bool
462−
463− -- | Specifies that a parameter is deprecated and SHOULD be transitioned out of usage.
464− -- Default value is @false@.
465− , _paramDeprecated :: Maybe Bool
466−
467− -- | The location of the parameter.
468− , _paramIn :: ParamLocation
469−
470− -- | Sets the ability to pass empty-valued parameters.
471− -- This is valid only for 'ParamQuery' parameters and allows sending
472− -- a parameter with an empty value. Default value is @false@.
473− , _paramAllowEmptyValue :: Maybe Bool
474−
475− -- | Determines whether the parameter value SHOULD allow reserved characters,
476− -- as defined by [RFC3986](https://tools.ietf.org/html/rfc3986#section-2.2)
477− -- @:/?#[]@!$&'()*+,;=@ to be included without percent-encoding.
478− -- This property only applies to parameters with an '_paramIn' value of 'ParamQuery'.
479− -- The default value is 'False'.
480− , _paramAllowReserved :: Maybe Bool
481−
482− -- | Parameter schema.
483− , _paramSchema :: Maybe (Referenced Schema)
484−
485− -- | Describes how the parameter value will be serialized depending
486− -- on the type of the parameter value. Default values (based on value of '_paramIn'):
487− -- for 'ParamQuery' - 'StyleForm'; for 'ParamPath' - 'StyleSimple'; for 'ParamHeader' - 'StyleSimple';
488− -- for 'ParamCookie' - 'StyleForm'.
489− , _paramStyle :: Maybe Style
490−
491− -- | When this is true, parameter values of type @array@ or @object@
492− -- generate separate parameters for each value of the array or key-value pair of the map.
493− -- For other types of parameters this property has no effect.
494− -- When style is @form@, the default value is true. For all other styles, the default value is false.
495− , _paramExplode :: Maybe Bool
496−
497− -- | Example of the parameter's potential value.
498− -- The example SHOULD match the specified schema and encoding properties if present.
499− -- The '_paramExample' field is mutually exclusive of the '_paramExamples' field.
500− -- Furthermore, if referencing a schema that contains an example, the example value
501− -- SHALL override the example provided by the schema. To represent examples of media types
502− -- that cannot naturally be represented in JSON or YAML, a string value can contain
503− -- the example with escaping where necessary.
504− , _paramExample :: Maybe Value
505−
506− -- | Examples of the parameter's potential value.
507− -- Each example SHOULD contain a value in the correct format as specified
508− -- in the parameter encoding. The '_paramExamples' field is mutually exclusive of the '_paramExample' field.
509− -- Furthermore, if referencing a schema that contains an example,
510− -- the examples value SHALL override the example provided by the schema.
511− , _paramExamples :: InsOrdHashMap Text (Referenced Example)
512−
513− -- TODO
514− -- _paramContent :: InsOrdHashMap MediaType MediaTypeObject
515− -- should be singleton. mutually exclusive with _paramSchema.
516− } deriving (Eq, Show, Generic, Data, Typeable)
517−
518−data Example = Example
519− { -- | Short description for the example.
520− _exampleSummary :: Maybe Text
521−
522− -- | Long description for the example.
523− -- CommonMark syntax MAY be used for rich text representation.
524− , _exampleDescription :: Maybe Text
525−
526− -- | Embedded literal example.
527− -- The '_exampleValue' field and '_exampleExternalValue' field are mutually exclusive.
528− --
529− -- To represent examples of media types that cannot naturally represented in JSON or YAML,
530− -- use a string value to contain the example, escaping where necessary.
531− , _exampleValue :: Maybe Value
532−
533− -- | A URL that points to the literal example.
534− -- This provides the capability to reference examples that cannot easily be included
535− -- in JSON or YAML documents. The '_exampleValue' field
536− -- and '_exampleExternalValue' field are mutually exclusive.
537− , _exampleExternalValue :: Maybe URL
538− } deriving (Eq, Show, Generic, Typeable, Data)
539−
540−data ExpressionOrValue
541− = Expression Text
542− | Value Value
543− deriving (Eq, Show, Generic, Typeable, Data)
544−
545−-- | The Link object represents a possible design-time link for a response.
546−-- The presence of a link does not guarantee the caller's ability to successfully invoke it,
547−-- rather it provides a known relationship and traversal mechanism between responses and other operations.
548−data Link = Link
549− { -- | A relative or absolute URI reference to an OAS operation.
550− -- This field is mutually exclusive of the '_linkOperationId' field,
551− -- and MUST point to an 'Operation' Object. Relative '_linkOperationRef'
552− -- values MAY be used to locate an existing 'Operation' Object in the OpenAPI definition.
553− _linkOperationRef :: Maybe Text
554−
555− -- | The name of an /existing/, resolvable OAS operation, as defined with a unique
556− -- '_operationOperationId'. This field is mutually exclusive of the '_linkOperationRef' field.
557− , _linkOperationId :: Maybe Text
558−
559− -- | A map representing parameters to pass to an operation as specified with '_linkOperationId'
560− -- or identified via '_linkOperationRef'. The key is the parameter name to be used, whereas
561− -- the value can be a constant or an expression to be evaluated and passed to the linked operation.
562− -- The parameter name can be qualified using the parameter location @[{in}.]{name}@
563− -- for operations that use the same parameter name in different locations (e.g. path.id).
564− , _linkParameters :: InsOrdHashMap Text ExpressionOrValue
565−
566− -- | A literal value or @{expression}@ to use as a request body when calling the target operation.
567− , _linkRequestBody :: Maybe ExpressionOrValue
568−
569− -- | A description of the link.
570− , _linkDescription :: Maybe Text
571−
572− -- | A server object to be used by the target operation.
573− , _linkServer :: Maybe Server
574− } deriving (Eq, Show, Generic, Typeable, Data)
575−
576−-- | Items for @'OpenApiArray'@ schemas.
577−--
578−-- __Warning__: OpenAPI 3.0 does not support tuple arrays. However, OpenAPI 3.1 will, as
579−-- it will incorporate Json Schema mostly verbatim.
580−--
581−-- @'OpenApiItemsObject'@ should be used to specify homogenous array @'Schema'@s.
582−--
583−-- @'OpenApiItemsArray'@ should be used to specify tuple @'Schema'@s.
584−data OpenApiItems where
585− OpenApiItemsObject :: Referenced Schema -> OpenApiItems
586− OpenApiItemsArray :: [Referenced Schema] -> OpenApiItems
587− deriving (Eq, Show, Typeable, Data)
588−
589−data OpenApiType where
590− OpenApiString :: OpenApiType
591− OpenApiNumber :: OpenApiType
592− OpenApiInteger :: OpenApiType
593− OpenApiBoolean :: OpenApiType
594− OpenApiArray :: OpenApiType
595− OpenApiNull :: OpenApiType
596− OpenApiObject :: OpenApiType
597− deriving (Eq, Show, Typeable, Generic, Data)
598−
599−data ParamLocation
600− = -- | Parameters that are appended to the URL.
601− -- For example, in @/items?id=###@, the query parameter is @id@.
602− ParamQuery
603− -- | Custom headers that are expected as part of the request.
604− | ParamHeader
605− -- | Used together with Path Templating, where the parameter value is actually part of the operation's URL.
606− -- This does not include the host or base path of the API.
607− -- For example, in @/items/{itemId}@, the path parameter is @itemId@.
608− | ParamPath
609− -- | Used to pass a specific cookie value to the API.
610− | ParamCookie
611− deriving (Eq, Show, Generic, Data, Typeable)
612−
613−type Format = Text
614−
615−type ParamName = Text
616−
617−data Schema = Schema
618− { _schemaTitle :: Maybe Text
619− , _schemaDescription :: Maybe Text
620− , _schemaRequired :: [ParamName]
621−
622− , _schemaNullable :: Maybe Bool
623− , _schemaAllOf :: Maybe [Referenced Schema]
624− , _schemaOneOf :: Maybe [Referenced Schema]
625− , _schemaNot :: Maybe (Referenced Schema)
626− , _schemaAnyOf :: Maybe [Referenced Schema]
627− , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
628− , _schemaAdditionalProperties :: Maybe AdditionalProperties
629−
630− , _schemaDiscriminator :: Maybe Discriminator
631− , _schemaReadOnly :: Maybe Bool
632− , _schemaWriteOnly :: Maybe Bool
633− , _schemaXml :: Maybe Xml
634− , _schemaExternalDocs :: Maybe ExternalDocs
635− , _schemaExample :: Maybe Value
636− , _schemaDeprecated :: Maybe Bool
637−
638− , _schemaMaxProperties :: Maybe Integer
639− , _schemaMinProperties :: Maybe Integer
640−
641− , -- | Declares the value of the parameter that the server will use if none is provided,
642− -- for example a @"count"@ to control the number of results per page might default to @100@
643− -- if not supplied by the client in the request.
644− -- (Note: "default" has no meaning for required parameters.)
645− -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
646− _schemaDefault :: Maybe Value
647−
648− , _schemaType :: Maybe OpenApiType
649− , _schemaFormat :: Maybe Format
650− , _schemaItems :: Maybe OpenApiItems
651− , _schemaMaximum :: Maybe Scientific
652− , _schemaExclusiveMaximum :: Maybe Bool
653− , _schemaMinimum :: Maybe Scientific
654− , _schemaExclusiveMinimum :: Maybe Bool
655− , _schemaMaxLength :: Maybe Integer
656− , _schemaMinLength :: Maybe Integer
657− , _schemaPattern :: Maybe Pattern
658− , _schemaMaxItems :: Maybe Integer
659− , _schemaMinItems :: Maybe Integer
660− , _schemaUniqueItems :: Maybe Bool
661− , _schemaEnum :: Maybe [Value]
662− , _schemaMultipleOf :: Maybe Scientific
663− } deriving (Eq, Show, Generic, Data, Typeable)
664−
665−-- | Regex pattern for @string@ type.
666−type Pattern = Text
667−
668−data Discriminator = Discriminator
669− { -- | The name of the property in the payload that will hold the discriminator value.
670− _discriminatorPropertyName :: Text
671−
672− -- | An object to hold mappings between payload values and schema names or references.
673− , _discriminatorMapping :: InsOrdHashMap Text Text
674− } deriving (Eq, Show, Generic, Data, Typeable)
675−
676−-- | A @'Schema'@ with an optional name.
677−-- This name can be used in references.
678−data NamedSchema = NamedSchema
679− { _namedSchemaName :: Maybe Text
680− , _namedSchemaSchema :: Schema
681− } deriving (Eq, Show, Generic, Data, Typeable)
682−
683−data Xml = Xml
684− { -- | Replaces the name of the element/attribute used for the described schema property.
685− -- When defined within the @'OpenApiItems'@ (items), it will affect the name of the individual XML elements within the list.
686− -- When defined alongside type being array (outside the items),
687− -- it will affect the wrapping element and only if wrapped is true.
688− -- If wrapped is false, it will be ignored.
689− _xmlName :: Maybe Text
690−
691− -- | The URL of the namespace definition.
692− -- Value SHOULD be in the form of a URL.
693− , _xmlNamespace :: Maybe Text
694−
695− -- | The prefix to be used for the name.
696− , _xmlPrefix :: Maybe Text
697−
698− -- | Declares whether the property definition translates to an attribute instead of an element.
699− -- Default value is @False@.
700− , _xmlAttribute :: Maybe Bool
701−
702− -- | MAY be used only for an array definition.
703− -- Signifies whether the array is wrapped
704− -- (for example, @\<books\>\<book/\>\<book/\>\</books\>@)
705− -- or unwrapped (@\<book/\>\<book/\>@).
706− -- Default value is @False@.
707− -- The definition takes effect only when defined alongside type being array (outside the items).
708− , _xmlWrapped :: Maybe Bool
709− } deriving (Eq, Show, Generic, Data, Typeable)
710−
711−-- | A container for the expected responses of an operation.
712−-- The container maps a HTTP response code to the expected response.
713−-- It is not expected from the documentation to necessarily cover all possible HTTP response codes,
714−-- since they may not be known in advance.
715−-- However, it is expected from the documentation to cover a successful operation response and any known errors.
716−data Responses = Responses
717− { -- | The documentation of responses other than the ones declared for specific HTTP response codes.
718− -- It can be used to cover undeclared responses.
719− _responsesDefault :: Maybe (Referenced Response)
720−
721− -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
722− -- Describes the expected response for those HTTP status codes.
723− , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)
724− } deriving (Eq, Show, Generic, Data, Typeable)
725−
726−type HttpStatusCode = Int
727−
728−-- | Describes a single response from an API Operation.
729−data Response = Response
730− { -- | A short description of the response.
731− -- [CommonMark syntax](https://spec.commonmark.org/) can be used for rich text representation.
732− _responseDescription :: Text
733−
734− -- | A map containing descriptions of potential response payloads.
735− -- The key is a media type or media type range and the value describes it.
736− -- For responses that match multiple keys, only the most specific key is applicable.
737− -- e.g. @text/plain@ overrides @text/\*@.
738− , _responseContent :: InsOrdHashMap MediaType MediaTypeObject
739−
740− -- | Maps a header name to its definition.
741− , _responseHeaders :: InsOrdHashMap HeaderName (Referenced Header)
742−
743− -- | A map of operations links that can be followed from the response.
744− -- The key of the map is a short name for the link, following the naming
745− -- constraints of the names for 'Component' Objects.
746− , _responseLinks :: InsOrdHashMap Text (Referenced Link)
747− } deriving (Eq, Show, Generic, Data, Typeable)
748−
749−instance IsString Response where
750− fromString s = Response (fromString s) mempty mempty mempty
751−
752−-- | A map of possible out-of band callbacks related to the parent operation.
753−-- Each value in the map is a 'PathItem' Object that describes a set of requests that
754−-- may be initiated by the API provider and the expected responses.
755−-- The key value used to identify the path item object is an expression, evaluated at runtime,
756−-- that identifies a URL to use for the callback operation.
757−newtype Callback = Callback (InsOrdHashMap Text PathItem)
758− deriving (Eq, Show, Generic, Data, Typeable)
759−
760−type HeaderName = Text
761−
762−-- | Header fields have the same meaning as for 'Param'.
763−--
764−-- Style is always treated as 'StyleSimple', as it is the only value allowed for headers.
765−data Header = Header
766− { -- | A short description of the header.
767− _headerDescription :: Maybe HeaderName
768−
769− , _headerRequired :: Maybe Bool
770− , _headerDeprecated :: Maybe Bool
771− , _headerAllowEmptyValue :: Maybe Bool
772− , _headerExplode :: Maybe Bool
773− , _headerExample :: Maybe Value
774− , _headerExamples :: InsOrdHashMap Text (Referenced Example)
775−
776− , _headerSchema :: Maybe (Referenced Schema)
777− } deriving (Eq, Show, Generic, Data, Typeable)
778−
779−-- | The location of the API key.
780−data ApiKeyLocation
781− = ApiKeyQuery
782− | ApiKeyHeader
783− | ApiKeyCookie
784− deriving (Eq, Show, Generic, Data, Typeable)
785−
786−data ApiKeyParams = ApiKeyParams
787− { -- | The name of the header or query parameter to be used.
788− _apiKeyName :: Text
789−
790− -- | The location of the API key.
791− , _apiKeyIn :: ApiKeyLocation
792− } deriving (Eq, Show, Generic, Data, Typeable)
793−
794−-- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
795−type AuthorizationURL = Text
796−
797−-- | The token URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
798−type TokenURL = Text
799−
800−newtype OAuth2ImplicitFlow
801− = OAuth2ImplicitFlow {_oAuth2ImplicitFlowAuthorizationUrl :: AuthorizationURL}
802− deriving (Eq, Show, Generic, Data, Typeable)
803−
804−newtype OAuth2PasswordFlow
805− = OAuth2PasswordFlow {_oAuth2PasswordFlowTokenUrl :: TokenURL}
806− deriving (Eq, Show, Generic, Data, Typeable)
807−
808−newtype OAuth2ClientCredentialsFlow
809− = OAuth2ClientCredentialsFlow {_oAuth2ClientCredentialsFlowTokenUrl :: TokenURL}
810− deriving (Eq, Show, Generic, Data, Typeable)
811−
812−data OAuth2AuthorizationCodeFlow = OAuth2AuthorizationCodeFlow
813− { _oAuth2AuthorizationCodeFlowAuthorizationUrl :: AuthorizationURL
814− , _oAuth2AuthorizationCodeFlowTokenUrl :: TokenURL
815− } deriving (Eq, Show, Generic, Data, Typeable)
816−
817−data OAuth2Flow p = OAuth2Flow
818− { _oAuth2Params :: p
819−
820− -- | The URL to be used for obtaining refresh tokens.
821− , _oAath2RefreshUrl :: Maybe URL
822−
823− -- | The available scopes for the OAuth2 security scheme.
824− -- A map between the scope name and a short description for it.
825− -- The map MAY be empty.
826− , _oAuth2Scopes :: InsOrdHashMap Text Text
827− } deriving (Eq, Show, Generic, Data, Typeable)
828−
829−data OAuth2Flows = OAuth2Flows
830− { -- | Configuration for the OAuth Implicit flow
831− _oAuth2FlowsImplicit :: Maybe (OAuth2Flow OAuth2ImplicitFlow)
832−
833− -- | Configuration for the OAuth Resource Owner Password flow
834− , _oAuth2FlowsPassword :: Maybe (OAuth2Flow OAuth2PasswordFlow)
835−
836− -- | Configuration for the OAuth Client Credentials flow
837− , _oAuth2FlowsClientCredentials :: Maybe (OAuth2Flow OAuth2ClientCredentialsFlow)
838−
839− -- | Configuration for the OAuth Authorization Code flow
840− , _oAuth2FlowsAuthorizationCode :: Maybe (OAuth2Flow OAuth2AuthorizationCodeFlow)
841− } deriving (Eq, Show, Generic, Data, Typeable)
842−
843−type BearerFormat = Text
844−
845−data HttpSchemeType
846− = HttpSchemeBearer (Maybe BearerFormat)
847− | HttpSchemeBasic
848− | HttpSchemeCustom Text
849− deriving (Eq, Show, Generic, Data, Typeable)
850−
851−-- |
852−--
853−-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeBearer Nothing))
854−-- {
855−-- "scheme": "bearer",
856−-- "type": "http"
857−-- }
858−--
859−-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeBearer (Just "jwt")))
860−-- {
861−-- "bearerFormat": "jwt",
862−-- "scheme": "bearer",
863−-- "type": "http"
864−-- }
865−--
866−-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp HttpSchemeBasic)
867−-- {
868−-- "scheme": "basic",
869−-- "type": "http"
870−-- }
871−--
872−-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeHttp (HttpSchemeCustom "CANARY"))
873−-- {
874−-- "scheme": "CANARY",
875−-- "type": "http"
876−-- }
877−--
878−-- >>> BSL.putStrLn $ encodePretty (SecuritySchemeApiKey (ApiKeyParams "id" ApiKeyCookie))
879−-- {
880−-- "in": "cookie",
881−-- "name": "id",
882−-- "type": "apiKey"
883−-- }
884−--
885−data SecuritySchemeType
886− = SecuritySchemeHttp HttpSchemeType
887− | SecuritySchemeApiKey ApiKeyParams
888− | SecuritySchemeOAuth2 OAuth2Flows
889− | SecuritySchemeOpenIdConnect URL
890− deriving (Eq, Show, Generic, Data, Typeable)
891−
892−data SecurityScheme = SecurityScheme
893− { -- | The type of the security scheme.
894− _securitySchemeType :: SecuritySchemeType
895−
896− -- | A short description for security scheme.
897− , _securitySchemeDescription :: Maybe Text
898− } deriving (Eq, Show, Generic, Data, Typeable)
899−
900−newtype SecurityDefinitions
901− = SecurityDefinitions (Definitions SecurityScheme)
902− deriving (Eq, Show, Generic, Data, Typeable)
903−
904−-- | Lists the required security schemes to execute this operation.
905−-- The object can have multiple security schemes declared in it which are all required
906−-- (that is, there is a logical AND between the schemes).
907−newtype SecurityRequirement = SecurityRequirement
908− { getSecurityRequirement :: InsOrdHashMap Text [Text]
909− } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
910−
911−-- | Tag name.
912−type TagName = Text
913−
914−-- | Allows adding meta data to a single tag that is used by @Operation@.
915−-- It is not mandatory to have a @Tag@ per tag used there.
916−data Tag = Tag
917− { -- | The name of the tag.
918− _tagName :: TagName
919−
920− -- | A short description for the tag.
921− -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.
922− , _tagDescription :: Maybe Text
923−
924− -- | Additional external documentation for this tag.
925− , _tagExternalDocs :: Maybe ExternalDocs
926− } deriving (Eq, Ord, Show, Generic, Data, Typeable)
927−
928−instance Hashable Tag
929−
930−instance IsString Tag where
931− fromString s = Tag (fromString s) Nothing Nothing
932−
933−-- | Allows referencing an external resource for extended documentation.
934−data ExternalDocs = ExternalDocs
935− { -- | A short description of the target documentation.
936− -- [CommonMark syntax](https://spec.commonmark.org/) MAY be used for rich text representation.
937− _externalDocsDescription :: Maybe Text
938−
939− -- | The URL for the target documentation.
940− , _externalDocsUrl :: URL
941− } deriving (Eq, Ord, Show, Generic, Data, Typeable)
942−
943−instance Hashable ExternalDocs
944−
945−-- | A simple object to allow referencing other definitions in the specification.
946−-- It can be used to reference parameters and responses that are defined at the top level for reuse.
947−newtype Reference = Reference { getReference :: Text }
948− deriving (Eq, Show, Data, Typeable)
949−
950−data Referenced a
951− = Ref Reference
952− | Inline a
953− deriving (Eq, Show, Functor, Data, Typeable)
954−
955−instance IsString a => IsString (Referenced a) where
956− fromString = Inline . fromString
957−
958−newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable)
959−
960−data AdditionalProperties
961− = AdditionalPropertiesAllowed Bool
962− | AdditionalPropertiesSchema (Referenced Schema)
963− deriving (Eq, Show, Data, Typeable)
964−
965−-------------------------------------------------------------------------------
966−-- Generic instances
967−-------------------------------------------------------------------------------
968−
969−deriveGeneric ''Server
970−deriveGeneric ''Components
971−deriveGeneric ''Header
972−deriveGeneric ''OAuth2Flow
973−deriveGeneric ''OAuth2Flows
974−deriveGeneric ''Operation
975−deriveGeneric ''Param
976−deriveGeneric ''PathItem
977−deriveGeneric ''Response
978−deriveGeneric ''RequestBody
979−deriveGeneric ''MediaTypeObject
980−deriveGeneric ''Responses
981−deriveGeneric ''SecurityScheme
982−deriveGeneric ''Schema
983−deriveGeneric ''OpenApi
984−deriveGeneric ''Example
985−deriveGeneric ''Encoding
986−deriveGeneric ''Link
987−
988−-- =======================================================================
989−-- Monoid instances
990−-- =======================================================================
991−
992−instance Semigroup OpenApi where
993− (<>) = genericMappend
994−instance Monoid OpenApi where
995− mempty = genericMempty
996− mappend = (<>)
997−
998−instance Semigroup Info where
999− (<>) = genericMappend
1000−instance Monoid Info where
1001− mempty = genericMempty
1002− mappend = (<>)
1003−
1004−instance Semigroup Contact where
1005− (<>) = genericMappend
1006−instance Monoid Contact where
1007− mempty = genericMempty
1008− mappend = (<>)
1009−
1010−instance Semigroup Components where
1011− (<>) = genericMappend
1012−instance Monoid Components where
1013− mempty = genericMempty
1014− mappend = (<>)
1015−
1016−instance Semigroup PathItem where
1017− (<>) = genericMappend
1018−instance Monoid PathItem where
1019− mempty = genericMempty
1020− mappend = (<>)
1021−
1022−instance Semigroup Schema where
1023− (<>) = genericMappend
1024−instance Monoid Schema where
1025− mempty = genericMempty
1026− mappend = (<>)
1027−
1028−instance Semigroup Param where
1029− (<>) = genericMappend
1030−instance Monoid Param where
1031− mempty = genericMempty
1032− mappend = (<>)
1033−
1034−instance Semigroup Header where
1035− (<>) = genericMappend
1036−instance Monoid Header where
1037− mempty = genericMempty
1038− mappend = (<>)
1039−
1040−instance Semigroup Responses where
1041− (<>) = genericMappend
1042−instance Monoid Responses where
1043− mempty = genericMempty
1044− mappend = (<>)
1045−
1046−instance Semigroup Response where
1047− (<>) = genericMappend
1048−instance Monoid Response where
1049− mempty = genericMempty
1050− mappend = (<>)
1051−
1052−instance Semigroup MediaTypeObject where
1053− (<>) = genericMappend
1054−instance Monoid MediaTypeObject where
1055− mempty = genericMempty
1056− mappend = (<>)
1057−
1058−instance Semigroup Encoding where
1059− (<>) = genericMappend
1060−instance Monoid Encoding where
1061− mempty = genericMempty
1062− mappend = (<>)
1063−
1064−instance Semigroup ExternalDocs where
1065− (<>) = genericMappend
1066−instance Monoid ExternalDocs where
1067− mempty = genericMempty
1068− mappend = (<>)
1069−
1070−instance Semigroup Operation where
1071− (<>) = genericMappend
1072−instance Monoid Operation where
1073− mempty = genericMempty
1074− mappend = (<>)
1075−
1076−instance Semigroup (OAuth2Flow p) where
1077− l@OAuth2Flow{ _oAath2RefreshUrl = lUrl, _oAuth2Scopes = lScopes }
1078− <> OAuth2Flow { _oAath2RefreshUrl = rUrl, _oAuth2Scopes = rScopes } =
1079− l { _oAath2RefreshUrl = swaggerMappend lUrl rUrl, _oAuth2Scopes = lScopes <> rScopes }
1080−
1081−-- swaggerMappend has First-like semantics, and here we need mappend'ing under Maybes.
1082−instance Semigroup OAuth2Flows where
1083− l <> r = OAuth2Flows
1084− { _oAuth2FlowsImplicit = _oAuth2FlowsImplicit l <> _oAuth2FlowsImplicit r
1085− , _oAuth2FlowsPassword = _oAuth2FlowsPassword l <> _oAuth2FlowsPassword r
1086− , _oAuth2FlowsClientCredentials = _oAuth2FlowsClientCredentials l <> _oAuth2FlowsClientCredentials r
1087− , _oAuth2FlowsAuthorizationCode = _oAuth2FlowsAuthorizationCode l <> _oAuth2FlowsAuthorizationCode r
1088− }
1089−
1090−instance Monoid OAuth2Flows where
1091− mempty = genericMempty
1092− mappend = (<>)
1093−
1094−instance Semigroup SecurityScheme where
1095− SecurityScheme (SecuritySchemeOAuth2 lFlows) lDesc
1096− <> SecurityScheme (SecuritySchemeOAuth2 rFlows) rDesc =
1097− SecurityScheme (SecuritySchemeOAuth2 $ lFlows <> rFlows) (swaggerMappend lDesc rDesc)
1098− l <> _ = l
1099−
1100−instance Semigroup SecurityDefinitions where
1101− (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =
1102− SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2
1103−
1104−instance Monoid SecurityDefinitions where
1105− mempty = SecurityDefinitions InsOrdHashMap.empty
1106− mappend = (<>)
1107−
1108−instance Semigroup RequestBody where
1109− (<>) = genericMappend
1110−instance Monoid RequestBody where
1111− mempty = genericMempty
1112− mappend = (<>)
1113−
1114−-- =======================================================================
1115−-- SwaggerMonoid helper instances
1116−-- =======================================================================
1117−
1118−instance SwaggerMonoid Info
1119−instance SwaggerMonoid Components
1120−instance SwaggerMonoid PathItem
1121−instance SwaggerMonoid Schema
1122−instance SwaggerMonoid Param
1123−instance SwaggerMonoid Responses
1124−instance SwaggerMonoid Response
1125−instance SwaggerMonoid ExternalDocs
1126−instance SwaggerMonoid Operation
1127−instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
1128−instance SwaggerMonoid SecurityDefinitions
1129−
1130−instance SwaggerMonoid MimeList
1131−deriving instance SwaggerMonoid URL
1132−
1133−instance SwaggerMonoid OpenApiType where
1134− swaggerMempty = OpenApiString
1135− swaggerMappend _ y = y
1136−
1137−instance SwaggerMonoid ParamLocation where
1138− swaggerMempty = ParamQuery
1139− swaggerMappend _ y = y
1140−
1141−instance {-# OVERLAPPING #-} SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
1142− swaggerMempty = InsOrdHashMap.empty
1143− swaggerMappend = InsOrdHashMap.unionWith mappend
1144−
1145−instance Monoid a => SwaggerMonoid (Referenced a) where
1146− swaggerMempty = Inline mempty
1147− swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
1148− swaggerMappend _ y = y
1149−
1150−-- =======================================================================
1151−-- Simple Generic-based ToJSON instances
1152−-- =======================================================================
1153−
1154−instance ToJSON Style where
1155− toJSON = genericToJSON (jsonPrefix "Style")
1156−
1157−instance ToJSON OpenApiType where
1158− toJSON = genericToJSON (jsonPrefix "Swagger")
1159−
1160−instance ToJSON ParamLocation where
1161− toJSON = genericToJSON (jsonPrefix "Param")
1162−
1163−instance ToJSON Info where
1164− toJSON = genericToJSON (jsonPrefix "Info")
1165−
1166−instance ToJSON Contact where
1167− toJSON = genericToJSON (jsonPrefix "Contact")
1168−
1169−instance ToJSON License where
1170− toJSON = genericToJSON (jsonPrefix "License")
1171−
1172−instance ToJSON ServerVariable where
1173− toJSON = genericToJSON (jsonPrefix "ServerVariable")
1174−
1175−instance ToJSON ApiKeyLocation where
1176− toJSON = genericToJSON (jsonPrefix "ApiKey")
1177−
1178−instance ToJSON ApiKeyParams where
1179− toJSON = genericToJSON (jsonPrefix "apiKey")
1180−
1181−instance ToJSON Tag where
1182− toJSON = genericToJSON (jsonPrefix "Tag")
1183−
1184−instance ToJSON ExternalDocs where
1185− toJSON = genericToJSON (jsonPrefix "ExternalDocs")
1186−
1187−instance ToJSON Xml where
1188− toJSON = genericToJSON (jsonPrefix "Xml")
1189−
1190−instance ToJSON Discriminator where
1191− toJSON = genericToJSON (jsonPrefix "Discriminator")
1192−
1193−instance ToJSON OAuth2ImplicitFlow where
1194− toJSON = genericToJSON (jsonPrefix "OAuth2ImplicitFlow")
1195−
1196−instance ToJSON OAuth2PasswordFlow where
1197− toJSON = genericToJSON (jsonPrefix "OAuth2PasswordFlow")
1198−
1199−instance ToJSON OAuth2ClientCredentialsFlow where
1200− toJSON = genericToJSON (jsonPrefix "OAuth2ClientCredentialsFlow")
1201−
1202−instance ToJSON OAuth2AuthorizationCodeFlow where
1203− toJSON = genericToJSON (jsonPrefix "OAuth2AuthorizationCodeFlow")
1204−
1205−-- =======================================================================
1206−-- Simple Generic-based FromJSON instances
1207−-- =======================================================================
1208−
1209−instance FromJSON Style where
1210− parseJSON = genericParseJSON (jsonPrefix "Style")
1211−
1212−instance FromJSON OpenApiType where
1213− parseJSON = genericParseJSON (jsonPrefix "Swagger")
1214−
1215−instance FromJSON ParamLocation where
1216− parseJSON = genericParseJSON (jsonPrefix "Param")
1217−
1218−instance FromJSON Info where
1219− parseJSON = genericParseJSON (jsonPrefix "Info")
1220−
1221−instance FromJSON Contact where
1222− parseJSON = genericParseJSON (jsonPrefix "Contact")
1223−
1224−instance FromJSON License where
1225− parseJSON = genericParseJSON (jsonPrefix "License")
1226−
1227−instance FromJSON ServerVariable where
1228− parseJSON = genericParseJSON (jsonPrefix "ServerVariable")
1229−
1230−instance FromJSON ApiKeyLocation where
1231− parseJSON = genericParseJSON (jsonPrefix "ApiKey")
1232−
1233−instance FromJSON ApiKeyParams where
1234− parseJSON = genericParseJSON (jsonPrefix "apiKey")
1235−
1236−instance FromJSON Tag where
1237− parseJSON = genericParseJSON (jsonPrefix "Tag")
1238−
1239−instance FromJSON ExternalDocs where
1240− parseJSON = genericParseJSON (jsonPrefix "ExternalDocs")
1241−
1242−instance FromJSON Discriminator where
1243− parseJSON = genericParseJSON (jsonPrefix "Discriminator")
1244−
1245−instance FromJSON OAuth2ImplicitFlow where
1246− parseJSON = genericParseJSON (jsonPrefix "OAuth2ImplicitFlow")
1247−
1248−instance FromJSON OAuth2PasswordFlow where
1249− parseJSON = genericParseJSON (jsonPrefix "OAuth2PasswordFlow")
1250−
1251−instance FromJSON OAuth2ClientCredentialsFlow where
1252− parseJSON = genericParseJSON (jsonPrefix "OAuth2ClientCredentialsFlow")
1253−
1254−instance FromJSON OAuth2AuthorizationCodeFlow where
1255− parseJSON = genericParseJSON (jsonPrefix "OAuth2AuthorizationCodeFlow")
1256−
1257−-- =======================================================================
1258−-- Manual ToJSON instances
1259−-- =======================================================================
1260−
1261−instance ToJSON MediaType where
1262− toJSON = toJSON . show
1263− toEncoding = toEncoding . show
1264−
1265−instance ToJSONKey MediaType where
1266− toJSONKey = JSON.toJSONKeyText (Text.pack . show)
1267−
1268−instance (Eq p, ToJSON p, AesonDefaultValue p) => ToJSON (OAuth2Flow p) where
1269− toJSON = sopSwaggerGenericToJSON
1270− toEncoding = sopSwaggerGenericToEncoding
1271−
1272−instance ToJSON OAuth2Flows where
1273− toJSON = sopSwaggerGenericToJSON
1274− toEncoding = sopSwaggerGenericToEncoding
1275−
1276−instance ToJSON SecuritySchemeType where
1277− toJSON (SecuritySchemeHttp ty) = case ty of
1278− HttpSchemeBearer mFmt ->
1279− object $ [ "type" .= ("http" :: Text)
1280− , "scheme" .= ("bearer" :: Text)
1281− ] <> maybe [] (\t -> ["bearerFormat" .= t]) mFmt
1282− HttpSchemeBasic ->
1283− object [ "type" .= ("http" :: Text)
1284− , "scheme" .= ("basic" :: Text)
1285− ]
1286− HttpSchemeCustom t ->
1287− object [ "type" .= ("http" :: Text)
1288− , "scheme" .= t
1289− ]
1290− toJSON (SecuritySchemeApiKey params)
1291− = toJSON params
1292− <+> object [ "type" .= ("apiKey" :: Text) ]
1293− toJSON (SecuritySchemeOAuth2 params) = object
1294− [ "type" .= ("oauth2" :: Text)
1295− , "flows" .= toJSON params
1296− ]
1297− toJSON (SecuritySchemeOpenIdConnect url) = object
1298− [ "type" .= ("openIdConnect" :: Text)
1299− , "openIdConnectUrl" .= url
1300− ]
1301−
1302−instance ToJSON OpenApi where
1303− toJSON a = sopSwaggerGenericToJSON a &
1304− if InsOrdHashMap.null (_openApiPaths a)
1305− then (<+> object ["paths" .= object []])
1306− else id
1307− toEncoding = sopSwaggerGenericToEncoding
1308−
1309−instance ToJSON Server where
1310− toJSON = sopSwaggerGenericToJSON
1311− toEncoding = sopSwaggerGenericToEncoding
1312−
1313−instance ToJSON SecurityScheme where
1314− toJSON = sopSwaggerGenericToJSON
1315− toEncoding = sopSwaggerGenericToEncoding
1316−
1317−instance ToJSON Schema where
1318− toJSON = sopSwaggerGenericToJSONWithOpts $
1319− mkSwaggerAesonOptions "schema" & saoSubObject ?~ "items"
1320−
1321−instance ToJSON Header where
1322− toJSON = sopSwaggerGenericToJSON
1323− toEncoding = sopSwaggerGenericToEncoding
1324−
1325−-- | As for nullary schema for 0-arity type constructors, see
1326−-- <https://github.com/GetShopTV/swagger2/issues/167>.
1327−--
1328−-- >>> BSL.putStrLn $ encodePretty (OpenApiItemsArray [])
1329−-- {
1330−-- "example": [],
1331−-- "items": {},
1332−-- "maxItems": 0
1333−-- }
1334−--
1335−instance ToJSON OpenApiItems where
1336− toJSON (OpenApiItemsObject x) = object [ "items" .= x ]
1337− toJSON (OpenApiItemsArray []) = object
1338− [ "items" .= object []
1339− , "maxItems" .= (0 :: Int)
1340− , "example" .= Array mempty
1341− ]
1342− toJSON (OpenApiItemsArray x) = object [ "items" .= x ]
1343−
1344−instance ToJSON Components where
1345− toJSON = sopSwaggerGenericToJSON
1346− toEncoding = sopSwaggerGenericToEncoding
1347−
1348−instance ToJSON MimeList where
1349− toJSON (MimeList xs) = toJSON (map show xs)
1350−
1351−instance ToJSON Param where
1352− toJSON = sopSwaggerGenericToJSON
1353− toEncoding = sopSwaggerGenericToEncoding
1354−
1355−instance ToJSON Responses where
1356− toJSON = sopSwaggerGenericToJSON
1357− toEncoding = sopSwaggerGenericToEncoding
1358−
1359−instance ToJSON Response where
1360− toJSON = sopSwaggerGenericToJSON
1361− toEncoding = sopSwaggerGenericToEncoding
1362−
1363−instance ToJSON Operation where
1364− toJSON = sopSwaggerGenericToJSON
1365− toEncoding = sopSwaggerGenericToEncoding
1366−
1367−instance ToJSON PathItem where
1368− toJSON = sopSwaggerGenericToJSON
1369− toEncoding = sopSwaggerGenericToEncoding
1370−
1371−instance ToJSON RequestBody where
1372− toJSON = sopSwaggerGenericToJSON
1373− toEncoding = sopSwaggerGenericToEncoding
1374−
1375−instance ToJSON MediaTypeObject where
1376− toJSON = sopSwaggerGenericToJSON
1377− toEncoding = sopSwaggerGenericToEncoding
1378−
1379−instance ToJSON Example where
1380− toJSON = sopSwaggerGenericToJSON
1381− toEncoding = sopSwaggerGenericToEncoding
1382−
1383−instance ToJSON Encoding where
1384− toJSON = sopSwaggerGenericToJSON
1385− toEncoding = sopSwaggerGenericToEncoding
1386−
1387−instance ToJSON Link where
1388− toJSON = sopSwaggerGenericToJSON
1389− toEncoding = sopSwaggerGenericToEncoding
1390−
1391−instance ToJSON SecurityDefinitions where
1392− toJSON (SecurityDefinitions sd) = toJSON sd
1393−
1394−instance ToJSON Reference where
1395− toJSON (Reference ref) = object [ "$ref" .= ref ]
1396−
1397−referencedToJSON :: ToJSON a => Text -> Referenced a -> Value
1398−referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ]
1399−referencedToJSON _ (Inline x) = toJSON x
1400−
1401−instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/components/schemas/"
1402−instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/components/parameters/"
1403−instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/components/responses/"
1404−instance ToJSON (Referenced RequestBody) where toJSON = referencedToJSON "#/components/requestBodies/"
1405−instance ToJSON (Referenced Example) where toJSON = referencedToJSON "#/components/examples/"
1406−instance ToJSON (Referenced Header) where toJSON = referencedToJSON "#/components/headers/"
1407−instance ToJSON (Referenced Link) where toJSON = referencedToJSON "#/components/links/"
1408−instance ToJSON (Referenced Callback) where toJSON = referencedToJSON "#/components/callbacks/"
1409−
1410−instance ToJSON AdditionalProperties where
1411− toJSON (AdditionalPropertiesAllowed b) = toJSON b
1412− toJSON (AdditionalPropertiesSchema s) = toJSON s
1413−
1414−instance ToJSON ExpressionOrValue where
1415− toJSON (Expression expr) = toJSON expr
1416− toJSON (Value val) = toJSON val
1417−
1418−instance ToJSON Callback where
1419− toJSON (Callback ps) = toJSON ps
1420−
1421−-- =======================================================================
1422−-- Manual FromJSON instances
1423−-- =======================================================================
1424−
1425−instance FromJSON MediaType where
1426− parseJSON = withText "MediaType" $ \str ->
1427− maybe (fail $ "Invalid media type literal " <> Text.unpack str) pure $ parseAccept $ encodeUtf8 str
1428−
1429−instance FromJSONKey MediaType where
1430− fromJSONKey = FromJSONKeyTextParser (parseJSON . String)
1431−
1432−instance (Eq p, FromJSON p, AesonDefaultValue p) => FromJSON (OAuth2Flow p) where
1433− parseJSON = sopSwaggerGenericParseJSON
1434−
1435−instance FromJSON OAuth2Flows where
1436− parseJSON = sopSwaggerGenericParseJSON
1437−
1438−instance FromJSON SecuritySchemeType where
1439− parseJSON js@(Object o) = do
1440− (t :: Text) <- o .: "type"
1441− case t of
1442− "http" -> do
1443− scheme <- o .: "scheme"
1444− SecuritySchemeHttp <$> case scheme of
1445− "bearer" -> HttpSchemeBearer <$> (o .:! "bearerFormat")
1446− "basic" -> pure HttpSchemeBasic
1447− t -> pure $ HttpSchemeCustom t
1448− "apiKey" -> SecuritySchemeApiKey <$> parseJSON js
1449− "oauth2" -> SecuritySchemeOAuth2 <$> (o .: "flows")
1450− "openIdConnect" -> SecuritySchemeOpenIdConnect <$> (o .: "openIdConnectUrl")
1451− _ -> empty
1452− parseJSON _ = empty
1453−
1454−instance FromJSON OpenApi where
1455− parseJSON = sopSwaggerGenericParseJSON
1456−
1457−instance FromJSON Server where
1458− parseJSON = sopSwaggerGenericParseJSON
1459−
1460−instance FromJSON SecurityScheme where
1461− parseJSON = sopSwaggerGenericParseJSON
1462−
1463−instance FromJSON Schema where
1464− parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
1465− where nullaryCleanup :: Schema -> Schema
1466− nullaryCleanup s =
1467− if _schemaItems s == Just (OpenApiItemsArray [])
1468− then s { _schemaExample = Nothing
1469− , _schemaMaxItems = Nothing
1470− }
1471− else s
1472−
1473−instance FromJSON Header where
1474− parseJSON = sopSwaggerGenericParseJSON
1475−
1476−instance FromJSON OpenApiItems where
1477− parseJSON js@(Object obj)
1478− | null obj = pure $ OpenApiItemsArray [] -- Nullary schema.
1479− | otherwise = OpenApiItemsObject <$> parseJSON js
1480− parseJSON js@(Array _) = OpenApiItemsArray <$> parseJSON js
1481− parseJSON _ = empty
1482−
1483−instance FromJSON Components where
1484− parseJSON = sopSwaggerGenericParseJSON
1485−
1486−instance FromJSON MimeList where
1487− parseJSON js = MimeList . map fromString <$> parseJSON js
1488−
1489−instance FromJSON Param where
1490− parseJSON = sopSwaggerGenericParseJSON
1491−
1492−instance FromJSON Responses where
1493− parseJSON (Object o) = Responses
1494− <$> o .:? "default"
1495− <*> parseJSON (Object (deleteKey "default" o))
1496− parseJSON _ = empty
1497−
1498−instance FromJSON Example where
1499− parseJSON = sopSwaggerGenericParseJSON
1500−
1501−instance FromJSON Response where
1502− parseJSON = sopSwaggerGenericParseJSON
1503−
1504−instance FromJSON Operation where
1505− parseJSON = sopSwaggerGenericParseJSON
1506−
1507−instance FromJSON PathItem where
1508− parseJSON = sopSwaggerGenericParseJSON
1509−
1510−instance FromJSON SecurityDefinitions where
1511− parseJSON js = SecurityDefinitions <$> parseJSON js
1512−
1513−instance FromJSON RequestBody where
1514− parseJSON = sopSwaggerGenericParseJSON
1515−
1516−instance FromJSON MediaTypeObject where
1517− parseJSON = sopSwaggerGenericParseJSON
1518−
1519−instance FromJSON Encoding where
1520− parseJSON = sopSwaggerGenericParseJSON
1521−
1522−instance FromJSON Link where
1523− parseJSON = sopSwaggerGenericParseJSON
1524−
1525−instance FromJSON Reference where
1526− parseJSON (Object o) = Reference <$> o .: "$ref"
1527− parseJSON _ = empty
1528−
1529−referencedParseJSON :: FromJSON a => Text -> Value -> JSON.Parser (Referenced a)
1530−referencedParseJSON prefix js@(Object o) = do
1531− ms <- o .:? "$ref"
1532− case ms of
1533− Nothing -> Inline <$> parseJSON js
1534− Just s -> Ref <$> parseRef s
1535− where
1536− parseRef s = do
1537− case Text.stripPrefix prefix s of
1538− Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s
1539− Just suffix -> pure (Reference suffix)
1540−referencedParseJSON _ _ = fail "referenceParseJSON: not an object"
1541−
1542−instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/components/schemas/"
1543−instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/components/parameters/"
1544−instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/components/responses/"
1545−instance FromJSON (Referenced RequestBody) where parseJSON = referencedParseJSON "#/components/requestBodies/"
1546−instance FromJSON (Referenced Example) where parseJSON = referencedParseJSON "#/components/examples/"
1547−instance FromJSON (Referenced Header) where parseJSON = referencedParseJSON "#/components/headers/"
1548−instance FromJSON (Referenced Link) where parseJSON = referencedParseJSON "#/components/links/"
1549−instance FromJSON (Referenced Callback) where parseJSON = referencedParseJSON "#/components/callbacks/"
1550−
1551−instance FromJSON Xml where
1552− parseJSON = genericParseJSON (jsonPrefix "xml")
1553−
1554−instance FromJSON AdditionalProperties where
1555− parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b
1556− parseJSON js = AdditionalPropertiesSchema <$> parseJSON js
1557−
1558−-- | All strings are parsed as expressions
1559−instance FromJSON ExpressionOrValue where
1560− parseJSON (String expr) = pure $ Expression expr
1561− parseJSON v = pure $ Value v
1562−
1563−instance FromJSON Callback where
1564− parseJSON = fmap Callback . parseJSON
1565−
1566−instance HasSwaggerAesonOptions Server where
1567− swaggerAesonOptions _ = mkSwaggerAesonOptions "server"
1568−instance HasSwaggerAesonOptions Components where
1569− swaggerAesonOptions _ = mkSwaggerAesonOptions "components"
1570−instance HasSwaggerAesonOptions Header where
1571− swaggerAesonOptions _ = mkSwaggerAesonOptions "header"
1572−instance AesonDefaultValue p => HasSwaggerAesonOptions (OAuth2Flow p) where
1573− swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "params"
1574−instance HasSwaggerAesonOptions OAuth2Flows where
1575− swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2Flows"
1576−instance HasSwaggerAesonOptions Operation where
1577− swaggerAesonOptions _ = mkSwaggerAesonOptions "operation"
1578−instance HasSwaggerAesonOptions Param where
1579− swaggerAesonOptions _ = mkSwaggerAesonOptions "param"
1580−instance HasSwaggerAesonOptions PathItem where
1581− swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem"
1582−instance HasSwaggerAesonOptions Response where
1583− swaggerAesonOptions _ = mkSwaggerAesonOptions "response"
1584−instance HasSwaggerAesonOptions RequestBody where
1585− swaggerAesonOptions _ = mkSwaggerAesonOptions "requestBody"
1586−instance HasSwaggerAesonOptions MediaTypeObject where
1587− swaggerAesonOptions _ = mkSwaggerAesonOptions "mediaTypeObject"
1588−instance HasSwaggerAesonOptions Responses where
1589− swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses"
1590−instance HasSwaggerAesonOptions SecurityScheme where
1591− swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type"
1592−instance HasSwaggerAesonOptions Schema where
1593− swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema"
1594−instance HasSwaggerAesonOptions OpenApi where
1595− swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("openapi", "3.0.0")]
1596−instance HasSwaggerAesonOptions Example where
1597− swaggerAesonOptions _ = mkSwaggerAesonOptions "example"
1598−instance HasSwaggerAesonOptions Encoding where
1599− swaggerAesonOptions _ = mkSwaggerAesonOptions "encoding"
1600−
1601−instance HasSwaggerAesonOptions Link where
1602− swaggerAesonOptions _ = mkSwaggerAesonOptions "link"
1603−
1604−instance AesonDefaultValue Server
1605−instance AesonDefaultValue Components
1606−instance AesonDefaultValue OAuth2ImplicitFlow
1607−instance AesonDefaultValue OAuth2PasswordFlow
1608−instance AesonDefaultValue OAuth2ClientCredentialsFlow
1609−instance AesonDefaultValue OAuth2AuthorizationCodeFlow
1610−instance AesonDefaultValue p => AesonDefaultValue (OAuth2Flow p)
1611−instance AesonDefaultValue Responses
1612−instance AesonDefaultValue SecuritySchemeType
1613−instance AesonDefaultValue OpenApiType
1614−instance AesonDefaultValue MimeList where defaultValue = Just mempty
1615−instance AesonDefaultValue Info
1616−instance AesonDefaultValue ParamLocation
1617−instance AesonDefaultValue Link
1618−instance AesonDefaultValue SecurityDefinitions where
1619− defaultValue = Just mempty
src/Data/OpenApi/Internal/AesonUtils.hsdeleted−313
@@ -1,313 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE ExplicitForAll #-}
6−{-# LANGUAGE TemplateHaskell #-}
7−{-# LANGUAGE UndecidableSuperClasses #-}
8−module Data.OpenApi.Internal.AesonUtils (
9− -- * Generic functions
10− AesonDefaultValue(..),
11− sopSwaggerGenericToJSON,
12− sopSwaggerGenericToEncoding,
13− sopSwaggerGenericToJSONWithOpts,
14− sopSwaggerGenericParseJSON,
15− -- * Options
16− HasSwaggerAesonOptions(..),
17− SwaggerAesonOptions,
18− mkSwaggerAesonOptions,
19− saoPrefix,
20− saoAdditionalPairs,
21− saoSubObject,
22− ) where
23−
24−import Prelude ()
25−import Prelude.Compat
26−
27−import Control.Applicative ((<|>))
28−import Control.Lens (makeLenses, (^.))
29−import Control.Monad (unless)
30−import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject, Encoding, pairs, (.=), Series)
31−import Data.Aeson.Types (Parser, Pair)
32−import Data.Char (toLower, isUpper)
33−import Data.Foldable (traverse_)
34−import Data.Text (Text)
35−
36−import Generics.SOP
37−
38−import qualified Data.Text as T
39−import qualified Data.Set as Set
40−import qualified Data.HashMap.Strict.InsOrd as InsOrd
41−import qualified Data.HashSet.InsOrd as InsOrdHS
42−
43−import Data.OpenApi.Aeson.Compat (keyToString, objectToList, stringToKey)
44−
45−-------------------------------------------------------------------------------
46−-- SwaggerAesonOptions
47−-------------------------------------------------------------------------------
48−
49−data SwaggerAesonOptions = SwaggerAesonOptions
50− { _saoPrefix :: String
51− , _saoAdditionalPairs :: [Pair]
52− , _saoSubObject :: Maybe String
53− }
54−
55−mkSwaggerAesonOptions
56− :: String -- ^ prefix
57− -> SwaggerAesonOptions
58−mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing
59−
60−makeLenses ''SwaggerAesonOptions
61−
62−class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
63− swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions
64−
65− -- So far we use only default definitions
66− aesonDefaults :: Proxy a -> POP Maybe (Code a)
67− aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
68−
69−-------------------------------------------------------------------------------
70−-- Generics
71−-------------------------------------------------------------------------------
72−
73−class AesonDefaultValue a where
74− defaultValue :: Maybe a
75− defaultValue = Nothing
76−
77−instance AesonDefaultValue Text where defaultValue = Nothing
78−instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
79−instance AesonDefaultValue [a] where defaultValue = Just []
80−instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
81−instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty
82−instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
83−
84−-------------------------------------------------------------------------------
85−-- ToJSON
86−-------------------------------------------------------------------------------
87−
88−-- | Generic serialisation for swagger records.
89−--
90−-- Features
91−--
92−-- * omits nulls, empty objects and empty arrays (configurable)
93−-- * possible to add fields
94−-- * possible to merge sub-object
95−sopSwaggerGenericToJSON
96− :: forall a xs.
97− ( HasDatatypeInfo a
98− , HasSwaggerAesonOptions a
99− , All2 ToJSON (Code a)
100− , All2 Eq (Code a)
101− , Code a ~ '[xs]
102− )
103− => a
104− -> Value
105−sopSwaggerGenericToJSON x =
106− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
107− in object (opts ^. saoAdditionalPairs ++ ps)
108− where
109− proxy = Proxy :: Proxy a
110− opts = swaggerAesonOptions proxy
111−
112−-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)
113−--
114−-- Also uses default `aesonDefaults`
115−sopSwaggerGenericToJSONWithOpts
116− :: forall a xs.
117− ( Generic a
118− , All2 AesonDefaultValue (Code a)
119− , HasDatatypeInfo a
120− , All2 ToJSON (Code a)
121− , All2 Eq (Code a)
122− , Code a ~ '[xs]
123− )
124− => SwaggerAesonOptions
125− -> a
126− -> Value
127−sopSwaggerGenericToJSONWithOpts opts x =
128− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs
129− in object (opts ^. saoAdditionalPairs ++ ps)
130− where
131− proxy = Proxy :: Proxy a
132− defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
133−
134−sopSwaggerGenericToJSON'
135− :: (All2 ToJSON '[xs], All2 Eq '[xs])
136− => SwaggerAesonOptions
137− -> SOP I '[xs]
138− -> DatatypeInfo '[xs]
139− -> POP Maybe '[xs]
140− -> [Pair]
141−sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
142− sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
143−sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
144−
145−sopSwaggerGenericToJSON''
146− :: (All ToJSON xs, All Eq xs)
147− => SwaggerAesonOptions
148− -> NP I xs
149− -> NP FieldInfo xs
150− -> NP Maybe xs
151− -> [Pair]
152−sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
153− where
154− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
155− go Nil Nil Nil = []
156− go (I x :* xs) (FieldInfo name :* names) (def :* defs)
157− | Just name' == sub = case json of
158− Object m -> objectToList m ++ rest
159− Null -> rest
160− _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
161− -- If default value: omit it.
162− | Just x == def =
163− rest
164− | otherwise =
165− (stringToKey name', json) : rest
166− where
167− json = toJSON x
168− name' = fieldNameModifier name
169− rest = go xs names defs
170−
171− fieldNameModifier = modifier . drop 1
172− modifier = lowerFirstUppers . drop (length prefix)
173− lowerFirstUppers s = map toLower x ++ y
174− where (x, y) = span isUpper s
175−
176−-------------------------------------------------------------------------------
177−-- FromJSON
178−-------------------------------------------------------------------------------
179−
180−sopSwaggerGenericParseJSON
181− :: forall a xs.
182− ( HasDatatypeInfo a
183− , HasSwaggerAesonOptions a
184− , All2 FromJSON (Code a)
185− , All2 Eq (Code a)
186− , Code a ~ '[xs]
187− )
188− => Value
189− -> Parser a
190−sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->
191− let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)
192− in do
193− traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs)
194− to <$> ps
195− where
196− proxy = Proxy :: Proxy a
197− opts = swaggerAesonOptions proxy
198−
199− parseAdditionalField :: Object -> Pair -> Parser ()
200− parseAdditionalField obj (k, v) = do
201− v' <- obj .: k
202− unless (v == v') $ fail $
203− "Additonal field don't match for key " ++ keyToString k
204− ++ ": " ++ show v
205− ++ " /= " ++ show v'
206−
207−sopSwaggerGenericParseJSON'
208− :: (All2 FromJSON '[xs], All2 Eq '[xs])
209− => SwaggerAesonOptions
210− -> Object
211− -> DatatypeInfo '[xs]
212− -> POP Maybe '[xs]
213− -> Parser (SOP I '[xs])
214−sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
215− SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
216−sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
217−
218−sopSwaggerGenericParseJSON''
219− :: (All FromJSON xs, All Eq xs)
220− => SwaggerAesonOptions
221− -> Object
222− -> NP FieldInfo xs
223− -> NP Maybe xs
224− -> Parser (NP I xs)
225−sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
226− where
227− go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
228− go Nil Nil = pure Nil
229− go (FieldInfo name :* names) (def :* defs)
230− | Just name' == sub =
231− -- Note: we might strip fields of outer structure.
232− cons <$> (withDef $ parseJSON $ Object obj) <*> rest
233− | otherwise = case def of
234− Just def' -> cons <$> obj .:? stringToKey name' .!= def' <*> rest
235− Nothing -> cons <$> obj .: stringToKey name' <*> rest
236− where
237− cons h t = I h :* t
238− name' = fieldNameModifier name
239− rest = go names defs
240−
241− withDef = case def of
242− Just def' -> (<|> pure def')
243− Nothing -> id
244−
245− fieldNameModifier = modifier . drop 1
246− modifier = lowerFirstUppers . drop (length prefix)
247− lowerFirstUppers s = map toLower x ++ y
248− where (x, y) = span isUpper s
249−
250−-------------------------------------------------------------------------------
251−-- ToEncoding
252−-------------------------------------------------------------------------------
253−
254−sopSwaggerGenericToEncoding
255− :: forall a xs.
256− ( HasDatatypeInfo a
257− , HasSwaggerAesonOptions a
258− , All2 ToJSON (Code a)
259− , All2 Eq (Code a)
260− , Code a ~ '[xs]
261− )
262− => a
263− -> Encoding
264−sopSwaggerGenericToEncoding x =
265− let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
266− in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)
267− where
268− proxy = Proxy :: Proxy a
269− opts = swaggerAesonOptions proxy
270−
271−pairsToSeries :: [Pair] -> Series
272−pairsToSeries = foldMap (\(k, v) -> (k .= v))
273−
274−sopSwaggerGenericToEncoding'
275− :: (All2 ToJSON '[xs], All2 Eq '[xs])
276− => SwaggerAesonOptions
277− -> SOP I '[xs]
278− -> DatatypeInfo '[xs]
279− -> POP Maybe '[xs]
280− -> Series
281−sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
282− sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
283−sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
284−
285−sopSwaggerGenericToEncoding''
286− :: (All ToJSON xs, All Eq xs)
287− => SwaggerAesonOptions
288− -> NP I xs
289− -> NP FieldInfo xs
290− -> NP Maybe xs
291− -> Series
292−sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go
293− where
294− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
295− go Nil Nil Nil = mempty
296− go (I x :* xs) (FieldInfo name :* names) (def :* defs)
297− | Just name' == sub = case toJSON x of
298− Object m -> pairsToSeries (objectToList m) <> rest
299− Null -> rest
300− _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)
301− -- If default value: omit it.
302− | Just x == def =
303− rest
304− | otherwise =
305− (stringToKey name' .= x) <> rest
306− where
307− name' = fieldNameModifier name
308− rest = go xs names defs
309−
310− fieldNameModifier = modifier . drop 1
311− modifier = lowerFirstUppers . drop (length prefix)
312− lowerFirstUppers s = map toLower x ++ y
313− where (x, y) = span isUpper s
src/Data/OpenApi/Internal/Schema.hsdeleted−1126
@@ -1,1126 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DefaultSignatures #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE KindSignatures #-}
8−{-# LANGUAGE OverloadedLists #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PackageImports #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TupleSections #-}
14−{-# LANGUAGE TypeApplications #-}
15−{-# LANGUAGE TypeFamilies #-}
16−{-# LANGUAGE TypeOperators #-}
17−{-# LANGUAGE TypeSynonymInstances #-}
18−{-# LANGUAGE UndecidableInstances #-}
19−{-# OPTIONS_GHC -Wno-redundant-constraints #-}
20−-- For TypeErrors
21−{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
22−module Data.OpenApi.Internal.Schema where
23−
24−import Prelude ()
25−import Prelude.Compat
26−
27−import Control.Lens hiding (allOf)
28−import Data.Data.Lens (template)
29−
30−import Control.Monad
31−import Control.Monad.Writer
32−import Data.Aeson (Object (..), SumEncoding (..), ToJSON (..), ToJSONKey (..),
33− ToJSONKeyFunction (..), Value (..))
34−import Data.Char
35−import Data.Data (Data)
36−import Data.Foldable (traverse_)
37−import Data.HashMap.Strict (HashMap)
38−import qualified Data.HashMap.Strict as HashMap
39−import "unordered-containers" Data.HashSet (HashSet)
40−import qualified "unordered-containers" Data.HashSet as HashSet
41−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
42−import Data.Int
43−import Data.IntSet (IntSet)
44−import Data.IntMap (IntMap)
45−import Data.List (sort)
46−import Data.List.NonEmpty.Compat (NonEmpty)
47−import Data.Map (Map)
48−import Data.Maybe (fromMaybe)
49−import Data.Proxy
50−import Data.Scientific (Scientific)
51−import Data.Fixed (Fixed, HasResolution, Pico)
52−import Data.Set (Set)
53−import qualified Data.Text as T
54−import qualified Data.Text.Lazy as TL
55−import Data.Time
56−import qualified Data.Vector as V
57−import qualified Data.Vector.Primitive as VP
58−import qualified Data.Vector.Storable as VS
59−import qualified Data.Vector.Unboxed as VU
60−import Data.Version (Version)
61−import Numeric.Natural.Compat (Natural)
62−import Data.Word
63−import GHC.Generics
64−import qualified Data.UUID.Types as UUID
65−import Type.Reflection (Typeable, typeRep)
66−
67−import Data.OpenApi.Aeson.Compat (keyToText, objectKeys, toInsOrdHashMap)
68−import Data.OpenApi.Declare
69−import Data.OpenApi.Internal
70−import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..))
71−import Data.OpenApi.Internal.TypeShape
72−import Data.OpenApi.Lens hiding (name, schema)
73−import qualified Data.OpenApi.Lens as Swagger
74−import Data.OpenApi.SchemaOptions
75−
76−import qualified Data.ByteString as BS
77−import qualified Data.ByteString.Lazy.Char8 as BSL
78−import GHC.TypeLits (TypeError, ErrorMessage(..))
79−
80−unnamed :: Schema -> NamedSchema
81−unnamed schema = NamedSchema Nothing schema
82−
83−named :: T.Text -> Schema -> NamedSchema
84−named name schema = NamedSchema (Just name) schema
85−
86−plain :: Schema -> Declare (Definitions Schema) NamedSchema
87−plain = pure . unnamed
88−
89−unname :: NamedSchema -> NamedSchema
90−unname (NamedSchema _ schema) = unnamed schema
91−
92−rename :: Maybe T.Text -> NamedSchema -> NamedSchema
93−rename name (NamedSchema _ schema) = NamedSchema name schema
94−
95−-- | Convert a type into @'Schema'@.
96−--
97−-- An example type and instance:
98−--
99−-- @
100−-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
101−-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
102−--
103−-- import Control.Lens
104−-- import Data.Proxy
105−-- import Data.OpenApi
106−--
107−-- data Coord = Coord { x :: Double, y :: Double }
108−--
109−-- instance ToSchema Coord where
110−-- declareNamedSchema _ = do
111−-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
112−-- return $ NamedSchema (Just \"Coord\") $ mempty
113−-- & type_ ?~ OpenApiObject
114−-- & properties .~
115−-- [ (\"x\", doubleSchema)
116−-- , (\"y\", doubleSchema)
117−-- ]
118−-- & required .~ [ \"x\", \"y\" ]
119−-- @
120−--
121−-- Instead of manually writing your @'ToSchema'@ instance you can
122−-- use a default generic implementation of @'declareNamedSchema'@.
123−--
124−-- To do that, simply add @deriving 'Generic'@ clause to your datatype
125−-- and declare a @'ToSchema'@ instance for your datatype without
126−-- giving definition for @'declareNamedSchema'@.
127−--
128−-- For instance, the previous example can be simplified into this:
129−--
130−-- @
131−-- {-\# LANGUAGE DeriveGeneric \#-}
132−--
133−-- import GHC.Generics (Generic)
134−--
135−-- data Coord = Coord { x :: Double, y :: Double } deriving Generic
136−--
137−-- instance ToSchema Coord
138−-- @
139−class Typeable a => ToSchema a where
140− -- | Convert a type into an optionally named schema
141− -- together with all used definitions.
142− -- Note that the schema itself is included in definitions
143− -- only if it is recursive (and thus needs its definition in scope).
144− declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
145− default declareNamedSchema :: (Generic a, GToSchema (Rep a)) =>
146− Proxy a -> Declare (Definitions Schema) NamedSchema
147− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
148−
149−instance ToSchema TimeOfDay where
150− declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
151− & example ?~ toJSON (TimeOfDay 12 33 15)
152−
153−-- | Convert a type into a schema and declare all used schema definitions.
154−declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
155−declareSchema = fmap _namedSchemaSchema . declareNamedSchema
156−
157−-- | Convert a type into an optionally named schema.
158−--
159−-- >>> toNamedSchema (Proxy :: Proxy String) ^. name
160−-- Nothing
161−-- >>> BSL.putStrLn $ encodePretty (toNamedSchema (Proxy :: Proxy String) ^. schema)
162−-- {
163−-- "type": "string"
164−-- }
165−--
166−-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
167−-- Just "Day"
168−-- >>> BSL.putStrLn $ encodePretty (toNamedSchema (Proxy :: Proxy Day) ^. schema)
169−-- {
170−-- "example": "2016-07-22",
171−-- "format": "date",
172−-- "type": "string"
173−-- }
174−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
175−toNamedSchema = undeclare . declareNamedSchema
176−
177−-- | Get type's schema name according to its @'ToSchema'@ instance.
178−--
179−-- >>> schemaName (Proxy :: Proxy Int)
180−-- Nothing
181−--
182−-- >>> schemaName (Proxy :: Proxy UTCTime)
183−-- Just "UTCTime"
184−schemaName :: ToSchema a => Proxy a -> Maybe T.Text
185−schemaName = _namedSchemaName . toNamedSchema
186−
187−-- | Convert a type into a schema.
188−--
189−-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy Int8)
190−-- {
191−-- "maximum": 127,
192−-- "minimum": -128,
193−-- "type": "integer"
194−-- }
195−--
196−-- >>> BSL.putStrLn $ encodePretty $ toSchema (Proxy :: Proxy [Day])
197−-- {
198−-- "items": {
199−-- "$ref": "#/components/schemas/Day"
200−-- },
201−-- "type": "array"
202−-- }
203−toSchema :: ToSchema a => Proxy a -> Schema
204−toSchema = _namedSchemaSchema . toNamedSchema
205−
206−-- | Convert a type into a referenced schema if possible.
207−-- Only named schemas can be referenced, nameless schemas are inlined.
208−--
209−-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Integer)
210−-- {
211−-- "type": "integer"
212−-- }
213−--
214−-- >>> BSL.putStrLn $ encodePretty $ toSchemaRef (Proxy :: Proxy Day)
215−-- {
216−-- "$ref": "#/components/schemas/Day"
217−-- }
218−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
219−toSchemaRef = undeclare . declareSchemaRef
220−
221−-- | Convert a type into a referenced schema if possible
222−-- and declare all used schema definitions.
223−-- Only named schemas can be referenced, nameless schemas are inlined.
224−--
225−-- Schema definitions are typically declared for every referenced schema.
226−-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
227−-- will be declared (regardless of whether it is recusive or not).
228−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
229−declareSchemaRef proxy = do
230− case toNamedSchema proxy of
231− NamedSchema (Just name) schema -> do
232− -- This check is very important as it allows generically
233− -- derive used definitions for recursive schemas.
234− -- Lazy Declare monad allows toNamedSchema to ignore
235− -- any declarations (which would otherwise loop) and
236− -- retrieve the schema and its name to check if we
237− -- have already declared it.
238− -- If we have, we don't need to declare anything for
239− -- this schema this time and thus simply return the reference.
240− known <- looks (InsOrdHashMap.member name)
241− when (not known) $ do
242− declare [(name, schema)]
243− void $ declareNamedSchema proxy
244− return $ Ref (Reference name)
245− _ -> Inline <$> declareSchema proxy
246−
247−-- | Inline any referenced schema if its name satisfies given predicate.
248−--
249−-- /NOTE:/ if a referenced schema is not found in definitions the predicate is ignored
250−-- and schema stays referenced.
251−--
252−-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas
253−-- when inlining recursive schemas.
254−inlineSchemasWhen :: Data s => (T.Text -> Bool) -> (Definitions Schema) -> s -> s
255−inlineSchemasWhen p defs = template %~ deref
256− where
257− deref r@(Ref (Reference name))
258− | p name =
259− case InsOrdHashMap.lookup name defs of
260− Just schema -> Inline (inlineSchemasWhen p defs schema)
261− Nothing -> r
262− | otherwise = r
263− deref (Inline schema) = Inline (inlineSchemasWhen p defs schema)
264−
265−-- | Inline any referenced schema if its name is in the given list.
266−--
267−-- /NOTE:/ if a referenced schema is not found in definitions
268−-- it stays referenced even if it appears in the list of names.
269−--
270−-- __WARNING:__ @'inlineSchemas'@ will produce infinite schemas
271−-- when inlining recursive schemas.
272−inlineSchemas :: Data s => [T.Text] -> (Definitions Schema) -> s -> s
273−inlineSchemas names = inlineSchemasWhen (`elem` names)
274−
275−-- | Inline all schema references for which the definition
276−-- can be found in @'Definitions'@.
277−--
278−-- __WARNING:__ @'inlineAllSchemas'@ will produce infinite schemas
279−-- when inlining recursive schemas.
280−inlineAllSchemas :: Data s => (Definitions Schema) -> s -> s
281−inlineAllSchemas = inlineSchemasWhen (const True)
282−
283−-- | Convert a type into a schema without references.
284−--
285−-- >>> BSL.putStrLn $ encodePretty $ toInlinedSchema (Proxy :: Proxy [Day])
286−-- {
287−-- "items": {
288−-- "example": "2016-07-22",
289−-- "format": "date",
290−-- "type": "string"
291−-- },
292−-- "type": "array"
293−-- }
294−--
295−-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
296−-- when inlining recursive schemas.
297−toInlinedSchema :: ToSchema a => Proxy a -> Schema
298−toInlinedSchema proxy = inlineAllSchemas defs schema
299− where
300− (defs, schema) = runDeclare (declareSchema proxy) mempty
301−
302−-- | Inline all /non-recursive/ schemas for which the definition
303−-- can be found in @'Definitions'@.
304−inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
305−inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
306− where
307− nonRecursive name =
308− case InsOrdHashMap.lookup name defs of
309− Just schema -> name `notElem` execDeclare (usedNames schema) mempty
310− Nothing -> False
311−
312− usedNames schema = traverse_ schemaRefNames (schema ^.. template)
313−
314− schemaRefNames :: Referenced Schema -> Declare [T.Text] ()
315− schemaRefNames ref = case ref of
316− Ref (Reference name) -> do
317− seen <- looks (name `elem`)
318− when (not seen) $ do
319− declare [name]
320− traverse_ usedNames (InsOrdHashMap.lookup name defs)
321− Inline subschema -> usedNames subschema
322−
323−-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
324−-- Produced schema can be used for further refinement.
325−--
326−-- >>> BSL.putStrLn $ encodePretty $ sketchSchema "hello"
327−-- {
328−-- "example": "hello",
329−-- "type": "string"
330−-- }
331−--
332−-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (1, 2, 3)
333−-- {
334−-- "example": [
335−-- 1,
336−-- 2,
337−-- 3
338−-- ],
339−-- "items": {
340−-- "type": "number"
341−-- },
342−-- "type": "array"
343−-- }
344−--
345−-- >>> BSL.putStrLn $ encodePretty $ sketchSchema ("Jack", 25)
346−-- {
347−-- "example": [
348−-- "Jack",
349−-- 25
350−-- ],
351−-- "items": [
352−-- {
353−-- "type": "string"
354−-- },
355−-- {
356−-- "type": "number"
357−-- }
358−-- ],
359−-- "type": "array"
360−-- }
361−--
362−-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
363−-- >>> instance ToJSON Person
364−-- >>> BSL.putStrLn $ encodePretty $ sketchSchema (Person "Jack" 25)
365−-- {
366−-- "example": {
367−-- "age": 25,
368−-- "name": "Jack"
369−-- },
370−-- "properties": {
371−-- "age": {
372−-- "type": "number"
373−-- },
374−-- "name": {
375−-- "type": "string"
376−-- }
377−-- },
378−-- "required": [
379−-- "age",
380−-- "name"
381−-- ],
382−-- "type": "object"
383−-- }
384−sketchSchema :: ToJSON a => a -> Schema
385−sketchSchema = sketch . toJSON
386− where
387− sketch Null = go Null
388− sketch js@(Bool _) = go js
389− sketch js = go js & example ?~ js
390−
391− go Null = mempty & type_ ?~ OpenApiNull
392− go (Bool _) = mempty & type_ ?~ OpenApiBoolean
393− go (String _) = mempty & type_ ?~ OpenApiString
394− go (Number _) = mempty & type_ ?~ OpenApiNumber
395− go (Array xs) = mempty
396− & type_ ?~ OpenApiArray
397− & items ?~ case ischema of
398− Just s -> OpenApiItemsObject (Inline s)
399− _ -> OpenApiItemsArray (map Inline ys)
400− where
401− ys = map go (V.toList xs)
402− allSame = and ((zipWith (==)) ys (tail ys))
403−
404− ischema = case ys of
405− (z:_) | allSame -> Just z
406− _ -> Nothing
407− go (Object o) = mempty
408− & type_ ?~ OpenApiObject
409− & required .~ sort (objectKeys o)
410− & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
411−
412−-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
413−-- Produced schema uses as much constraints as possible.
414−--
415−-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema "hello"
416−-- {
417−-- "enum": [
418−-- "hello"
419−-- ],
420−-- "maxLength": 5,
421−-- "minLength": 5,
422−-- "pattern": "hello",
423−-- "type": "string"
424−-- }
425−--
426−-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema (1, 2, 3)
427−-- {
428−-- "enum": [
429−-- [
430−-- 1,
431−-- 2,
432−-- 3
433−-- ]
434−-- ],
435−-- "items": [
436−-- {
437−-- "enum": [
438−-- 1
439−-- ],
440−-- "maximum": 1,
441−-- "minimum": 1,
442−-- "multipleOf": 1,
443−-- "type": "number"
444−-- },
445−-- {
446−-- "enum": [
447−-- 2
448−-- ],
449−-- "maximum": 2,
450−-- "minimum": 2,
451−-- "multipleOf": 2,
452−-- "type": "number"
453−-- },
454−-- {
455−-- "enum": [
456−-- 3
457−-- ],
458−-- "maximum": 3,
459−-- "minimum": 3,
460−-- "multipleOf": 3,
461−-- "type": "number"
462−-- }
463−-- ],
464−-- "maxItems": 3,
465−-- "minItems": 3,
466−-- "type": "array",
467−-- "uniqueItems": true
468−-- }
469−--
470−-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema ("Jack", 25)
471−-- {
472−-- "enum": [
473−-- [
474−-- "Jack",
475−-- 25
476−-- ]
477−-- ],
478−-- "items": [
479−-- {
480−-- "enum": [
481−-- "Jack"
482−-- ],
483−-- "maxLength": 4,
484−-- "minLength": 4,
485−-- "pattern": "Jack",
486−-- "type": "string"
487−-- },
488−-- {
489−-- "enum": [
490−-- 25
491−-- ],
492−-- "maximum": 25,
493−-- "minimum": 25,
494−-- "multipleOf": 25,
495−-- "type": "number"
496−-- }
497−-- ],
498−-- "maxItems": 2,
499−-- "minItems": 2,
500−-- "type": "array",
501−-- "uniqueItems": true
502−-- }
503−--
504−-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
505−-- >>> instance ToJSON Person
506−-- >>> BSL.putStrLn $ encodePretty $ sketchStrictSchema (Person "Jack" 25)
507−-- {
508−-- "enum": [
509−-- {
510−-- "age": 25,
511−-- "name": "Jack"
512−-- }
513−-- ],
514−-- "maxProperties": 2,
515−-- "minProperties": 2,
516−-- "properties": {
517−-- "age": {
518−-- "enum": [
519−-- 25
520−-- ],
521−-- "maximum": 25,
522−-- "minimum": 25,
523−-- "multipleOf": 25,
524−-- "type": "number"
525−-- },
526−-- "name": {
527−-- "enum": [
528−-- "Jack"
529−-- ],
530−-- "maxLength": 4,
531−-- "minLength": 4,
532−-- "pattern": "Jack",
533−-- "type": "string"
534−-- }
535−-- },
536−-- "required": [
537−-- "age",
538−-- "name"
539−-- ],
540−-- "type": "object"
541−-- }
542−sketchStrictSchema :: ToJSON a => a -> Schema
543−sketchStrictSchema = go . toJSON
544− where
545− go Null = mempty & type_ ?~ OpenApiNull
546− go js@(Bool _) = mempty
547− & type_ ?~ OpenApiBoolean
548− & enum_ ?~ [js]
549− go js@(String s) = mempty
550− & type_ ?~ OpenApiString
551− & maxLength ?~ fromIntegral (T.length s)
552− & minLength ?~ fromIntegral (T.length s)
553− & pattern ?~ s
554− & enum_ ?~ [js]
555− go js@(Number n) = mempty
556− & type_ ?~ OpenApiNumber
557− & maximum_ ?~ n
558− & minimum_ ?~ n
559− & multipleOf ?~ n
560− & enum_ ?~ [js]
561− go js@(Array xs) = mempty
562− & type_ ?~ OpenApiArray
563− & maxItems ?~ fromIntegral sz
564− & minItems ?~ fromIntegral sz
565− & items ?~ OpenApiItemsArray (map (Inline . go) (V.toList xs))
566− & uniqueItems ?~ allUnique
567− & enum_ ?~ [js]
568− where
569− sz = length xs
570− allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
571− go js@(Object o) = mempty
572− & type_ ?~ OpenApiObject
573− & required .~ sort names
574− & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
575− & maxProperties ?~ fromIntegral (length names)
576− & minProperties ?~ fromIntegral (length names)
577− & enum_ ?~ [js]
578− where
579− names = objectKeys o
580−
581−class GToSchema (f :: * -> *) where
582− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
583−
584−instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
585− declareNamedSchema _ = do
586− ref <- declareSchemaRef (Proxy :: Proxy a)
587− return $ unnamed $ mempty
588− & type_ ?~ OpenApiArray
589− & items ?~ OpenApiItemsObject ref
590−
591−instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
592−instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
593−instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
594−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
595−instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
596−instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
597−instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
598−instance ToSchema Int32 where declareNamedSchema = plain . paramSchemaToSchema
599−instance ToSchema Int64 where declareNamedSchema = plain . paramSchemaToSchema
600−instance ToSchema Word where declareNamedSchema = plain . paramSchemaToSchema
601−instance ToSchema Word8 where declareNamedSchema = plain . paramSchemaToSchema
602−instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
603−instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
604−instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
605−
606−instance ToSchema Char where
607− declareNamedSchema proxy = plain (paramSchemaToSchema proxy)
608− & mapped.Swagger.schema.example ?~ toJSON '?'
609−
610−instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
611−instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
612−instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
613−
614−instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
615−
616−instance ToSchema a => ToSchema (Maybe a) where
617− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
618−
619−instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where
620− -- To match Aeson instance
621− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField }
622−
623−instance ToSchema () where
624− declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
625−
626−-- | For 'ToJSON' instance, see <http://hackage.haskell.org/package/uuid-aeson uuid-aeson> package.
627−instance ToSchema UUID.UUID where
628− declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
629− & example ?~ toJSON (UUID.toText UUID.nil)
630−
631−instance (ToSchema a, ToSchema b) => ToSchema (a, b) where
632− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
633−instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where
634− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
635−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where
636− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
637−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where
638− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
639−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where
640− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
641−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) where
642− declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
643−
644−timeSchema :: T.Text -> Schema
645−timeSchema fmt = mempty
646− & type_ ?~ OpenApiString
647− & format ?~ fmt
648−
649−-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
650−instance ToSchema Day where
651− declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"
652− & example ?~ toJSON (fromGregorian 2016 7 22)
653−
654−-- |
655−-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
656−-- Just "yyyy-mm-ddThh:MM:ss"
657−instance ToSchema LocalTime where
658− declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
659− & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
660−
661−-- | Format @"date-time"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
662−instance ToSchema ZonedTime where
663− declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
664− & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
665−
666−instance ToSchema NominalDiffTime where
667− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
668−
669−-- |
670−-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
671−-- Just "yyyy-mm-ddThh:MM:ssZ"
672−instance ToSchema UTCTime where
673− declareNamedSchema _ = pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"
674− & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)
675−
676−instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
677−instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
678−
679−instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
680−
681−type family ToSchemaByteStringError bs where
682− ToSchemaByteStringError bs = TypeError
683− ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."
684− :$$: Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."
685− :$$: Text "Consider using byteSchema or binarySchema templates." )
686−
687−instance ToSchemaByteStringError BS.ByteString => ToSchema BS.ByteString where declareNamedSchema = error "impossible"
688−instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"
689−
690−instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
691−
692−-- | NOTE: This schema does not account for the uniqueness of keys.
693−instance (ToSchema a) => ToSchema (IntMap a) where
694− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
695−
696−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
697− declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of
698− ToJSONKeyText _ _ -> declareObjectMapSchema
699− ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])
700− where
701− declareObjectMapSchema = do
702− schema <- declareSchemaRef (Proxy :: Proxy v)
703− return $ unnamed $ mempty
704− & type_ ?~ OpenApiObject
705− & additionalProperties ?~ AdditionalPropertiesSchema schema
706−
707−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
708− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
709−
710−instance {-# OVERLAPPING #-} ToSchema Object where
711− declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
712− & type_ ?~ OpenApiObject
713− & description ?~ "Arbitrary JSON object."
714− & additionalProperties ?~ AdditionalPropertiesAllowed True
715−
716−instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
717−instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
718−instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
719−instance ToSchema a => ToSchema (VP.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
720−
721−instance ToSchema a => ToSchema (Set a) where
722− declareNamedSchema _ = do
723− schema <- declareSchema (Proxy :: Proxy [a])
724− return $ unnamed $ schema
725− & uniqueItems ?~ True
726−
727−instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
728−
729−-- | @since 2.2.1
730−instance ToSchema a => ToSchema (NonEmpty a) where
731− declareNamedSchema _ = do
732− schema <- declareSchema (Proxy :: Proxy [a])
733− return $ unnamed $ schema
734− & minItems .~ Just 1
735−
736−instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
737−instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
738−
739−instance ToSchema a => ToSchema (Sum a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
740−instance ToSchema a => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
741−instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
742−instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
743−instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
744−
745−instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
746−
747−-- | Default schema for @'Bounded'@, @'Integral'@ types.
748−--
749−-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
750−-- {
751−-- "maximum": 32767,
752−-- "minimum": -32768,
753−-- "type": "integer"
754−-- }
755−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
756−toSchemaBoundedIntegral _ = mempty
757− & type_ ?~ OpenApiInteger
758− & minimum_ ?~ fromInteger (toInteger (minBound :: a))
759− & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
760−
761−-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
762−genericToNamedSchemaBoundedIntegral :: forall a d f.
763− ( Bounded a, Integral a
764− , Generic a, Rep a ~ D1 d f, Datatype d)
765− => SchemaOptions -> Proxy a -> NamedSchema
766−genericToNamedSchemaBoundedIntegral opts proxy
767− = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
768−
769−-- | Declare a named schema for a @newtype@ wrapper.
770−genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
771− (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
772− => SchemaOptions -- ^ How to derive the name.
773− -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.
774− -> Proxy a
775− -> Declare (Definitions Schema) NamedSchema
776−genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
777−
778−-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
779−-- This makes a much more useful schema when there aren't many options for key values.
780−--
781−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
782−-- >>> instance ToJSON ButtonState
783−-- >>> instance ToSchema ButtonState
784−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
785−-- >>> type ImageUrl = T.Text
786−-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
787−-- {
788−-- "properties": {
789−-- "Active": {
790−-- "type": "string"
791−-- },
792−-- "Disabled": {
793−-- "type": "string"
794−-- },
795−-- "Focus": {
796−-- "type": "string"
797−-- },
798−-- "Hover": {
799−-- "type": "string"
800−-- },
801−-- "Neutral": {
802−-- "type": "string"
803−-- }
804−-- },
805−-- "type": "object"
806−-- }
807−--
808−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
809−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
810−declareSchemaBoundedEnumKeyMapping :: forall map key value.
811− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
812− => Proxy (map key value) -> Declare (Definitions Schema) Schema
813−declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
814− ToJSONKeyText getKey _ -> objectSchema getKey
815− ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
816− where
817− objectSchema getKey = do
818− valueRef <- declareSchemaRef (Proxy :: Proxy value)
819− let allKeys = [minBound..maxBound :: key]
820− mkPair k = (keyToText $ getKey k, valueRef)
821− return $ mempty
822− & type_ ?~ OpenApiObject
823− & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
824−
825−-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
826−-- This makes a much more useful schema when there aren't many options for key values.
827−--
828−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
829−-- >>> instance ToJSON ButtonState
830−-- >>> instance ToSchema ButtonState
831−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
832−-- >>> type ImageUrl = T.Text
833−-- >>> BSL.putStrLn $ encodePretty $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
834−-- {
835−-- "properties": {
836−-- "Active": {
837−-- "type": "string"
838−-- },
839−-- "Disabled": {
840−-- "type": "string"
841−-- },
842−-- "Focus": {
843−-- "type": "string"
844−-- },
845−-- "Hover": {
846−-- "type": "string"
847−-- },
848−-- "Neutral": {
849−-- "type": "string"
850−-- }
851−-- },
852−-- "type": "object"
853−-- }
854−--
855−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
856−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
857−toSchemaBoundedEnumKeyMapping :: forall map key value.
858− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
859− => Proxy (map key value) -> Schema
860−toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
861−
862−-- | A configurable generic @'Schema'@ creator.
863−genericDeclareSchema :: (Generic a, GToSchema (Rep a), Typeable a) =>
864− SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
865−genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
866−
867−-- | A configurable generic @'NamedSchema'@ creator.
868−-- This function applied to @'defaultSchemaOptions'@
869−-- is used as the default for @'declareNamedSchema'@
870−-- when the type is an instance of @'Generic'@.
871−--
872−-- Default implementation will use the name from 'Typeable' instance, including concrete
873−-- instantioations of type variables.
874−--
875−-- For example:
876−--
877−-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool))
878−-- Just "Either_Int_Bool"
879−genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) =>
880− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
881−genericDeclareNamedSchema opts _ =
882− rename (Just $ T.pack name) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
883− where
884− unspace ' ' = '_'
885− unspace x = x
886− orig = fmap unspace $ show $ typeRep @a
887− name = datatypeNameModifier opts orig
888−
889−
890−-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
891−genericNameSchema :: forall a d f.
892− (Generic a, Rep a ~ D1 d f, Datatype d)
893− => SchemaOptions -> Proxy a -> Schema -> NamedSchema
894−genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
895−
896−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
897−gdatatypeSchemaName opts _ = case orig of
898− (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
899− _ -> Nothing
900− where
901− orig = datatypeName (Proxy3 :: Proxy3 d f a)
902− name = datatypeNameModifier opts orig
903−
904−-- | Construct 'NamedSchema' usinng 'ToParamSchema'.
905−paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
906− SchemaOptions -> Proxy a -> NamedSchema
907−paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
908−
909−-- | Construct 'Schema' usinng 'ToParamSchema'.
910−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
911−paramSchemaToSchema = toParamSchema
912−
913−nullarySchema :: Schema
914−nullarySchema = mempty
915− & type_ ?~ OpenApiArray
916− & items ?~ OpenApiItemsArray []
917−
918−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
919−gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
920−
921−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
922−gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
923−
924−instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
925− gdeclareNamedSchema opts _ schema = do
926− NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema
927− gdeclareNamedSchema opts (Proxy :: Proxy g) gschema
928−
929−instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
930− gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
931− where
932− name = gdatatypeSchemaName opts (Proxy :: Proxy d)
933−
934−instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
935− gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)
936−
937−instance {-# OVERLAPPING #-} Constructor c => GToSchema (C1 c U1) where
938− gdeclareNamedSchema = gdeclareNamedSumSchema
939−
940−-- | Single field constructor.
941−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
942− gdeclareNamedSchema opts _ s
943− | unwrapUnaryRecords opts = fieldSchema
944− | otherwise =
945− case schema ^. items of
946− Just (OpenApiItemsArray [_]) -> fieldSchema
947− _ -> do
948− -- We have to run recordSchema instead of just using its defs,
949− -- since those can be recursive and will lead to infinite loop,
950− -- see https://github.com/biocad/openapi3/pull/37
951− NamedSchema _ schema' <- recordSchema
952− return (unnamed schema')
953− where
954− (_, NamedSchema _ schema) = runDeclare recordSchema mempty
955− recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
956− fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
957−
958−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
959−gdeclareSchemaRef opts proxy = do
960− case gtoNamedSchema opts proxy of
961− NamedSchema (Just name) schema -> do
962− -- This check is very important as it allows generically
963− -- derive used definitions for recursive schemas.
964− -- Lazy Declare monad allows toNamedSchema to ignore
965− -- any declarations (which would otherwise loop) and
966− -- retrieve the schema and its name to check if we
967− -- have already declared it.
968− -- If we have, we don't need to declare anything for
969− -- this schema this time and thus simply return the reference.
970− known <- looks (InsOrdHashMap.member name)
971− when (not known) $ do
972− declare [(name, schema)]
973− void $ gdeclareNamedSchema opts proxy mempty
974− return $ Ref (Reference name)
975− _ -> Inline <$> gdeclareSchema opts proxy
976−
977−appendItem :: Referenced Schema -> Maybe OpenApiItems -> Maybe OpenApiItems
978−appendItem x Nothing = Just (OpenApiItemsArray [x])
979−appendItem x (Just (OpenApiItemsArray xs)) = Just (OpenApiItemsArray (xs ++ [x]))
980−appendItem _ _ = error "GToSchema.appendItem: cannot append to OpenApiItemsObject"
981−
982−withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
983− SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
984−withFieldSchema opts _ isRequiredField schema = do
985− ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
986− return $
987− if T.null fname
988− then schema
989− & type_ ?~ OpenApiArray
990− & items %~ appendItem ref
991− & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
992− & minItems %~ Just . maybe 1 (+1) -- increment minItems
993− else schema
994− & type_ ?~ OpenApiObject
995− & properties . at fname ?~ ref
996− & if isRequiredField
997− then required %~ (++ [fname])
998− else id
999− where
1000− fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
1001−
1002−-- | Optional record fields.
1003−instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
1004− gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
1005−
1006−-- | Record fields.
1007−instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
1008− gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
1009−
1010−instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
1011− gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
1012−
1013−instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
1014− gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
1015−
1016−instance ( GSumToSchema f
1017− , GSumToSchema g
1018− ) => GToSchema (f :+: g)
1019− where
1020− -- Aeson does not unwrap unary record in sum types.
1021− gdeclareNamedSchema opts p s = gdeclareNamedSumSchema (opts { unwrapUnaryRecords = False } )p s
1022−
1023−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
1024−gdeclareNamedSumSchema opts proxy _
1025− | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchemas)
1026− | otherwise = do
1027− (schemas, _) <- runWriterT declareSumSchema
1028− return $ unnamed $ mempty
1029− & type_ ?~ OpenApiObject
1030− & oneOf ?~ (snd <$> schemas)
1031− where
1032− declareSumSchema = gsumToSchema opts proxy
1033− (sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema)
1034−
1035− toStringTag schemas = mempty
1036− & type_ ?~ OpenApiString
1037− & enum_ ?~ map (String . fst) sumSchemas
1038−
1039−type AllNullary = All
1040−
1041−class GSumToSchema (f :: * -> *) where
1042− gsumToSchema :: SchemaOptions -> Proxy f -> WriterT AllNullary (Declare (Definitions Schema)) [(T.Text, Referenced Schema)]
1043−
1044−instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
1045− gsumToSchema opts _ =
1046− (<>) <$> gsumToSchema opts (Proxy :: Proxy f) <*> gsumToSchema opts (Proxy :: Proxy g)
1047−
1048−-- | Convert one component of the sum to schema, to be later combined with @oneOf@.
1049−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
1050− Maybe (Referenced Schema) -> SchemaOptions -> Proxy (C1 c f) -> (T.Text, Referenced Schema)
1051−gsumConToSchemaWith ref opts _ = (tag, schema)
1052− where
1053− schema = case sumEncoding opts of
1054− TaggedObject tagField contentsField ->
1055− case ref of
1056− -- If subschema is an object and constructor is a record, we add tag directly
1057− -- to the record, as Aeson does it.
1058− Just (Inline sub) | sub ^. type_ == Just OpenApiObject && isRecord -> Inline $ sub
1059− & required <>~ [T.pack tagField]
1060− & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])
1061−
1062− -- If it is not a record, we need to put subschema into "contents" field.
1063− _ | not isRecord -> Inline $ mempty
1064− & type_ ?~ OpenApiObject
1065− & required .~ [T.pack tagField]
1066− & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])
1067− -- If constructor is nullary, there is no content.
1068− & case ref of
1069− Just r -> (properties . at (T.pack contentsField) ?~ r) . (required <>~ [T.pack contentsField])
1070− Nothing -> id
1071−
1072− -- In the remaining cases we combine "tag" object and "contents" object using allOf.
1073− _ -> Inline $ mempty
1074− & type_ ?~ OpenApiObject
1075− & allOf ?~ [Inline $ mempty
1076− & type_ ?~ OpenApiObject
1077− & required .~ (T.pack tagField : if isRecord then [] else [T.pack contentsField])
1078− & properties . at (T.pack tagField) ?~ (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag])]
1079− & if isRecord
1080− then allOf . _Just <>~ [refOrNullary]
1081− else allOf . _Just <>~ [Inline $ mempty & type_ ?~ OpenApiObject & properties . at (T.pack contentsField) ?~ refOrNullary]
1082− UntaggedValue -> refOrEnum -- Aeson encodes nullary constructors as strings in this case.
1083− ObjectWithSingleField -> Inline $ mempty
1084− & type_ ?~ OpenApiObject
1085− & required .~ [tag]
1086− & properties . at tag ?~ refOrNullary
1087− TwoElemArray -> error "unrepresentable in OpenAPI 3"
1088−
1089− tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
1090− isRecord = conIsRecord (Proxy3 :: Proxy3 c f p)
1091− refOrNullary = fromMaybe (Inline nullarySchema) ref
1092− refOrEnum = fromMaybe (Inline $ mempty & type_ ?~ OpenApiString & enum_ ?~ [String tag]) ref
1093−
1094−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
1095− SchemaOptions -> Proxy (C1 c f) -> Declare (Definitions Schema) [(T.Text, Referenced Schema)]
1096−gsumConToSchema opts proxy = do
1097− ref <- gdeclareSchemaRef opts proxy
1098− return [gsumConToSchemaWith (Just ref) opts proxy]
1099−
1100−instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
1101− gsumToSchema opts proxy = do
1102− tell (All False)
1103− lift $ gsumConToSchema opts proxy
1104−
1105−instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
1106− gsumToSchema opts proxy = do
1107− tell (All False)
1108− lift $ gsumConToSchema opts proxy
1109−
1110−instance Constructor c => GSumToSchema (C1 c U1) where
1111− gsumToSchema opts proxy = pure $ (:[]) $ gsumConToSchemaWith Nothing opts proxy
1112−
1113−data Proxy2 a b = Proxy2
1114−
1115−data Proxy3 a b c = Proxy3
1116−
1117−{- $setup
1118−>>> import Data.OpenApi
1119−>>> import Data.Aeson (encode)
1120−>>> import Data.Aeson.Types (toJSONKeyText)
1121−>>> import Data.OpenApi.Internal.Utils
1122−>>> :set -XScopedTypeVariables
1123−>>> :set -XDeriveAnyClass
1124−>>> :set -XStandaloneDeriving
1125−>>> :set -XTypeApplications
1126−-}
src/Data/OpenApi/Internal/Schema/Validation.hsdeleted−536
@@ -1,536 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DeriveFunctor #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9−{-# LANGUAGE LambdaCase #-}
10−{-# LANGUAGE MultiParamTypeClasses #-}
11−{-# LANGUAGE PackageImports #-}
12−{-# LANGUAGE RankNTypes #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TemplateHaskell #-}
15−{-# LANGUAGE UndecidableInstances #-}
16−{-# LANGUAGE ViewPatterns #-}
17−-- |
18−-- Module: Data.OpenApi.Internal.Schema.Validation
19−-- Copyright: (c) 2015 GetShopTV
20−-- License: BSD3
21−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
22−-- Stability: experimental
23−--
24−-- Validate JSON values with Swagger Schema.
25−module Data.OpenApi.Internal.Schema.Validation where
26−
27−import Prelude ()
28−import Prelude.Compat
29−
30−import Control.Applicative
31−import Control.Lens hiding (allOf)
32−import Control.Monad (forM, forM_, when)
33−
34−import Data.Aeson hiding (Result)
35−#if MIN_VERSION_aeson(2,0,0)
36−import qualified Data.Aeson.KeyMap as KeyMap
37−#endif
38−import Data.Foldable (for_, sequenceA_,
39− traverse_)
40−#if !MIN_VERSION_aeson(2,0,0)
41−import Data.HashMap.Strict (HashMap)
42−#endif
43−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
44−import qualified "unordered-containers" Data.HashSet as HashSet
45−import Data.Maybe (fromMaybe)
46−import Data.Proxy
47−import Data.Scientific (Scientific, isInteger)
48−import Data.Text (Text)
49−import qualified Data.Text as Text
50−import qualified Data.Text.Lazy as TL
51−import qualified Data.Text.Lazy.Encoding as TL
52−import Data.Vector (Vector)
53−import qualified Data.Vector as Vector
54−
55−import Data.OpenApi.Aeson.Compat (hasKey, keyToText, lookupKey, objectToList)
56−import Data.OpenApi.Declare
57−import Data.OpenApi.Internal
58−import Data.OpenApi.Internal.Schema
59−import Data.OpenApi.Internal.Utils
60−import Data.OpenApi.Lens
61−
62−-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
63−-- This can be used with QuickCheck to ensure those instances are coherent:
64−--
65−-- prop> validateToJSON (x :: Int) == []
66−--
67−-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
68−-- See @'validateToJSONWithPatternChecker'@.
69−--
70−-- See 'renderValidationErrors' on how the output is structured.
71−validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String
72−validatePrettyToJSON = renderValidationErrors validateToJSON
73−
74−-- | Variant of 'validatePrettyToJSON' with typed output.
75−validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
76−validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
77−
78−-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
79−-- This can be used with QuickCheck to ensure those instances are coherent.
80−--
81−-- For validation without patterns see @'validateToJSON'@. See also:
82−-- 'renderValidationErrors'.
83−validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]
84−validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON
85− where
86− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
87−
88−-- | Pretty print validation errors
89−-- together with actual JSON and Swagger Schema
90−-- (using 'encodePretty').
91−--
92−-- >>> import Data.Aeson as Aeson
93−-- >>> import Data.Foldable (traverse_)
94−-- >>> import GHC.Generics
95−-- >>> data Phone = Phone { value :: String } deriving (Generic)
96−-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)
97−-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]
98−-- >>> instance ToSchema Phone
99−-- >>> instance ToSchema Person
100−-- >>> let person = Person { name = "John", phone = Phone "123456" }
101−-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person
102−-- Validation against the schema fails:
103−-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
104−-- <BLANKLINE>
105−-- JSON value:
106−-- {
107−-- "name": "John"
108−-- }
109−-- <BLANKLINE>
110−-- Swagger Schema:
111−-- {
112−-- "properties": {
113−-- "name": {
114−-- "type": "string"
115−-- },
116−-- "phone": {
117−-- "$ref": "#/components/schemas/Phone"
118−-- }
119−-- },
120−-- "required": [
121−-- "name",
122−-- "phone"
123−-- ],
124−-- "type": "object"
125−-- }
126−-- <BLANKLINE>
127−-- Swagger Description Context:
128−-- {
129−-- "Phone": {
130−-- "properties": {
131−-- "value": {
132−-- "type": "string"
133−-- }
134−-- },
135−-- "required": [
136−-- "value"
137−-- ],
138−-- "type": "object"
139−-- }
140−-- }
141−-- <BLANKLINE>
142−renderValidationErrors
143− :: forall a. (ToJSON a, ToSchema a)
144− => (a -> [ValidationError]) -> a -> Maybe String
145−renderValidationErrors f x =
146− case f x of
147− [] -> Nothing
148− errors -> Just $ unlines
149− [ "Validation against the schema fails:"
150− , unlines (map (" * " ++) errors)
151− , "JSON value:"
152− , ppJSONString (toJSON x)
153− , ""
154− , "Swagger Schema:"
155− , ppJSONString (toJSON schema_)
156− , ""
157− , "Swagger Description Context:"
158− , ppJSONString (toJSON refs_)
159− ]
160− where
161− ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty
162− (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
163−
164−-- | Validate JSON @'Value'@ against Swagger @'Schema'@.
165−--
166−-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []
167−--
168−-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.
169−-- See @'validateJSONWithPatternChecker'@.
170−validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]
171−validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True)
172−
173−-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker.
174−--
175−-- For validation without patterns see @'validateJSON'@.
176−validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]
177−validateJSONWithPatternChecker checker defs sch js =
178− case runValidation (validateWithSchema js) cfg sch of
179− Failed xs -> xs
180− Passed _ -> mempty
181− where
182− cfg = defaultConfig
183− { configPatternChecker = checker
184− , configDefinitions = defs }
185−
186−-- | Validation error message.
187−type ValidationError = String
188−
189−-- | Validation result type.
190−data Result a
191− = Failed [ValidationError] -- ^ Validation failed with a list of error messages.
192− | Passed a -- ^ Validation passed.
193− deriving (Eq, Show, Functor)
194−
195−instance Applicative Result where
196− pure = Passed
197− Passed f <*> Passed x = Passed (f x)
198− Failed xs <*> Failed ys = Failed (xs <> ys)
199− Failed xs <*> _ = Failed xs
200− _ <*> Failed ys = Failed ys
201−
202−instance Alternative Result where
203− empty = Failed mempty
204− Passed x <|> _ = Passed x
205− _ <|> y = y
206−
207−instance Monad Result where
208− return = pure
209− Passed x >>= f = f x
210− Failed xs >>= _ = Failed xs
211−
212−-- | Validation configuration.
213−data Config = Config
214− { -- | Pattern checker for @'_schemaPattern'@ validation.
215− configPatternChecker :: Pattern -> Text -> Bool
216− -- | Schema definitions in scope to resolve references.
217− , configDefinitions :: Definitions Schema
218− }
219−
220−-- | Default @'Config'@:
221−--
222−-- @
223−-- defaultConfig = 'Config'
224−-- { 'configPatternChecker' = \\_pattern _str -> True
225−-- , 'configDefinitions' = mempty
226−-- }
227−-- @
228−defaultConfig :: Config
229−defaultConfig = Config
230− { configPatternChecker = \_pattern _str -> True
231− , configDefinitions = mempty
232− }
233−
234−-- | Value validation.
235−newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }
236− deriving (Functor)
237−
238−instance Applicative (Validation schema) where
239− pure x = Validation (\_ _ -> pure x)
240− Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)
241−
242−instance Alternative (Validation schema) where
243− empty = Validation (\_ _ -> empty)
244− Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)
245−
246−instance Profunctor Validation where
247− dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))
248−
249−instance Choice Validation where
250− left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))
251− right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))
252−
253−instance Monad (Validation s) where
254− return = pure
255− Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)
256− (>>) = (*>)
257−
258−withConfig :: (Config -> Validation s a) -> Validation s a
259−withConfig f = Validation (\c -> runValidation (f c) c)
260−
261−withSchema :: (s -> Validation s a) -> Validation s a
262−withSchema f = Validation (\c s -> runValidation (f s) c s)
263−
264−-- | Issue an error message.
265−invalid :: String -> Validation schema a
266−invalid msg = Validation (\_ _ -> Failed [msg])
267−
268−-- | Validation passed.
269−valid :: Validation schema ()
270−valid = pure ()
271−
272−-- | Validate schema's property given a lens into that property
273−-- and property checker.
274−checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
275−checkMissing missing l g = withSchema $ \sch ->
276− case sch ^. l of
277− Nothing -> missing
278− Just x -> g x
279−
280−-- | Validate schema's property given a lens into that property
281−-- and property checker.
282−-- If property is missing in schema, consider it valid.
283−check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
284−check = checkMissing valid
285−
286−-- | Validate same value with different schema.
287−sub :: t -> Validation t a -> Validation s a
288−sub = lmap . const
289−
290−-- | Validate same value with a part of the original schema.
291−sub_ :: Getting a s a -> Validation a r -> Validation s r
292−sub_ = lmap . view
293−
294−-- | Validate value against a schema given schema reference and validation function.
295−withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
296−withRef (Reference ref) f = withConfig $ \cfg ->
297− case InsOrdHashMap.lookup ref (configDefinitions cfg) of
298− Nothing -> invalid $ "unknown schema " ++ show ref
299− Just s -> f s
300−
301−validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
302−validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)
303−validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
304−
305−-- | Validate JSON @'Value'@ with Swagger @'Schema'@.
306−validateWithSchema :: Value -> Validation Schema ()
307−validateWithSchema val = do
308− validateSchemaType val
309− validateEnum val
310−
311−validateInteger :: Scientific -> Validation Schema ()
312−validateInteger n = do
313− when (not (isInteger n)) $
314− invalid ("not an integer")
315− validateNumber n
316−
317−validateNumber :: Scientific -> Validation Schema ()
318−validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do
319− let exMax = Just True == sch ^. exclusiveMaximum
320− exMin = Just True == sch ^. exclusiveMinimum
321−
322− check maximum_ $ \m ->
323− when (if exMax then (n >= m) else (n > m)) $
324− invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ (if exMax then "<" else "<=") ++ show m ++ ")")
325−
326− check minimum_ $ \m ->
327− when (if exMin then (n <= m) else (n < m)) $
328− invalid ("value " ++ show n ++ " falls below minimum (should be " ++ (if exMin then ">" else ">=") ++ show m ++ ")")
329−
330− check multipleOf $ \k ->
331− when (not (isInteger (n / k))) $
332− invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)
333−
334−validateString :: Text -> Validation Schema ()
335−validateString s = do
336− check maxLength $ \n ->
337− when (len > fromInteger n) $
338− invalid ("string is too long (length should be <=" ++ show n ++ ")")
339−
340− check minLength $ \n ->
341− when (len < fromInteger n) $
342− invalid ("string is too short (length should be >=" ++ show n ++ ")")
343−
344− check pattern $ \regex -> do
345− withConfig $ \cfg -> do
346− when (not (configPatternChecker cfg regex s)) $
347− invalid ("string does not match pattern " ++ show regex)
348− where
349− len = Text.length s
350−
351−validateArray :: Vector Value -> Validation Schema ()
352−validateArray xs = do
353− check maxItems $ \n ->
354− when (len > fromInteger n) $
355− invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")")
356−
357− check minItems $ \n ->
358− when (len < fromInteger n) $
359− invalid ("array is too short (size should be >=" ++ show n ++ ")")
360−
361− check items $ \case
362− OpenApiItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs
363− OpenApiItemsArray itemSchemas -> do
364− when (len /= length itemSchemas) $
365− invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")
366− sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
367−
368− check uniqueItems $ \unique ->
369− when (unique && not allUnique) $
370− invalid ("array is expected to contain unique items, but it does not")
371− where
372− len = Vector.length xs
373− allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
374−
375−validateObject ::
376−#if MIN_VERSION_aeson(2,0,0)
377− KeyMap.KeyMap Value
378−#else
379− HashMap Text Value
380−#endif
381− -> Validation Schema ()
382−validateObject o = withSchema $ \sch ->
383− case sch ^. discriminator of
384− Just (Discriminator pname types) -> case fromJSON <$> lookupKey pname o of
385− Just (Success pvalue) ->
386− let ref = fromMaybe pvalue $ InsOrdHashMap.lookup pvalue types
387− -- TODO ref may be name or reference
388− in validateWithSchemaRef (Ref (Reference ref)) (Object o)
389− Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)
390− Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing")
391− Nothing -> do
392− check maxProperties $ \n ->
393− when (size > n) $
394− invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")")
395−
396− check minProperties $ \n ->
397− when (size < n) $
398− invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")")
399−
400− validateRequired
401− validateProps
402− where
403− size = fromIntegral (length o)
404−
405− validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)
406− validateReq n =
407− when (not (hasKey n o)) $
408− invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))
409−
410− validateProps = withSchema $ \sch -> do
411− for_ (objectToList o) $ \(keyToText -> k, v) ->
412− case v of
413− Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
414− _ ->
415− case InsOrdHashMap.lookup k (sch ^. properties) of
416− Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
417− Just s -> validateWithSchemaRef s v
418−
419− validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid
420− validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"
421− validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v
422−
423− unknownProperty :: Text -> Validation s a
424− unknownProperty pname = invalid $
425− "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"
426−
427−validateEnum :: Value -> Validation Schema ()
428−validateEnum val = do
429− check enum_ $ \xs ->
430− when (val `notElem` xs) $
431− invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show val)
432−
433−-- | Infer schema type based on used properties.
434−--
435−-- This is like 'inferParamSchemaTypes', but also works for objects:
436−--
437−-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"
438−-- Just [OpenApiObject]
439−inferSchemaTypes :: Schema -> [OpenApiType]
440−inferSchemaTypes sch = inferParamSchemaTypes sch ++
441− [ OpenApiObject | any ($ sch)
442− [ has (additionalProperties._Just)
443− , has (maxProperties._Just)
444− , has (minProperties._Just)
445− , has (properties.folded)
446− , has (required.folded) ] ]
447−
448−-- | Infer schema type based on used properties.
449−--
450−-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"
451−-- Just [OpenApiString]
452−--
453−-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"
454−-- Just [OpenApiArray]
455−--
456−-- From numeric properties 'OpenApiInteger' type is inferred.
457−-- If you want 'OpenApiNumber' instead, you must specify it explicitly.
458−--
459−-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"
460−-- Just [OpenApiInteger]
461−inferParamSchemaTypes :: Schema -> [OpenApiType]
462−inferParamSchemaTypes sch = concat
463− [ [ OpenApiArray | any ($ sch)
464− [ has (items._Just)
465− , has (maxItems._Just)
466− , has (minItems._Just)
467− , has (uniqueItems._Just) ] ]
468− , [ OpenApiInteger | any ($ sch)
469− [ has (exclusiveMaximum._Just)
470− , has (exclusiveMinimum._Just)
471− , has (maximum_._Just)
472− , has (minimum_._Just)
473− , has (multipleOf._Just) ] ]
474− , [ OpenApiString | any ($ sch)
475− [ has (maxLength._Just)
476− , has (minLength._Just)
477− , has (pattern._Just) ] ]
478− ]
479−
480−validateSchemaType :: Value -> Validation Schema ()
481−validateSchemaType val = withSchema $ \sch ->
482− case sch of
483− (view oneOf -> Just variants) -> do
484− res <- forM variants $ \var ->
485− (True <$ validateWithSchemaRef var val) <|> (return False)
486− case length $ filter id res of
487− 0 -> invalid $ "Value not valid under any of 'oneOf' schemas: " ++ show val
488− 1 -> valid
489− _ -> invalid $ "Value matches more than one of 'oneOf' schemas: " ++ show val
490− (view allOf -> Just variants) -> do
491− -- Default semantics for Validation Monad will abort when at least one
492− -- variant does not match.
493− forM_ variants $ \var ->
494− validateWithSchemaRef var val
495−
496− _ ->
497− case (sch ^. type_, val) of
498− (Just OpenApiNull, Null) -> valid
499− (Just OpenApiBoolean, Bool _) -> valid
500− (Just OpenApiInteger, Number n) -> validateInteger n
501− (Just OpenApiNumber, Number n) -> validateNumber n
502− (Just OpenApiString, String s) -> validateString s
503− (Just OpenApiArray, Array xs) -> validateArray xs
504− (Just OpenApiObject, Object o) -> validateObject o
505− (Nothing, Null) -> valid
506− (Nothing, Bool _) -> valid
507− -- Number by default
508− (Nothing, Number n) -> validateNumber n
509− (Nothing, String s) -> validateString s
510− (Nothing, Array xs) -> validateArray xs
511− (Nothing, Object o) -> validateObject o
512− bad -> invalid $ "expected JSON value of type " ++ showType bad
513−
514−validateParamSchemaType :: Value -> Validation Schema ()
515−validateParamSchemaType val = withSchema $ \sch ->
516− case (sch ^. type_, val) of
517− (Just OpenApiBoolean, Bool _) -> valid
518− (Just OpenApiInteger, Number n) -> validateInteger n
519− (Just OpenApiNumber, Number n) -> validateNumber n
520− (Just OpenApiString, String s) -> validateString s
521− (Just OpenApiArray, Array xs) -> validateArray xs
522− (Nothing, Bool _) -> valid
523− -- Number by default
524− (Nothing, Number n) -> validateNumber n
525− (Nothing, String s) -> validateString s
526− (Nothing, Array xs) -> validateArray xs
527− bad -> invalid $ "expected JSON value of type " ++ showType bad
528−
529−showType :: (Maybe OpenApiType, Value) -> String
530−showType (Just ty, _) = show ty
531−showType (Nothing, Null) = "OpenApiNull"
532−showType (Nothing, Bool _) = "OpenApiBoolean"
533−showType (Nothing, Number _) = "OpenApiNumber"
534−showType (Nothing, String _) = "OpenApiString"
535−showType (Nothing, Array _) = "OpenApiArray"
536−showType (Nothing, Object _) = "OpenApiObject"
src/Data/OpenApi/Internal/TypeShape.hsdeleted−56
@@ -1,56 +0,0 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE TypeFamilies #-}
4−{-# LANGUAGE TypeOperators #-}
5−{-# LANGUAGE UndecidableInstances #-}
6−
7−module Data.OpenApi.Internal.TypeShape where
8−
9−import Data.Proxy
10−import GHC.Generics
11−import GHC.TypeLits
12−import GHC.Exts (Constraint)
13−
14−-- | Shape of a datatype.
15−data TypeShape
16− = Enumeration -- ^ A simple enumeration.
17− | SumOfProducts -- ^ A product or a sum of non-unit products.
18− | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.
19−
20−-- | A combined shape for a product type.
21−type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
22− ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products
23− ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products
24− ProdCombine a b = SumOfProducts
25−
26−-- | A combined shape for a sum type.
27−type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
28− SumCombine Enumeration Enumeration = Enumeration
29− SumCombine SumOfProducts SumOfProducts = SumOfProducts
30− SumCombine a b = Mixed
31−
32−type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where
33− TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))
34−
35−type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where
36− GenericHasSimpleShape t f Enumeration = ()
37− GenericHasSimpleShape t f SumOfProducts = ()
38− GenericHasSimpleShape t f Mixed =
39− TypeError
40− ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t
41− :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."
42− :$$: Text "Swagger does not have a good representation for these types."
43− :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"
44− :$$: Text "that matches aeson's Generic-based toJSON,"
45− :$$: Text "but that's not supported by some Swagger tools."
46− )
47−
48−-- | Infer a 'TypeShape' for a generic representation of a type.
49−type family GenericShape (g :: * -> *) :: TypeShape
50−
51−type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)
52−type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)
53−type instance GenericShape (D1 d f) = GenericShape f
54−type instance GenericShape (C1 c U1) = Enumeration
55−type instance GenericShape (C1 c (S1 s f)) = SumOfProducts
56−type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
src/Data/OpenApi/Lens.hsdeleted−166
@@ -1,166 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE RankNTypes #-}
7−{-# LANGUAGE TemplateHaskell #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE DataKinds #-}
10−{-# LANGUAGE UndecidableInstances #-}
11−{-# OPTIONS_GHC -fno-warn-orphans #-}
12−-- |
13−-- Module: Data.OpenApi.Lens
14−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
15−-- Stability: experimental
16−--
17−-- Lenses and prisms for Swagger.
18−module Data.OpenApi.Lens where
19−
20−import Control.Lens
21−import Data.Aeson (Value)
22−import Data.Scientific (Scientific)
23−import Data.OpenApi.Internal
24−import Data.OpenApi.Internal.Utils
25−import Data.Text (Text)
26−
27−-- * Classy lenses
28−
29−makeFields ''OpenApi
30−makeFields ''Components
31−makeFields ''Server
32−makeFields ''RequestBody
33−makeFields ''MediaTypeObject
34−makeFields ''Info
35−makeFields ''Contact
36−makeFields ''License
37−makeLensesWith swaggerFieldRules ''PathItem
38−makeFields ''Tag
39−makeFields ''Operation
40−makeLensesWith swaggerFieldRules ''Param
41−makeFields ''Header
42−makeLensesWith swaggerFieldRules ''Schema
43−makeFields ''NamedSchema
44−makeFields ''Xml
45−makeLensesWith swaggerFieldRules ''Responses
46−makeFields ''Response
47−makeLensesWith swaggerFieldRules ''SecurityScheme
48−makeFields ''ApiKeyParams
49−makeFields ''OAuth2ImplicitFlow
50−makeFields ''OAuth2PasswordFlow
51−makeFields ''OAuth2ClientCredentialsFlow
52−makeFields ''OAuth2AuthorizationCodeFlow
53−makeFields ''OAuth2Flow
54−makeFields ''OAuth2Flows
55−makeFields ''ExternalDocs
56−makeFields ''Encoding
57−makeFields ''Example
58−makeFields ''Discriminator
59−makeFields ''Link
60−
61−-- * Prisms
62−-- ** 'SecuritySchemeType' prisms
63−makePrisms ''SecuritySchemeType
64−-- ** 'Referenced' prisms
65−makePrisms ''Referenced
66−
67−-- ** 'OpenApiItems' prisms
68−
69−_OpenApiItemsArray :: Review OpenApiItems [Referenced Schema]
70−_OpenApiItemsArray
71− = unto (\x -> OpenApiItemsArray x)
72−{- \x -> case x of
73− OpenApiItemsPrimitive c p -> Left (OpenApiItemsPrimitive c p)
74− OpenApiItemsObject o -> Left (OpenApiItemsObject o)
75− OpenApiItemsArray a -> Right a
76−-}
77−
78−_OpenApiItemsObject :: Review OpenApiItems (Referenced Schema)
79−_OpenApiItemsObject
80− = unto (\x -> OpenApiItemsObject x)
81−{- \x -> case x of
82− OpenApiItemsPrimitive c p -> Left (OpenApiItemsPrimitive c p)
83− OpenApiItemsObject o -> Right o
84− OpenApiItemsArray a -> Left (OpenApiItemsArray a)
85−-}
86−
87−-- =============================================================
88−-- More helpful instances for easier access to schema properties
89−
90−type instance Index Responses = HttpStatusCode
91−type instance Index Operation = HttpStatusCode
92−
93−type instance IxValue Responses = Referenced Response
94−type instance IxValue Operation = Referenced Response
95−
96−instance Ixed Responses where ix n = responses . ix n
97−instance At Responses where at n = responses . at n
98−
99−instance Ixed Operation where ix n = responses . ix n
100−instance At Operation where at n = responses . at n
101−
102−instance HasType NamedSchema (Maybe OpenApiType) where type_ = schema.type_
103−
104−-- OVERLAPPABLE instances
105−
106−instance
107− {-# OVERLAPPABLE #-}
108− HasSchema s Schema
109− => HasFormat s (Maybe Format) where
110− format = schema.format
111−
112−instance
113− {-# OVERLAPPABLE #-}
114− HasSchema s Schema
115− => HasItems s (Maybe OpenApiItems) where
116− items = schema.items
117−
118−instance
119− {-# OVERLAPPABLE #-}
120− HasSchema s Schema
121− => HasMaximum s (Maybe Scientific) where
122− maximum_ = schema.maximum_
123−
124−instance {-# OVERLAPPABLE #-} HasSchema s Schema
125− => HasExclusiveMaximum s (Maybe Bool) where
126− exclusiveMaximum = schema.exclusiveMaximum
127−
128−instance {-# OVERLAPPABLE #-} HasSchema s Schema
129− => HasMinimum s (Maybe Scientific) where
130− minimum_ = schema.minimum_
131−
132−instance {-# OVERLAPPABLE #-} HasSchema s Schema
133− => HasExclusiveMinimum s (Maybe Bool) where
134− exclusiveMinimum = schema.exclusiveMinimum
135−
136−instance {-# OVERLAPPABLE #-} HasSchema s Schema
137− => HasMaxLength s (Maybe Integer) where
138− maxLength = schema.maxLength
139−
140−instance {-# OVERLAPPABLE #-} HasSchema s Schema
141− => HasMinLength s (Maybe Integer) where
142− minLength = schema.minLength
143−
144−instance {-# OVERLAPPABLE #-} HasSchema s Schema
145− => HasPattern s (Maybe Text) where
146− pattern = schema.pattern
147−
148−instance {-# OVERLAPPABLE #-} HasSchema s Schema
149− => HasMaxItems s (Maybe Integer) where
150− maxItems = schema.maxItems
151−
152−instance {-# OVERLAPPABLE #-} HasSchema s Schema
153− => HasMinItems s (Maybe Integer) where
154− minItems = schema.minItems
155−
156−instance {-# OVERLAPPABLE #-} HasSchema s Schema
157− => HasUniqueItems s (Maybe Bool) where
158− uniqueItems = schema.uniqueItems
159−
160−instance {-# OVERLAPPABLE #-} HasSchema s Schema
161− => HasEnum s (Maybe [Value]) where
162− enum_ = schema.enum_
163−
164−instance {-# OVERLAPPABLE #-} HasSchema s Schema
165− => HasMultipleOf s (Maybe Scientific) where
166− multipleOf = schema.multipleOf
src/Data/OpenApi/Operation.hsdeleted−305
@@ -1,305 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−-- |
3−-- Module: Data.OpenApi.Operation
4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5−-- Stability: experimental
6−--
7−-- Helper traversals and functions for Swagger operations manipulations.
8−-- These might be useful when you already have Swagger specification
9−-- generated by something else.
10−module Data.OpenApi.Operation (
11− -- * Operation traversals
12− allOperations,
13− operationsOf,
14−
15− -- * Manipulation
16− -- ** Tags
17− applyTags,
18− applyTagsFor,
19−
20− -- ** Responses
21− setResponse,
22− setResponseWith,
23− setResponseFor,
24− setResponseForWith,
25−
26− -- ** Paths
27− prependPath,
28−
29− -- * Miscellaneous
30− declareResponse,
31−) where
32−
33−import Prelude ()
34−import Prelude.Compat
35−
36−import Control.Lens
37−import Data.Data.Lens
38−import Data.List.Compat
39−import Data.Maybe (mapMaybe)
40−import Data.Proxy
41−import qualified Data.Set as Set
42−import Data.Text (Text)
43−import Network.HTTP.Media (MediaType)
44−
45−import Data.OpenApi.Declare
46−import Data.OpenApi.Internal
47−import Data.OpenApi.Lens
48−import Data.OpenApi.Schema
49−
50−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
51−import qualified Data.HashSet.InsOrd as InsOrdHS
52−
53−-- $setup
54−-- >>> import Data.Aeson
55−-- >>> import Data.Proxy
56−-- >>> import Data.Time
57−-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
58−-- >>> import Data.OpenApi.Internal.Utils
59−
60−-- | Prepend path piece to all operations of the spec.
61−-- Leading and trailing slashes are trimmed/added automatically.
62−--
63−-- >>> let api = (mempty :: OpenApi) & paths .~ [("/info", mempty)]
64−-- >>> BSL.putStrLn $ encodePretty $ prependPath "user/{user_id}" api ^. paths
65−-- {
66−-- "/user/{user_id}/info": {}
67−-- }
68−prependPath :: FilePath -> OpenApi -> OpenApi
69−prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)
70− where
71− x </> y = case trim y of
72− "" -> "/" <> trim x
73− y' -> "/" <> trim x <> "/" <> y'
74−
75− trim = dropWhile (== '/') . dropWhileEnd (== '/')
76−
77−-- | All operations of a Swagger spec.
78−allOperations :: Traversal' OpenApi Operation
79−allOperations = paths.traverse.template
80−
81−-- | @'operationsOf' sub@ will traverse only those operations
82−-- that are present in @sub@. Note that @'Operation'@ is determined
83−-- by both path and method.
84−--
85−-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"
86−-- >>> let api = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
87−-- >>> let sub = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ mempty)]
88−-- >>> BSL.putStrLn $ encodePretty api
89−-- {
90−-- "components": {},
91−-- "info": {
92−-- "title": "",
93−-- "version": ""
94−-- },
95−-- "openapi": "3.0.0",
96−-- "paths": {
97−-- "/user": {
98−-- "get": {
99−-- "responses": {
100−-- "200": {
101−-- "description": "OK"
102−-- }
103−-- }
104−-- },
105−-- "post": {
106−-- "responses": {
107−-- "200": {
108−-- "description": "OK"
109−-- }
110−-- }
111−-- }
112−-- }
113−-- }
114−-- }
115−-- >>> BSL.putStrLn $ encodePretty $ api & operationsOf sub . at 404 ?~ "Not found"
116−-- {
117−-- "components": {},
118−-- "info": {
119−-- "title": "",
120−-- "version": ""
121−-- },
122−-- "openapi": "3.0.0",
123−-- "paths": {
124−-- "/user": {
125−-- "get": {
126−-- "responses": {
127−-- "200": {
128−-- "description": "OK"
129−-- },
130−-- "404": {
131−-- "description": "Not found"
132−-- }
133−-- }
134−-- },
135−-- "post": {
136−-- "responses": {
137−-- "200": {
138−-- "description": "OK"
139−-- }
140−-- }
141−-- }
142−-- }
143−-- }
144−-- }
145−operationsOf :: OpenApi -> Traversal' OpenApi Operation
146−operationsOf sub = paths.itraversed.withIndex.subops
147− where
148− -- | Traverse operations that correspond to paths and methods of the sub API.
149− subops :: Traversal' (FilePath, PathItem) Operation
150− subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of
151− Just subitem -> (,) path <$> methodsOf subitem f item
152− Nothing -> pure (path, item)
153−
154− -- | Traverse operations that exist in a given @'PathItem'@
155− -- This is used to traverse only the operations that exist in sub API.
156− methodsOf :: PathItem -> Traversal' PathItem Operation
157− methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just
158− where
159− ops = pathItem ^.. template :: [Maybe Operation]
160− ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops
161−
162−-- | Apply tags to all operations and update the global list of tags.
163−--
164−-- @
165−-- 'applyTags' = 'applyTagsFor' 'allOperations'
166−-- @
167−applyTags :: [Tag] -> OpenApi -> OpenApi
168−applyTags = applyTagsFor allOperations
169−
170−-- | Apply tags to a part of Swagger spec and update the global
171−-- list of tags.
172−applyTagsFor :: Traversal' OpenApi Operation -> [Tag] -> OpenApi -> OpenApi
173−applyTagsFor ops ts swag = swag
174− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
175− & tags %~ (<> InsOrdHS.fromList ts)
176−
177−-- | Construct a response with @'Schema'@ while declaring all
178−-- necessary schema definitions.
179−--
180−-- FIXME doc
181−--
182−-- >>> BSL.putStrLn $ encodePretty $ runDeclare (declareResponse "application/json" (Proxy :: Proxy Day)) mempty
183−-- [
184−-- {
185−-- "Day": {
186−-- "example": "2016-07-22",
187−-- "format": "date",
188−-- "type": "string"
189−-- }
190−-- },
191−-- {
192−-- "content": {
193−-- "application/json": {
194−-- "schema": {
195−-- "$ref": "#/components/schemas/Day"
196−-- }
197−-- }
198−-- },
199−-- "description": ""
200−-- }
201−-- ]
202−declareResponse :: ToSchema a => MediaType -> Proxy a -> Declare (Definitions Schema) Response
203−declareResponse cType proxy = do
204− s <- declareSchemaRef proxy
205− return (mempty & content.at cType ?~ (mempty & schema ?~ s))
206−
207−-- | Set response for all operations.
208−-- This will also update global schema definitions.
209−--
210−-- If the response already exists it will be overwritten.
211−--
212−-- @
213−-- 'setResponse' = 'setResponseFor' 'allOperations'
214−-- @
215−--
216−-- Example:
217−--
218−-- >>> let api = (mempty :: OpenApi) & paths .~ [("/user", mempty & get ?~ mempty)]
219−-- >>> let res = declareResponse "application/json" (Proxy :: Proxy Day)
220−-- >>> BSL.putStrLn $ encodePretty $ api & setResponse 200 res
221−-- {
222−-- "components": {
223−-- "schemas": {
224−-- "Day": {
225−-- "example": "2016-07-22",
226−-- "format": "date",
227−-- "type": "string"
228−-- }
229−-- }
230−-- },
231−-- "info": {
232−-- "title": "",
233−-- "version": ""
234−-- },
235−-- "openapi": "3.0.0",
236−-- "paths": {
237−-- "/user": {
238−-- "get": {
239−-- "responses": {
240−-- "200": {
241−-- "content": {
242−-- "application/json": {
243−-- "schema": {
244−-- "$ref": "#/components/schemas/Day"
245−-- }
246−-- }
247−-- },
248−-- "description": ""
249−-- }
250−-- }
251−-- }
252−-- }
253−-- }
254−-- }
255−--
256−-- See also @'setResponseWith'@.
257−setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi
258−setResponse = setResponseFor allOperations
259−
260−-- | Set or update response for all operations.
261−-- This will also update global schema definitions.
262−--
263−-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
264−-- then just the new response is used.
265−--
266−-- @
267−-- 'setResponseWith' = 'setResponseForWith' 'allOperations'
268−-- @
269−--
270−-- See also @'setResponse'@.
271−setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi
272−setResponseWith = setResponseForWith allOperations
273−
274−-- | Set response for specified operations.
275−-- This will also update global schema definitions.
276−--
277−-- If the response already exists it will be overwritten.
278−--
279−-- See also @'setResponseForWith'@.
280−setResponseFor :: Traversal' OpenApi Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi
281−setResponseFor ops code dres swag = swag
282− & components.schemas %~ (<> defs)
283− & ops . at code ?~ Inline res
284− where
285− (defs, res) = runDeclare dres mempty
286−
287−-- | Set or update response for specified operations.
288−-- This will also update global schema definitions.
289−--
290−-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
291−-- then just the new response is used.
292−--
293−-- See also @'setResponseFor'@.
294−setResponseForWith :: Traversal' OpenApi Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi
295−setResponseForWith ops f code dres swag = swag
296− & components.schemas %~ (<> defs)
297− & ops . at code %~ Just . Inline . combine
298− where
299− (defs, new) = runDeclare dres mempty
300−
301− combine (Just (Ref (Reference n))) = case swag ^. components.responses.at n of
302− Just old -> f old new
303− Nothing -> new -- response name can't be dereferenced, replacing with new response
304− combine (Just (Inline old)) = f old new
305− combine Nothing = new
src/Data/OpenApi/Optics.hsdeleted−328
@@ -1,328 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE OverloadedLabels #-}
5−{-# LANGUAGE TemplateHaskell #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−{-# OPTIONS_GHC -fno-warn-orphans #-}
9−-- |
10−-- Module: Data.OpenApi.Optics
11−-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>
12−-- Stability: experimental
13−--
14−-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>
15−-- library.
16−--
17−-- >>> import Data.Aeson
18−-- >>> import Optics.Core
19−-- >>> :set -XOverloadedLabels
20−-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
21−--
22−-- Example from the "Data.OpenApi" module using @optics@:
23−--
24−-- >>> :{
25−-- BSL.putStrLn $ encodePretty $ (mempty :: OpenApi)
26−-- & #components % #schemas .~ [ ("User", mempty & #type ?~ OpenApiString) ]
27−-- & #paths .~
28−-- [ ("/user", mempty & #get ?~ (mempty
29−-- & at 200 ?~ ("OK" & #_Inline % #content % at "application/json" ?~ (mempty & #schema ?~ Ref (Reference "User")))
30−-- & at 404 ?~ "User info not found")) ]
31−-- :}
32−-- {
33−-- "components": {
34−-- "schemas": {
35−-- "User": {
36−-- "type": "string"
37−-- }
38−-- }
39−-- },
40−-- "info": {
41−-- "title": "",
42−-- "version": ""
43−-- },
44−-- "openapi": "3.0.0",
45−-- "paths": {
46−-- "/user": {
47−-- "get": {
48−-- "responses": {
49−-- "200": {
50−-- "content": {
51−-- "application/json": {
52−-- "schema": {
53−-- "$ref": "#/components/schemas/User"
54−-- }
55−-- }
56−-- },
57−-- "description": "OK"
58−-- },
59−-- "404": {
60−-- "description": "User info not found"
61−-- }
62−-- }
63−-- }
64−-- }
65−-- }
66−-- }
67−--
68−-- For convenience optics are defined as /labels/. It means that field accessor
69−-- names can be overloaded for different types. One such common field is
70−-- @#description@. Many components of a Swagger specification can have
71−-- descriptions, and you can use the same name for them:
72−--
73−-- >>> BSL.putStrLn $ encodePretty $ (mempty :: Response) & #description .~ "No content"
74−-- {
75−-- "description": "No content"
76−-- }
77−-- >>> :{
78−-- BSL.putStrLn $ encodePretty $ (mempty :: Schema)
79−-- & #type ?~ OpenApiBoolean
80−-- & #description ?~ "To be or not to be"
81−-- :}
82−-- {
83−-- "description": "To be or not to be",
84−-- "type": "boolean"
85−-- }
86−--
87−-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and
88−-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:
89−--
90−-- >>> :{
91−-- BSL.putStrLn $ encodePretty $ (mempty :: Operation)
92−-- & at 404 ?~ "Not found"
93−-- :}
94−-- {
95−-- "responses": {
96−-- "404": {
97−-- "description": "Not found"
98−-- }
99−-- }
100−-- }
101−module Data.OpenApi.Optics () where
102−
103−import Data.Aeson (Value)
104−import Data.Scientific (Scientific)
105−import Data.OpenApi.Internal
106−import Data.OpenApi.Internal.Utils
107−import Data.Text (Text)
108−import Optics.Core
109−import Optics.TH
110−
111−-- Lenses
112−
113−makeFieldLabels ''OpenApi
114−makeFieldLabels ''Components
115−makeFieldLabels ''Server
116−makeFieldLabels ''ServerVariable
117−makeFieldLabels ''RequestBody
118−makeFieldLabels ''MediaTypeObject
119−makeFieldLabels ''Info
120−makeFieldLabels ''Contact
121−makeFieldLabels ''License
122−makeFieldLabels ''PathItem
123−makeFieldLabels ''Tag
124−makeFieldLabels ''Operation
125−makeFieldLabels ''Param
126−makeFieldLabels ''Header
127−makeFieldLabels ''Schema
128−makeFieldLabels ''NamedSchema
129−makeFieldLabels ''Xml
130−makeFieldLabels ''Responses
131−makeFieldLabels ''Response
132−makeFieldLabels ''SecurityScheme
133−makeFieldLabels ''ApiKeyParams
134−makeFieldLabels ''OAuth2ImplicitFlow
135−makeFieldLabels ''OAuth2PasswordFlow
136−makeFieldLabels ''OAuth2ClientCredentialsFlow
137−makeFieldLabels ''OAuth2AuthorizationCodeFlow
138−makeFieldLabels ''OAuth2Flow
139−makeFieldLabels ''OAuth2Flows
140−makeFieldLabels ''ExternalDocs
141−makeFieldLabels ''Encoding
142−makeFieldLabels ''Example
143−makeFieldLabels ''Discriminator
144−makeFieldLabels ''Link
145−
146−-- Prisms
147−
148−makePrismLabels ''SecuritySchemeType
149−makePrismLabels ''Referenced
150−
151−-- OpenApiItems prisms
152−
153−instance
154− ( a ~ [Referenced Schema]
155− , b ~ [Referenced Schema]
156− ) => LabelOptic "_OpenApiItemsArray"
157− A_Review
158− OpenApiItems
159− OpenApiItems
160− a
161− b where
162− labelOptic = unto (\x -> OpenApiItemsArray x)
163− {-# INLINE labelOptic #-}
164−
165−instance
166− ( a ~ Referenced Schema
167− , b ~ Referenced Schema
168− ) => LabelOptic "_OpenApiItemsObject"
169− A_Review
170− OpenApiItems
171− OpenApiItems
172− a
173− b where
174− labelOptic = unto (\x -> OpenApiItemsObject x)
175− {-# INLINE labelOptic #-}
176−
177−-- =============================================================
178−-- More helpful instances for easier access to schema properties
179−
180−type instance Index Responses = HttpStatusCode
181−type instance Index Operation = HttpStatusCode
182−
183−type instance IxValue Responses = Referenced Response
184−type instance IxValue Operation = Referenced Response
185−
186−instance Ixed Responses where
187− ix n = #responses % ix n
188− {-# INLINE ix #-}
189−instance At Responses where
190− at n = #responses % at n
191− {-# INLINE at #-}
192−
193−instance Ixed Operation where
194− ix n = #responses % ix n
195− {-# INLINE ix #-}
196−instance At Operation where
197− at n = #responses % at n
198− {-# INLINE at #-}
199−
200−-- #type
201−
202−instance
203− ( a ~ Maybe OpenApiType
204− , b ~ Maybe OpenApiType
205− ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where
206− labelOptic = #schema % #type
207− {-# INLINE labelOptic #-}
208−
209−-- #default
210−
211−instance
212− ( a ~ Maybe Value, b ~ Maybe Value
213− ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where
214− labelOptic = #schema % #default
215− {-# INLINE labelOptic #-}
216−
217−-- #format
218−
219−instance
220− ( a ~ Maybe Format, b ~ Maybe Format
221− ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where
222− labelOptic = #schema % #format
223− {-# INLINE labelOptic #-}
224−
225−-- #items
226−
227−instance
228− ( a ~ Maybe OpenApiItems
229− , b ~ Maybe OpenApiItems
230− ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where
231− labelOptic = #schema % #items
232− {-# INLINE labelOptic #-}
233−
234−-- #maximum
235−
236−instance
237− ( a ~ Maybe Scientific, b ~ Maybe Scientific
238− ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where
239− labelOptic = #schema % #maximum
240− {-# INLINE labelOptic #-}
241−
242−-- #exclusiveMaximum
243−
244−instance
245− ( a ~ Maybe Bool, b ~ Maybe Bool
246− ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where
247− labelOptic = #schema % #exclusiveMaximum
248− {-# INLINE labelOptic #-}
249−
250−-- #minimum
251−
252−instance
253− ( a ~ Maybe Scientific, b ~ Maybe Scientific
254− ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where
255− labelOptic = #schema % #minimum
256− {-# INLINE labelOptic #-}
257−
258−-- #exclusiveMinimum
259−
260−instance
261− ( a ~ Maybe Bool, b ~ Maybe Bool
262− ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where
263− labelOptic = #schema % #exclusiveMinimum
264− {-# INLINE labelOptic #-}
265−
266−-- #maxLength
267−
268−instance
269− ( a ~ Maybe Integer, b ~ Maybe Integer
270− ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where
271− labelOptic = #schema % #maxLength
272− {-# INLINE labelOptic #-}
273−
274−-- #minLength
275−
276−instance
277− ( a ~ Maybe Integer, b ~ Maybe Integer
278− ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where
279− labelOptic = #schema % #minLength
280− {-# INLINE labelOptic #-}
281−
282−-- #pattern
283−
284−instance
285− ( a ~ Maybe Text, b ~ Maybe Text
286− ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where
287− labelOptic = #schema % #pattern
288− {-# INLINE labelOptic #-}
289−
290−-- #maxItems
291−
292−instance
293− ( a ~ Maybe Integer, b ~ Maybe Integer
294− ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where
295− labelOptic = #schema % #maxItems
296− {-# INLINE labelOptic #-}
297−
298−-- #minItems
299−
300−instance
301− ( a ~ Maybe Integer, b ~ Maybe Integer
302− ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where
303− labelOptic = #schema % #minItems
304− {-# INLINE labelOptic #-}
305−
306−-- #uniqueItems
307−
308−instance
309− ( a ~ Maybe Bool, b ~ Maybe Bool
310− ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where
311− labelOptic = #schema % #uniqueItems
312− {-# INLINE labelOptic #-}
313−
314−-- #enum
315−
316−instance
317− ( a ~ Maybe [Value], b ~ Maybe [Value]
318− ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where
319− labelOptic = #schema % #enum
320− {-# INLINE labelOptic #-}
321−
322−-- #multipleOf
323−
324−instance
325− ( a ~ Maybe Scientific, b ~ Maybe Scientific
326− ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where
327− labelOptic = #schema % #multipleOf
328− {-# INLINE labelOptic #-}
src/Data/OpenApi/Schema/Generator.hsdeleted−117
@@ -1,117 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE OverloadedLists #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.OpenApi.Schema.Generator where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens.Operators
11−import Control.Monad (filterM)
12−import Data.Aeson
13−import Data.Aeson.Types
14−import qualified Data.HashMap.Strict.InsOrd as M
15−import Data.Maybe
16−import Data.Proxy
17−import Data.Scientific
18−import qualified Data.Set as S
19−import Data.OpenApi
20−import Data.OpenApi.Declare
21−import Data.OpenApi.Internal.Schema.Validation (inferSchemaTypes)
22−import qualified Data.Text as T
23−import qualified Data.Vector as V
24−import Test.QuickCheck (arbitrary)
25−import Test.QuickCheck.Gen
26−import Test.QuickCheck.Property
27−
28−import Data.OpenApi.Aeson.Compat (fromInsOrdHashMap)
29−
30−-- | Note: 'schemaGen' may 'error', if schema type is not specified,
31−-- and cannot be inferred.
32−schemaGen :: Definitions Schema -> Schema -> Gen Value
33−schemaGen _ schema
34− | Just cases <- schema ^. enum_ = elements cases
35−schemaGen defns schema
36− | Just variants <- schema ^. oneOf = schemaGen defns =<< elements (dereference defns <$> variants)
37−schemaGen defns schema =
38− case schema ^. type_ of
39− Nothing ->
40− case inferSchemaTypes schema of
41− [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
42− -- Gen is not MonadFail
43− _ -> error "unable to infer schema type"
44− Just OpenApiBoolean -> Bool <$> elements [True, False]
45− Just OpenApiNull -> pure Null
46− Just OpenApiNumber
47− | Just min <- schema ^. minimum_
48− , Just max <- schema ^. maximum_ ->
49− Number . fromFloatDigits <$>
50− choose (toRealFloat min, toRealFloat max :: Double)
51− | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
52− Just OpenApiInteger
53− | Just min <- schema ^. minimum_
54− , Just max <- schema ^. maximum_ ->
55− Number . fromInteger <$>
56− choose (truncate min, truncate max)
57− | otherwise -> Number . fromInteger <$> arbitrary
58− Just OpenApiArray
59− | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
60− | Just items <- schema ^. items ->
61− case items of
62− OpenApiItemsObject ref -> do
63− size <- getSize
64− let itemSchema = dereference defns ref
65− minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems
66− maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems
67− arrayLength <- choose (minLength', max minLength' maxLength')
68− generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema
69− return . Array $ V.fromList generatedArray
70− OpenApiItemsArray refs ->
71− let itemGens = schemaGen defns . dereference defns <$> refs
72− in fmap (Array . V.fromList) $ sequence itemGens
73− Just OpenApiString -> do
74− size <- getSize
75− let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
76− let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
77− length <- choose (minLength', max minLength' maxLength')
78− str <- vectorOf length arbitrary
79− return . String $ T.pack str
80− Just OpenApiObject -> do
81− size <- getSize
82− let props = dereference defns <$> schema ^. properties
83− reqKeys = S.fromList $ schema ^. required
84− allKeys = S.fromList . M.keys $ schema ^. properties
85− optionalKeys = allKeys S.\\ reqKeys
86− minProps' = fromMaybe (length reqKeys) $
87− fromInteger <$> schema ^. minProperties
88− maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties
89− shuffledOptional <- shuffle $ S.toList optionalKeys
90− numProps <- choose (minProps', max minProps' maxProps')
91− let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional
92− let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props
93− let gens = schemaGen defns <$> presentProps
94− additionalGens <- case schema ^. additionalProperties of
95− Just (AdditionalPropertiesSchema addlSchema) -> do
96− additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary
97− return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)
98− _ -> return []
99− x <- sequence $ gens <> additionalGens
100− return . Object $ fromInsOrdHashMap x
101−
102−dereference :: Definitions a -> Referenced a -> a
103−dereference _ (Inline a) = a
104−dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
105−
106−genValue :: (ToSchema a) => Proxy a -> Gen Value
107−genValue p =
108− let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty
109− in schemaGen defs schema
110−
111−validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
112−validateFromJSON p = forAll (genValue p) $
113− \val -> case parseEither parseJSON val of
114− Right (_ :: a) -> succeeded
115− Left err -> failed
116− { reason = err
117− }
src/Data/OpenApi/Schema/Validation.hsdeleted−90
@@ -1,90 +0,0 @@
1−-- |
2−-- Module: Data.OpenApi.Schema.Validation
3−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4−-- Stability: experimental
5−--
6−-- Validate JSON values with Swagger Schema.
7−module Data.OpenApi.Schema.Validation (
8− -- * How to use validation
9− -- $howto
10−
11− -- ** Examples
12− -- $examples
13−
14− -- ** Validating @'Maybe'@
15− -- $maybe
16−
17− -- * JSON validation
18−
19− ValidationError,
20−
21− -- ** Using 'ToJSON' and 'ToSchema'
22− validatePrettyToJSON,
23− validateToJSON,
24− validateToJSONWithPatternChecker,
25− renderValidationErrors,
26−
27− -- ** Using 'Value' and 'Schema'
28− validateJSON,
29− validateJSONWithPatternChecker,
30−) where
31−
32−import Data.OpenApi.Internal.Schema.Validation
33−
34−-- $setup
35−-- >>> import Control.Lens
36−-- >>> import Data.Aeson
37−-- >>> import Data.Proxy
38−-- >>> import Data.OpenApi
39−-- >>> import GHC.Generics
40−-- >>> :set -XDeriveGeneric
41−
42−-- $howto
43−--
44−-- This module provides helpful functions for JSON validation.
45−-- These functions are meant to be used in test suites for your application
46−-- to ensure that JSON respresentation for your data corresponds to
47−-- schemas you're using for the Swagger specification.
48−--
49−-- It is recommended to use validation functions as QuickCheck properties
50−-- (see <http://hackage.haskell.org/package/QuickCheck>).
51−
52−-- $examples
53−--
54−-- >>> validateToJSON "hello"
55−-- []
56−--
57−-- >>> validateToJSON False
58−-- []
59−--
60−-- >>> newtype Nat = Nat Integer deriving Generic
61−-- >>> instance ToJSON Nat where toJSON (Nat n) = toJSON n
62−-- >>> instance ToSchema Nat where declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy & mapped.minimum_ ?~ 0
63−-- >>> validateToJSON (Nat 10)
64−-- []
65−-- >>> validateToJSON (Nat (-5))
66−-- ["value -5.0 falls below minimum (should be >=0.0)"]
67−
68−-- $maybe
69−--
70−-- Because @'Maybe' a@ has the same schema as @a@, validation
71−-- generally fails for @null@ JSON:
72−--
73−-- >>> validateToJSON (Nothing :: Maybe String)
74−-- ["expected JSON value of type OpenApiString"]
75−-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])
76−-- ["expected JSON value of type OpenApiString"]
77−-- >>> validateToJSON (123, Nothing :: Maybe String)
78−-- ["expected JSON value of type OpenApiString"]
79−--
80−-- However, when @'Maybe' a@ is a type of a record field,
81−-- validation takes @'required'@ property of the @'Schema'@
82−-- into account:
83−--
84−-- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic
85−-- >>> instance ToJSON Person
86−-- >>> instance ToSchema Person
87−-- >>> validateToJSON (Person "Nick" (Just 24))
88−-- []
89−-- >>> validateToJSON (Person "Nick" Nothing)
90−-- []
src/Data/OpenApi/SchemaOptions.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE RecordWildCards #-}
2−-- |
3−-- Module: Data.OpenApi.SchemaOptions
4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5−-- Stability: experimental
6−--
7−-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.
8−module Data.OpenApi.SchemaOptions where
9−
10−import qualified Data.Aeson.Types as Aeson
11−
12−-- | Options that specify how to encode your type to Swagger schema.
13−data SchemaOptions = SchemaOptions
14− { -- | Function applied to field labels. Handy for removing common record prefixes for example.
15− fieldLabelModifier :: String -> String
16− -- | Function applied to constructor tags which could be handy for lower-casing them for example.
17− , constructorTagModifier :: String -> String
18− -- | Function applied to datatype name.
19− , datatypeNameModifier :: String -> String
20− -- | If @'True'@ the constructors of a datatype, with all nullary constructors,
21− -- will be encoded to a string enumeration schema with the constructor tags as possible values.
22− , allNullaryToStringTag :: Bool
23− -- | Hide the field name when a record constructor has only one field, like a newtype.
24− , unwrapUnaryRecords :: Bool
25− -- | Specifies how to encode constructors of a sum datatype.
26− , sumEncoding :: Aeson.SumEncoding
27− }
28−
29−-- | Default encoding @'SchemaOptions'@.
30−--
31−-- @
32−-- 'SchemaOptions'
33−-- { 'fieldLabelModifier' = id
34−-- , 'constructorTagModifier' = id
35−-- , 'datatypeNameModifier' = id
36−-- , 'allNullaryToStringTag' = True
37−-- , 'unwrapUnaryRecords' = False
38−-- , 'sumEncoding' = 'Aeson.defaultTaggedObject'
39−-- }
40−-- @
41−defaultSchemaOptions :: SchemaOptions
42−defaultSchemaOptions = SchemaOptions
43− { fieldLabelModifier = id
44− , constructorTagModifier = id
45− , datatypeNameModifier = id
46− , allNullaryToStringTag = True
47− , unwrapUnaryRecords = False
48− , sumEncoding = Aeson.defaultTaggedObject
49− }
50−
51−-- | Convert 'Aeson.Options' to 'SchemaOptions'.
52−--
53−-- Specifically the following fields get copied:
54−--
55−-- * 'fieldLabelModifier'
56−-- * 'constructorTagModifier'
57−-- * 'allNullaryToStringTag'
58−-- * 'unwrapUnaryRecords'
59−--
60−-- Note that these fields have no effect on `SchemaOptions`:
61−--
62−-- * 'Aeson.omitNothingFields'
63−-- * 'Aeson.tagSingleConstructors'
64−--
65−-- The rest is defined as in 'defaultSchemaOptions'.
66−--
67−-- @since 2.2.1
68−--
69−fromAesonOptions :: Aeson.Options -> SchemaOptions
70−fromAesonOptions opts = defaultSchemaOptions
71− { fieldLabelModifier = Aeson.fieldLabelModifier opts
72− , constructorTagModifier = Aeson.constructorTagModifier opts
73− , allNullaryToStringTag = Aeson.allNullaryToStringTag opts
74− , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts
75− , sumEncoding = Aeson.sumEncoding opts
76− }
src/Data/Swagger.hsnew file+259
@@ -0,0 +1,259 @@
1+-- |
2+-- Swagger™ is a project used to describe and document RESTful APIs.
3+--
4+-- The Swagger specification defines a set of files required to describe such an API.
5+-- These files can then be used by the Swagger-UI project to display the API
6+-- and Swagger-Codegen to generate clients in various languages.
7+-- Additional utilities can also take advantage of the resulting files, such as testing tools.
8+module Data.Swagger (
9+ -- * How to use this library
10+ -- $howto
11+
12+ -- ** @'Monoid'@ instances
13+ -- $monoids
14+
15+ -- ** Lenses and prisms
16+ -- $lens
17+
18+ -- ** Schema specification
19+ -- $schema
20+
21+ -- * Re-exports
22+ module Data.Swagger.Lens,
23+ module Data.Swagger.ParamSchema,
24+ module Data.Swagger.Schema,
25+
26+ -- * Swagger specification
27+ Swagger(..),
28+ Host(..),
29+ Scheme(..),
30+
31+ -- ** Info types
32+ Info(..),
33+ Contact(..),
34+ License(..),
35+
36+ -- ** PathItem
37+ PathItem(..),
38+
39+ -- ** Operations
40+ Operation(..),
41+ Tag(..),
42+ TagName,
43+
44+ -- ** Types and formats
45+ SwaggerType(..),
46+ Format,
47+ Definitions,
48+ CollectionFormat(..),
49+
50+ -- ** Parameters
51+ Param(..),
52+ ParamAnySchema(..),
53+ ParamOtherSchema(..),
54+ ParamLocation(..),
55+ ParamName,
56+ Header(..),
57+ HeaderName,
58+ Example(..),
59+
60+ -- ** Schemas
61+ ParamSchema(..),
62+ Schema(..),
63+ NamedSchema(..),
64+ SwaggerItems(..),
65+ Xml(..),
66+
67+ -- ** Responses
68+ Responses(..),
69+ Response(..),
70+ HttpStatusCode,
71+
72+ -- ** Security
73+ SecurityScheme(..),
74+ SecuritySchemeType(..),
75+ SecurityRequirement(..),
76+
77+ -- *** API key
78+ ApiKeyParams(..),
79+ ApiKeyLocation(..),
80+
81+ -- *** OAuth2
82+ OAuth2Params(..),
83+ OAuth2Flow(..),
84+ AuthorizationURL,
85+ TokenURL,
86+
87+ -- ** External documentation
88+ ExternalDocs(..),
89+
90+ -- ** References
91+ Reference(..),
92+ Referenced(..),
93+
94+ -- ** Miscellaneous
95+ MimeList(..),
96+ URL(..),
97+) where
98+
99+import Data.Swagger.Lens
100+import Data.Swagger.ParamSchema
101+import Data.Swagger.Schema
102+
103+import Data.Swagger.Internal
104+
105+-- $setup
106+-- >>> import Control.Lens
107+-- >>> import Data.Aeson
108+-- >>> import Data.Monoid
109+-- >>> import Data.Proxy
110+-- >>> import GHC.Generics
111+-- >>> :set -XDeriveGeneric
112+-- >>> :set -XOverloadedStrings
113+-- >>> :set -XOverloadedLists
114+-- >>> :set -fno-warn-missing-methods
115+
116+-- $howto
117+--
118+-- This section explains how to use this library to work with Swagger specification.
119+
120+-- $monoids
121+--
122+-- Virtually all types representing Swagger specification have @'Monoid'@ instances.
123+-- The @'Monoid'@ type class provides two methods — @'mempty'@ and @'mappend'@.
124+--
125+-- In this library you can use @'mempty'@ for a default/empty value. For instance:
126+--
127+-- >>> encode (mempty :: Swagger)
128+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"}}"
129+--
130+-- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty.
131+-- That is because these properties are actually required ones.
132+--
133+-- You /should/ always override the default (empty) value for these properties,
134+-- although it is not strictly necessary:
135+--
136+-- >>> encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" }
137+-- "{\"version\":\"1.0\",\"title\":\"Todo API\"}"
138+--
139+-- You can merge two values using @'mappend'@ or its infix version @('<>')@:
140+--
141+-- >>> encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" }
142+-- "{\"version\":\"1.0\",\"title\":\"Todo API\"}"
143+--
144+-- This can be useful for combining specifications of endpoints into a whole API specification:
145+--
146+-- @
147+-- \-\- /account subAPI specification
148+-- accountAPI :: Swagger
149+--
150+-- \-\- /task subAPI specification
151+-- taskAPI :: Swagger
152+--
153+-- \-\- while API specification is just a combination
154+-- \-\- of subAPIs' specifications
155+-- api :: Swagger
156+-- api = accountAPI <> taskAPI
157+-- @
158+
159+-- $lens
160+--
161+-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
162+-- to work comfortly with it. In combination with @'Monoid'@ instances, lenses
163+-- make it fairly simple to construct/modify any part of the specification:
164+--
165+-- >>> :{
166+-- encode $ (mempty :: Swagger)
167+-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]
168+-- & paths .~
169+-- [ ("/user", mempty & get ?~ (mempty
170+-- & produces ?~ MimeList ["application/json"]
171+-- & at 200 ?~ Inline (mempty & schema ?~ Ref (Reference "User")))) ]
172+-- :}
173+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"]}}}}"
174+--
175+-- In the snippet above we declare API with a single path @/user@ providing method @GET@
176+-- which produces @application/json@ output and should respond with code @200@ and body specified
177+-- by schema @User@ which is defined in @'definitions'@ property of swagger specification.
178+--
179+-- For convenience, @swagger2@ uses /classy field lenses/. It means that
180+-- field accessor names can be overloaded for different types. One such
181+-- common field is @'description'@. Many components of Swagger specification
182+-- can have descriptions, and you can use the same name for them:
183+--
184+-- >>> encode $ (mempty :: Response) & description .~ "No content"
185+-- "{\"description\":\"No content\"}"
186+-- >>> :{
187+-- encode $ (mempty :: Schema)
188+-- & type_ .~ SwaggerBoolean
189+-- & description ?~ "To be or not to be"
190+-- :}
191+-- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}"
192+--
193+-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).
194+-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
195+-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
196+--
197+-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber
198+-- "{\"type\":\"number\"}"
199+--
200+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
201+-- have direct access to it via @'at' code@. Example:
202+--
203+-- >>> :{
204+-- encode $ (mempty :: Operation)
205+-- & at 404 ?~ Inline (mempty & description .~ "Not found")
206+-- :}
207+-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"
208+--
209+-- You might've noticed that @'type_'@ has an extra underscore in its name
210+-- compared to, say, @'description'@ field accessor.
211+-- This is because @type@ is a keyword in Haskell.
212+-- A few other field accessors are modified in this way:
213+--
214+-- - @'in_'@, @'type_'@, @'default_'@ (as keywords);
215+-- - @'maximum_'@ and @'minimum_'@ (as conflicting with @Prelude@);
216+-- - @'enum_'@ (as conflicting with @Control.Lens@).
217+
218+-- $schema
219+--
220+-- @'ParamSchema'@ and @'Schema'@ are the two core types for data model specification.
221+--
222+-- @'ParamSchema' t@ specifies all the common properties, available for every data schema.
223+-- The @t@ parameter imposes some restrictions on @type@ and @items@ properties (see @'SwaggerType'@ and @'SwaggerItems'@).
224+--
225+-- @'Schema'@ is used for request and response bodies and allows specifying objects
226+-- with properties in addition to what @'ParamSchema'@ provides.
227+--
228+-- In most cases you will have a Haskell data type for which you would like to
229+-- define a corresponding schema. To facilitate this use case
230+-- @swagger2@ provides two classes for schema encoding.
231+-- Both these classes provide means to encode /types/ as Swagger /schemas/.
232+--
233+-- @'ToParamSchema'@ is intended to be used for primitive API endpoint parameters,
234+-- such as query parameters, headers and URL path pieces.
235+-- Its corresponding value-encoding class is @'ToHttpApiData'@ (from @http-api-data@ package).
236+--
237+-- @'ToSchema'@ is used for request and response bodies and mostly differ from
238+-- primitive parameters by allowing objects/mappings in addition to primitive types and arrays.
239+-- Its corresponding value-encoding class is @'ToJSON'@ (from @aeson@ package).
240+--
241+-- While lenses and prisms make it easy to define schemas, it might be that you don't need to:
242+-- @'ToSchema'@ and @'ToParamSchema'@ classes both have default @'Generic'@-based implementations!
243+--
244+-- @'ToSchema'@ default implementation is also aligned with @'ToJSON'@ default implementation with
245+-- the only difference being for sum encoding. @'ToJSON'@ defaults sum encoding to @'defaultTaggedObject'@,
246+-- while @'ToSchema'@ defaults to something which corresponds to @'ObjectWithSingleField'@. This is due to
247+-- @'defaultTaggedObject'@ behavior being hard to specify in Swagger.
248+--
249+-- Here's an example showing @'ToJSON'@–@'ToSchema'@ correspondance:
250+--
251+-- >>> data Person = Person { name :: String, age :: Integer } deriving Generic
252+-- >>> instance ToJSON Person
253+-- >>> instance ToSchema Person
254+-- >>> encode (Person "David" 28)
255+-- "{\"age\":28,\"name\":\"David\"}"
256+-- >>> encode $ toSchema (Proxy :: Proxy Person)
257+-- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}"
258+--
259+
src/Data/OpenApi/Declare.hs → src/Data/Swagger/Declare.hsrenamed+12−89
@@ -2,33 +2,12 @@
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FunctionalDependencies #-}
3{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE UndecidableInstances #-}
6−-- |
7−-- Module: Data.OpenApi.Declare
8−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
9−-- Stability: experimental
10−--
11−-- Declare monad transformer and associated functions.
12−module Data.OpenApi.Declare where
5+module Data.Swagger.Declare where
13−
14−import Prelude ()
15−import Prelude.Compat
16
6
17import Control.Monad
7import Control.Monad
18−import Control.Monad.Cont (ContT)
19−import Control.Monad.List (ListT)
20−import Control.Monad.Reader (ReaderT)
21import Control.Monad.Trans
8import Control.Monad.Trans
22−import Control.Monad.Trans.Except (ExceptT)
23−import Control.Monad.Trans.Identity (IdentityT)
24−import Control.Monad.Trans.Maybe (MaybeT)
25−import Control.Monad.Trans.State.Lazy as Lazy
26−import Control.Monad.Trans.State.Strict as Strict
27−import Control.Monad.Trans.RWS.Lazy as Lazy
28−import Control.Monad.Trans.RWS.Strict as Strict
29−import Control.Monad.Trans.Writer.Lazy as Lazy
30−import Control.Monad.Trans.Writer.Strict as Strict
31import Data.Functor.Identity
9import Data.Functor.Identity
10+import Data.Monoid
32
11
33-- | A declare monad transformer parametrized by:
12-- | A declare monad transformer parametrized by:
34--
13--
@@ -45,19 +24,19 @@ import Data.Functor.Identity
45newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
24newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
46 deriving (Functor)
25 deriving (Functor)
47
26
48−instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
27+instance (Monad m, Monoid d) => Applicative (DeclareT d m) where
49 pure x = DeclareT (\_ -> pure (mempty, x))
28 pure x = DeclareT (\_ -> pure (mempty, x))
50 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
29 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
51 ~(d', f) <- df d
30 ~(d', f) <- df d
52− ~(d'', x) <- dx (mappend d d')
31+ ~(d'', x) <- dx (d <> d')
53− return (mappend d' d'', f x)
32+ return (d' <> d'', f x)
54
33
55−instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
34+instance (Monad m, Monoid d) => Monad (DeclareT d m) where
56 return x = DeclareT (\_ -> pure (mempty, x))
35 return x = DeclareT (\_ -> pure (mempty, x))
57 DeclareT dx >>= f = DeclareT $ \d -> do
36 DeclareT dx >>= f = DeclareT $ \d -> do
58 ~(d', x) <- dx d
37 ~(d', x) <- dx d
59− ~(d'', y) <- runDeclareT (f x) (mappend d d')
38+ ~(d'', y) <- runDeclareT (f x) (d <> d')
60− return (mappend d' d'', y)
39+ return (d' <> d'', y)
61
40
62instance Monoid d => MonadTrans (DeclareT d) where
41instance Monoid d => MonadTrans (DeclareT d) where
63 lift m = DeclareT (\_ -> (,) mempty <$> m)
42 lift m = DeclareT (\_ -> (,) mempty <$> m)
@@ -79,23 +58,16 @@ instance Monoid d => MonadTrans (DeclareT d) where
79-- [/@look@ as left identity/]
58-- [/@look@ as left identity/]
80-- @'look' >> m == m@
59-- @'look' >> m == m@
81-- for every @m@
60-- for every @m@
82−class (Applicative m, Monad m) => MonadDeclare d m | m -> d where
61+class Monad m => MonadDeclare d m | m -> d where
83 -- | @'declare' x@ is an action that produces the output @x@.
62 -- | @'declare' x@ is an action that produces the output @x@.
84 declare :: d -> m ()
63 declare :: d -> m ()
85 -- | @'look'@ is an action that returns all the output so far.
64 -- | @'look'@ is an action that returns all the output so far.
86 look :: m d
65 look :: m d
87
66
88−instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
67+instance (Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
89 declare d = DeclareT (\_ -> return (d, ()))
68 declare d = DeclareT (\_ -> return (d, ()))
90 look = DeclareT (\d -> return (mempty, d))
69 look = DeclareT (\d -> return (mempty, d))
91
70
92−-- | Lift a computation from the simple Declare monad.
93−liftDeclare :: MonadDeclare d m => Declare d a -> m a
94−liftDeclare da = do
95− (d', a) <- looks (runDeclare da)
96− declare d'
97− pure a
98−
99-- | Retrieve a function of all the output so far.
71-- | Retrieve a function of all the output so far.
100looks :: MonadDeclare d m => (d -> a) -> m a
72looks :: MonadDeclare d m => (d -> a) -> m a
101looks f = f <$> look
73looks f = f <$> look
@@ -103,12 +75,12 @@ looks f = f <$> look
103-- | Evaluate @'DeclareT' d m a@ computation,
75-- | Evaluate @'DeclareT' d m a@ computation,
104-- ignoring new output @d@.
76-- ignoring new output @d@.
105evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
77evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
106−evalDeclareT (DeclareT f) d = snd <$> f d
78+evalDeclareT (DeclareT f) d = snd `liftM` f d
107
79
108-- | Execute @'DeclateT' d m a@ computation,
80-- | Execute @'DeclateT' d m a@ computation,
109-- ignoring result and only producing new output @d@.
81-- ignoring result and only producing new output @d@.
110execDeclareT :: Monad m => DeclareT d m a -> d -> m d
82execDeclareT :: Monad m => DeclareT d m a -> d -> m d
111−execDeclareT (DeclareT f) d = fst <$> f d
83+execDeclareT (DeclareT f) d = fst `liftM` f d
112
84
113-- | Evaluate @'DeclareT' d m a@ computation,
85-- | Evaluate @'DeclareT' d m a@ computation,
114-- starting with empty output history.
86-- starting with empty output history.
@@ -144,52 +116,3 @@ execDeclare m = runIdentity . execDeclareT m
144undeclare :: Monoid d => Declare d a -> a
116undeclare :: Monoid d => Declare d a -> a
145undeclare = runIdentity . undeclareT
117undeclare = runIdentity . undeclareT
146
118
147−-- ---------------------------------------------------------------------------
148−-- Instances for other mtl transformers
149−--
150−-- All of these instances need UndecidableInstances,
151−-- because they do not satisfy the coverage condition.
152−
153−instance MonadDeclare d m => MonadDeclare d (ContT r m) where
154− declare = lift . declare
155− look = lift look
156−
157−instance MonadDeclare d m => MonadDeclare d (ExceptT e m) where
158− declare = lift . declare
159− look = lift look
160−
161−instance MonadDeclare d m => MonadDeclare d (IdentityT m) where
162− declare = lift . declare
163− look = lift look
164−
165−instance MonadDeclare d m => MonadDeclare d (MaybeT m) where
166− declare = lift . declare
167− look = lift look
168−
169−instance MonadDeclare d m => MonadDeclare d (ReaderT r m) where
170− declare = lift . declare
171− look = lift look
172−
173−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.RWST r w s m) where
174− declare = lift . declare
175− look = lift look
176−
177−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.RWST r w s m) where
178− declare = lift . declare
179− look = lift look
180−
181−instance MonadDeclare d m => MonadDeclare d (Lazy.StateT s m) where
182− declare = lift . declare
183− look = lift look
184−
185−instance MonadDeclare d m => MonadDeclare d (Strict.StateT s m) where
186− declare = lift . declare
187− look = lift look
188−
189−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.WriterT w m) where
190− declare = lift . declare
191− look = lift look
192−
193−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.WriterT w m) where
194− declare = lift . declare
195− look = lift look
src/Data/Swagger/Internal.hsnew file+1161
@@ -0,0 +1,1161 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RecordWildCards #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+module Data.Swagger.Internal where
14+
15+import Control.Applicative
16+import Control.Monad
17+import Data.Aeson
18+import qualified Data.Aeson.Types as JSON
19+import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
20+import Data.HashMap.Strict (HashMap)
21+import qualified Data.HashMap.Strict as HashMap
22+import Data.Map (Map)
23+import qualified Data.Map as Map
24+import Data.Monoid
25+import Data.Scientific (Scientific)
26+import Data.String (fromString)
27+import Data.Text (Text)
28+import qualified Data.Text as Text
29+import GHC.Generics (Generic)
30+import Network (HostName, PortNumber)
31+import Network.HTTP.Media (MediaType)
32+import Text.Read (readMaybe)
33+
34+import Data.Swagger.Internal.Utils
35+
36+-- | A list of definitions that can be used in references.
37+type Definitions = HashMap Text
38+
39+-- | This is the root document object for the API specification.
40+data Swagger = Swagger
41+ { -- | Provides metadata about the API.
42+ -- The metadata can be used by the clients if needed.
43+ _swaggerInfo :: Info
44+
45+ -- | The host (name or ip) serving the API. It MAY include a port.
46+ -- If the host is not included, the host serving the documentation is to be used (including the port).
47+ , _swaggerHost :: Maybe Host
48+
49+ -- | The base path on which the API is served, which is relative to the host.
50+ -- If it is not included, the API is served directly under the host.
51+ -- The value MUST start with a leading slash (/).
52+ , _swaggerBasePath :: Maybe FilePath
53+
54+ -- | The transfer protocol of the API.
55+ -- If the schemes is not included, the default scheme to be used is the one used to access the Swagger definition itself.
56+ , _swaggerSchemes :: Maybe [Scheme]
57+
58+ -- | A list of MIME types the APIs can consume.
59+ -- This is global to all APIs but can be overridden on specific API calls.
60+ , _swaggerConsumes :: MimeList
61+
62+ -- | A list of MIME types the APIs can produce.
63+ -- This is global to all APIs but can be overridden on specific API calls.
64+ , _swaggerProduces :: MimeList
65+
66+ -- | The available paths and operations for the API.
67+ -- Holds the relative paths to the individual endpoints.
68+ -- The path is appended to the @'basePath'@ in order to construct the full URL.
69+ , _swaggerPaths :: HashMap FilePath PathItem
70+
71+ -- | An object to hold data types produced and consumed by operations.
72+ , _swaggerDefinitions :: Definitions Schema
73+
74+ -- | An object to hold parameters that can be used across operations.
75+ -- This property does not define global parameters for all operations.
76+ , _swaggerParameters :: Definitions Param
77+
78+ -- | An object to hold responses that can be used across operations.
79+ -- This property does not define global responses for all operations.
80+ , _swaggerResponses :: Definitions Response
81+
82+ -- | Security scheme definitions that can be used across the specification.
83+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme
84+
85+ -- | A declaration of which security schemes are applied for the API as a whole.
86+ -- The list of values describes alternative security schemes that can be used
87+ -- (that is, there is a logical OR between the security requirements).
88+ -- Individual operations can override this definition.
89+ , _swaggerSecurity :: [SecurityRequirement]
90+
91+ -- | A list of tags used by the specification with additional metadata.
92+ -- The order of the tags can be used to reflect on their order by the parsing tools.
93+ -- Not all tags that are used by the Operation Object must be declared.
94+ -- The tags that are not declared may be organized randomly or based on the tools' logic.
95+ -- Each tag name in the list MUST be unique.
96+ , _swaggerTags :: [Tag]
97+
98+ -- | Additional external documentation.
99+ , _swaggerExternalDocs :: Maybe ExternalDocs
100+ } deriving (Eq, Show, Generic, Data, Typeable)
101+
102+-- | The object provides metadata about the API.
103+-- The metadata can be used by the clients if needed,
104+-- and can be presented in the Swagger-UI for convenience.
105+data Info = Info
106+ { -- | The title of the application.
107+ _infoTitle :: Text
108+
109+ -- | A short description of the application.
110+ -- GFM syntax can be used for rich text representation.
111+ , _infoDescription :: Maybe Text
112+
113+ -- | The Terms of Service for the API.
114+ , _infoTermsOfService :: Maybe Text
115+
116+ -- | The contact information for the exposed API.
117+ , _infoContact :: Maybe Contact
118+
119+ -- | The license information for the exposed API.
120+ , _infoLicense :: Maybe License
121+
122+ -- | Provides the version of the application API
123+ -- (not to be confused with the specification version).
124+ , _infoVersion :: Text
125+ } deriving (Eq, Show, Generic, Data, Typeable)
126+
127+-- | Contact information for the exposed API.
128+data Contact = Contact
129+ { -- | The identifying name of the contact person/organization.
130+ _contactName :: Maybe Text
131+
132+ -- | The URL pointing to the contact information.
133+ , _contactUrl :: Maybe URL
134+
135+ -- | The email address of the contact person/organization.
136+ , _contactEmail :: Maybe Text
137+ } deriving (Eq, Show, Generic, Data, Typeable)
138+
139+-- | License information for the exposed API.
140+data License = License
141+ { -- | The license name used for the API.
142+ _licenseName :: Text
143+
144+ -- | A URL to the license used for the API.
145+ , _licenseUrl :: Maybe URL
146+ } deriving (Eq, Show, Generic, Data, Typeable)
147+
148+-- | The host (name or ip) serving the API. It MAY include a port.
149+data Host = Host
150+ { _hostName :: HostName -- ^ Host name.
151+ , _hostPort :: Maybe PortNumber -- ^ Optional port.
152+ } deriving (Eq, Show, Generic, Typeable)
153+
154+hostConstr :: Constr
155+hostConstr = mkConstr hostDataType "Host" [] Prefix
156+
157+hostDataType :: DataType
158+hostDataType = mkDataType "Data.Swagger.Host" [hostConstr]
159+
160+instance Data Host where
161+ gunfold k z c = case constrIndex c of
162+ 1 -> k (k (z (\name mport -> Host name (fromInteger <$> mport))))
163+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Host."
164+ toConstr (Host _ _) = hostConstr
165+ dataTypeOf _ = hostDataType
166+
167+-- | The transfer protocol of the API.
168+data Scheme
169+ = Http
170+ | Https
171+ | Ws
172+ | Wss
173+ deriving (Eq, Show, Generic, Data, Typeable)
174+
175+-- | Describes the operations available on a single path.
176+-- A @'PathItem'@ may be empty, due to ACL constraints.
177+-- The path itself is still exposed to the documentation viewer
178+-- but they will not know which operations and parameters are available.
179+data PathItem = PathItem
180+ { -- | A definition of a GET operation on this path.
181+ _pathItemGet :: Maybe Operation
182+
183+ -- | A definition of a PUT operation on this path.
184+ , _pathItemPut :: Maybe Operation
185+
186+ -- | A definition of a POST operation on this path.
187+ , _pathItemPost :: Maybe Operation
188+
189+ -- | A definition of a DELETE operation on this path.
190+ , _pathItemDelete :: Maybe Operation
191+
192+ -- | A definition of a OPTIONS operation on this path.
193+ , _pathItemOptions :: Maybe Operation
194+
195+ -- | A definition of a HEAD operation on this path.
196+ , _pathItemHead :: Maybe Operation
197+
198+ -- | A definition of a PATCH operation on this path.
199+ , _pathItemPatch :: Maybe Operation
200+
201+ -- | A list of parameters that are applicable for all the operations described under this path.
202+ -- These parameters can be overridden at the operation level, but cannot be removed there.
203+ -- The list MUST NOT include duplicated parameters.
204+ -- A unique parameter is defined by a combination of a name and location.
205+ , _pathItemParameters :: [Referenced Param]
206+ } deriving (Eq, Show, Generic, Data, Typeable)
207+
208+-- | Describes a single API operation on a path.
209+data Operation = Operation
210+ { -- | A list of tags for API documentation control.
211+ -- Tags can be used for logical grouping of operations by resources or any other qualifier.
212+ _operationTags :: [TagName]
213+
214+ -- | A short summary of what the operation does.
215+ -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
216+ , _operationSummary :: Maybe Text
217+
218+ -- | A verbose explanation of the operation behavior.
219+ -- GFM syntax can be used for rich text representation.
220+ , _operationDescription :: Maybe Text
221+
222+ -- | Additional external documentation for this operation.
223+ , _operationExternalDocs :: Maybe ExternalDocs
224+
225+ -- | Unique string used to identify the operation.
226+ -- The id MUST be unique among all operations described in the API.
227+ -- Tools and libraries MAY use the it to uniquely identify an operation,
228+ -- therefore, it is recommended to follow common programming naming conventions.
229+ , _operationOperationId :: Maybe Text
230+
231+ -- | A list of MIME types the operation can consume.
232+ -- This overrides the @'consumes'@.
233+ -- @Just []@ MAY be used to clear the global definition.
234+ , _operationConsumes :: Maybe MimeList
235+
236+ -- | A list of MIME types the operation can produce.
237+ -- This overrides the @'produces'@.
238+ -- @Just []@ MAY be used to clear the global definition.
239+ , _operationProduces :: Maybe MimeList
240+
241+ -- | A list of parameters that are applicable for this operation.
242+ -- If a parameter is already defined at the @'PathItem'@,
243+ -- the new definition will override it, but can never remove it.
244+ -- The list MUST NOT include duplicated parameters.
245+ -- A unique parameter is defined by a combination of a name and location.
246+ , _operationParameters :: [Referenced Param]
247+
248+ -- | The list of possible responses as they are returned from executing this operation.
249+ , _operationResponses :: Responses
250+
251+ -- | The transfer protocol for the operation.
252+ -- The value overrides @'schemes'@.
253+ , _operationSchemes :: Maybe [Scheme]
254+
255+ -- | Declares this operation to be deprecated.
256+ -- Usage of the declared operation should be refrained.
257+ -- Default value is @False@.
258+ , _operationDeprecated :: Maybe Bool
259+
260+ -- | A declaration of which security schemes are applied for this operation.
261+ -- The list of values describes alternative security schemes that can be used
262+ -- (that is, there is a logical OR between the security requirements).
263+ -- This definition overrides any declared top-level security.
264+ -- To remove a top-level security declaration, @Just []@ can be used.
265+ , _operationSecurity :: [SecurityRequirement]
266+ } deriving (Eq, Show, Generic, Data, Typeable)
267+
268+newtype MimeList = MimeList { getMimeList :: [MediaType] }
269+ deriving (Eq, Show, Monoid, Typeable)
270+
271+mimeListConstr :: Constr
272+mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
273+
274+mimeListDataType :: DataType
275+mimeListDataType = mkDataType "Data.Swagger.MimeList" [mimeListConstr]
276+
277+instance Data MimeList where
278+ gunfold k z c = case constrIndex c of
279+ 1 -> k (z (\xs -> MimeList (map fromString xs)))
280+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MimeList."
281+ toConstr (MimeList _) = mimeListConstr
282+ dataTypeOf _ = mimeListDataType
283+
284+-- | Describes a single operation parameter.
285+-- A unique parameter is defined by a combination of a name and location.
286+data Param = Param
287+ { -- | The name of the parameter.
288+ -- Parameter names are case sensitive.
289+ _paramName :: Text
290+
291+ -- | A brief description of the parameter.
292+ -- This could contain examples of use.
293+ -- GFM syntax can be used for rich text representation.
294+ , _paramDescription :: Maybe Text
295+
296+ -- | Determines whether this parameter is mandatory.
297+ -- If the parameter is in "path", this property is required and its value MUST be true.
298+ -- Otherwise, the property MAY be included and its default value is @False@.
299+ , _paramRequired :: Maybe Bool
300+
301+ -- | Parameter schema.
302+ , _paramSchema :: ParamAnySchema
303+ } deriving (Eq, Show, Generic, Data, Typeable)
304+
305+data ParamAnySchema
306+ = ParamBody (Referenced Schema)
307+ | ParamOther ParamOtherSchema
308+ deriving (Eq, Show, Generic, Data, Typeable)
309+
310+data ParamOtherSchema = ParamOtherSchema
311+ { -- | The location of the parameter.
312+ _paramOtherSchemaIn :: ParamLocation
313+
314+ -- | Sets the ability to pass empty-valued parameters.
315+ -- This is valid only for either @'ParamQuery'@ or @'ParamFormData'@
316+ -- and allows you to send a parameter with a name only or an empty value.
317+ -- Default value is @False@.
318+ , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
319+
320+ , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
321+ } deriving (Eq, Show, Generic, Data, Typeable)
322+
323+-- | Items for @'SwaggerArray'@ schemas.
324+--
325+-- @'SwaggerItemsPrimitive'@ should be used only for query params, headers and path pieces.
326+-- The @'CollectionFormat' t@ parameter specifies how elements of an array should be displayed.
327+-- Note that @fmt@ in @'SwaggerItemsPrimitive' fmt schema@ specifies format for elements of type @schema@.
328+-- This is different from the original Swagger's <http://swagger.io/specification/#itemsObject Items Object>.
329+--
330+-- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s.
331+--
332+-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
333+data SwaggerItems t where
334+ SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t
335+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema
336+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema
337+
338+deriving instance Eq (SwaggerItems t)
339+deriving instance Show (SwaggerItems t)
340+deriving instance Typeable (SwaggerItems t)
341+
342+swaggerItemsPrimitiveConstr :: Constr
343+swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
344+
345+swaggerItemsDataType :: DataType
346+swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
347+
348+instance {-# OVERLAPPABLE #-} Data t => Data (SwaggerItems t) where
349+ gunfold k z c = case constrIndex c of
350+ 1 -> k (k (z SwaggerItemsPrimitive))
351+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
352+ toConstr _ = swaggerItemsPrimitiveConstr
353+ dataTypeOf _ = swaggerItemsDataType
354+
355+deriving instance Data (SwaggerItems Schema)
356+
357+data SwaggerType t where
358+ SwaggerString :: SwaggerType t
359+ SwaggerNumber :: SwaggerType t
360+ SwaggerInteger :: SwaggerType t
361+ SwaggerBoolean :: SwaggerType t
362+ SwaggerArray :: SwaggerType t
363+ SwaggerFile :: SwaggerType ParamOtherSchema
364+ SwaggerNull :: SwaggerType Schema
365+ SwaggerObject :: SwaggerType Schema
366+
367+deriving instance Eq (SwaggerType t)
368+deriving instance Show (SwaggerType t)
369+deriving instance Typeable (SwaggerType t)
370+
371+swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
372+swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
373+
374+swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
375+swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
376+
377+swaggerCommonTypes :: [SwaggerType t]
378+swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
379+
380+swaggerParamTypes :: [SwaggerType ParamOtherSchema]
381+swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
382+
383+swaggerSchemaTypes :: [SwaggerType Schema]
384+swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
385+
386+swaggerTypeConstrs :: [Constr]
387+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])
388+ ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
389+
390+instance {-# OVERLAPPABLE #-} Typeable t => Data (SwaggerType t) where
391+ gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
392+ toConstr = swaggerTypeConstr
393+ dataTypeOf = swaggerTypeDataType
394+
395+instance {-# OVERLAPPING #-} Data (SwaggerType ParamOtherSchema) where
396+ gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
397+ toConstr = swaggerTypeConstr
398+ dataTypeOf = swaggerTypeDataType
399+
400+instance {-# OVERLAPPING #-} Data (SwaggerType Schema) where
401+ gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
402+ toConstr = swaggerTypeConstr
403+ dataTypeOf = swaggerTypeDataType
404+
405+data ParamLocation
406+ = -- | Parameters that are appended to the URL.
407+ -- For example, in @/items?id=###@, the query parameter is @id@.
408+ ParamQuery
409+ -- | Custom headers that are expected as part of the request.
410+ | ParamHeader
411+ -- | Used together with Path Templating, where the parameter value is actually part of the operation's URL.
412+ -- This does not include the host or base path of the API.
413+ -- For example, in @/items/{itemId}@, the path parameter is @itemId@.
414+ | ParamPath
415+ -- | Used to describe the payload of an HTTP request when either @application/x-www-form-urlencoded@
416+ -- or @multipart/form-data@ are used as the content type of the request
417+ -- (in Swagger's definition, the @consumes@ property of an operation).
418+ -- This is the only parameter type that can be used to send files, thus supporting the @'ParamFile'@ type.
419+ -- Since form parameters are sent in the payload, they cannot be declared together with a body parameter for the same operation.
420+ -- Form parameters have a different format based on the content-type used
421+ -- (for further details, consult <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).
422+ | ParamFormData
423+ deriving (Eq, Show, Generic, Data, Typeable)
424+
425+type Format = Text
426+
427+-- | Determines the format of the array.
428+data CollectionFormat t where
429+ -- Comma separated values: @foo,bar@.
430+ CollectionCSV :: CollectionFormat t
431+ -- Space separated values: @foo bar@.
432+ CollectionSSV :: CollectionFormat t
433+ -- Tab separated values: @foo\\tbar@.
434+ CollectionTSV :: CollectionFormat t
435+ -- Pipe separated values: @foo|bar@.
436+ CollectionPipes :: CollectionFormat t
437+ -- Corresponds to multiple parameter instances
438+ -- instead of multiple values for a single instance @foo=bar&foo=baz@.
439+ -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
440+ CollectionMulti :: CollectionFormat ParamOtherSchema
441+
442+deriving instance Eq (CollectionFormat t)
443+deriving instance Show (CollectionFormat t)
444+deriving instance Typeable (CollectionFormat t)
445+
446+collectionFormatConstr :: CollectionFormat t -> Constr
447+collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix
448+
449+collectionFormatDataType :: DataType
450+collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
451+ map collectionFormatConstr collectionCommonFormats
452+
453+collectionCommonFormats :: [CollectionFormat t]
454+collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
455+
456+instance {-# OVERLAPPABLE #-} Data t => Data (CollectionFormat t) where
457+ gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
458+ toConstr = collectionFormatConstr
459+ dataTypeOf _ = collectionFormatDataType
460+
461+deriving instance {-# OVERLAPPING #-} Data (CollectionFormat ParamOtherSchema)
462+
463+type ParamName = Text
464+
465+data Schema = Schema
466+ { _schemaTitle :: Maybe Text
467+ , _schemaDescription :: Maybe Text
468+ , _schemaRequired :: [ParamName]
469+
470+ , _schemaAllOf :: Maybe [Schema]
471+ , _schemaProperties :: HashMap Text (Referenced Schema)
472+ , _schemaAdditionalProperties :: Maybe Schema
473+
474+ , _schemaDiscriminator :: Maybe Text
475+ , _schemaReadOnly :: Maybe Bool
476+ , _schemaXml :: Maybe Xml
477+ , _schemaExternalDocs :: Maybe ExternalDocs
478+ , _schemaExample :: Maybe Value
479+
480+ , _schemaMaxProperties :: Maybe Integer
481+ , _schemaMinProperties :: Maybe Integer
482+
483+ , _schemaParamSchema :: ParamSchema Schema
484+ } deriving (Eq, Show, Generic, Data, Typeable)
485+
486+-- | A @'Schema'@ with an optional name.
487+-- This name can be used in references.
488+data NamedSchema = NamedSchema
489+ { _namedSchemaName :: Maybe Text
490+ , _namedSchemaSchema :: Schema
491+ } deriving (Eq, Show, Generic, Data, Typeable)
492+
493+data ParamSchema t = ParamSchema
494+ { -- | Declares the value of the parameter that the server will use if none is provided,
495+ -- for example a @"count"@ to control the number of results per page might default to @100@
496+ -- if not supplied by the client in the request.
497+ -- (Note: "default" has no meaning for required parameters.)
498+ -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
499+ _paramSchemaDefault :: Maybe Value
500+
501+ , _paramSchemaType :: SwaggerType t
502+ , _paramSchemaFormat :: Maybe Format
503+ , _paramSchemaItems :: Maybe (SwaggerItems t)
504+ , _paramSchemaMaximum :: Maybe Scientific
505+ , _paramSchemaExclusiveMaximum :: Maybe Bool
506+ , _paramSchemaMinimum :: Maybe Scientific
507+ , _paramSchemaExclusiveMinimum :: Maybe Bool
508+ , _paramSchemaMaxLength :: Maybe Integer
509+ , _paramSchemaMinLength :: Maybe Integer
510+ , _paramSchemaPattern :: Maybe Text
511+ , _paramSchemaMaxItems :: Maybe Integer
512+ , _paramSchemaMinItems :: Maybe Integer
513+ , _paramSchemaUniqueItems :: Maybe Bool
514+ , _paramSchemaEnum :: Maybe [Value]
515+ , _paramSchemaMultipleOf :: Maybe Scientific
516+ } deriving (Eq, Show, Generic, Typeable)
517+
518+deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)
519+
520+data Xml = Xml
521+ { -- | Replaces the name of the element/attribute used for the described schema property.
522+ -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list.
523+ -- When defined alongside type being array (outside the items),
524+ -- it will affect the wrapping element and only if wrapped is true.
525+ -- If wrapped is false, it will be ignored.
526+ _xmlName :: Maybe Text
527+
528+ -- | The URL of the namespace definition.
529+ -- Value SHOULD be in the form of a URL.
530+ , _xmlNamespace :: Maybe Text
531+
532+ -- | The prefix to be used for the name.
533+ , _xmlPrefix :: Maybe Text
534+
535+ -- | Declares whether the property definition translates to an attribute instead of an element.
536+ -- Default value is @False@.
537+ , _xmlAttribute :: Maybe Bool
538+
539+ -- | MAY be used only for an array definition.
540+ -- Signifies whether the array is wrapped
541+ -- (for example, @\<books\>\<book/\>\<book/\>\</books\>@)
542+ -- or unwrapped (@\<book/\>\<book/\>@).
543+ -- Default value is @False@.
544+ -- The definition takes effect only when defined alongside type being array (outside the items).
545+ , _xmlWrapped :: Maybe Bool
546+ } deriving (Eq, Show, Generic, Data, Typeable)
547+
548+-- | A container for the expected responses of an operation.
549+-- The container maps a HTTP response code to the expected response.
550+-- It is not expected from the documentation to necessarily cover all possible HTTP response codes,
551+-- since they may not be known in advance.
552+-- However, it is expected from the documentation to cover a successful operation response and any known errors.
553+data Responses = Responses
554+ { -- | The documentation of responses other than the ones declared for specific HTTP response codes.
555+ -- It can be used to cover undeclared responses.
556+ _responsesDefault :: Maybe (Referenced Response)
557+
558+ -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
559+ -- Describes the expected response for those HTTP status codes.
560+ , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
561+ } deriving (Eq, Show, Generic, Data, Typeable)
562+
563+type HttpStatusCode = Int
564+
565+-- | Describes a single response from an API Operation.
566+data Response = Response
567+ { -- | A short description of the response.
568+ -- GFM syntax can be used for rich text representation.
569+ _responseDescription :: Text
570+
571+ -- | A definition of the response structure.
572+ -- It can be a primitive, an array or an object.
573+ -- If this field does not exist, it means no content is returned as part of the response.
574+ -- As an extension to the Schema Object, its root type value may also be "file".
575+ -- This SHOULD be accompanied by a relevant produces mime-type.
576+ , _responseSchema :: Maybe (Referenced Schema)
577+
578+ -- | A list of headers that are sent with the response.
579+ , _responseHeaders :: HashMap HeaderName Header
580+
581+ -- | An example of the response message.
582+ , _responseExamples :: Maybe Example
583+ } deriving (Eq, Show, Generic, Data, Typeable)
584+
585+type HeaderName = Text
586+
587+data Header = Header
588+ { -- | A short description of the header.
589+ _headerDescription :: Maybe Text
590+
591+ , _headerParamSchema :: ParamSchema Header
592+ } deriving (Eq, Show, Generic, Data, Typeable)
593+
594+data Example = Example { getExample :: Map MediaType Value }
595+ deriving (Eq, Show, Generic, Typeable)
596+
597+exampleConstr :: Constr
598+exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix
599+
600+exampleDataType :: DataType
601+exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr]
602+
603+instance Data Example where
604+ gunfold k z c = case constrIndex c of
605+ 1 -> k (z (\m -> Example (Map.mapKeys fromString m)))
606+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Example."
607+ toConstr (Example _) = exampleConstr
608+ dataTypeOf _ = exampleDataType
609+
610+-- | The location of the API key.
611+data ApiKeyLocation
612+ = ApiKeyQuery
613+ | ApiKeyHeader
614+ deriving (Eq, Show, Generic, Data, Typeable)
615+
616+data ApiKeyParams = ApiKeyParams
617+ { -- | The name of the header or query parameter to be used.
618+ _apiKeyName :: Text
619+
620+ -- | The location of the API key.
621+ , _apiKeyIn :: ApiKeyLocation
622+ } deriving (Eq, Show, Generic, Data, Typeable)
623+
624+-- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
625+type AuthorizationURL = Text
626+
627+-- | The token URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
628+type TokenURL = Text
629+
630+data OAuth2Flow
631+ = OAuth2Implicit AuthorizationURL
632+ | OAuth2Password TokenURL
633+ | OAuth2Application TokenURL
634+ | OAuth2AccessCode AuthorizationURL TokenURL
635+ deriving (Eq, Show, Generic, Data, Typeable)
636+
637+data OAuth2Params = OAuth2Params
638+ { -- | The flow used by the OAuth2 security scheme.
639+ _oauth2Flow :: OAuth2Flow
640+
641+ -- | The available scopes for the OAuth2 security scheme.
642+ , _oauth2Scopes :: HashMap Text Text
643+ } deriving (Eq, Show, Generic, Data, Typeable)
644+
645+data SecuritySchemeType
646+ = SecuritySchemeBasic
647+ | SecuritySchemeApiKey ApiKeyParams
648+ | SecuritySchemeOAuth2 OAuth2Params
649+ deriving (Eq, Show, Generic, Data, Typeable)
650+
651+data SecurityScheme = SecurityScheme
652+ { -- | The type of the security scheme.
653+ _securitySchemeType :: SecuritySchemeType
654+
655+ -- | A short description for security scheme.
656+ , _securitySchemeDescription :: Maybe Text
657+ } deriving (Eq, Show, Generic, Data, Typeable)
658+
659+-- | Lists the required security schemes to execute this operation.
660+-- The object can have multiple security schemes declared in it which are all required
661+-- (that is, there is a logical AND between the schemes).
662+newtype SecurityRequirement = SecurityRequirement
663+ { getSecurityRequirement :: HashMap Text [Text]
664+ } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
665+
666+-- | Tag name.
667+type TagName = Text
668+
669+-- | Allows adding meta data to a single tag that is used by @Operation@.
670+-- It is not mandatory to have a @Tag@ per tag used there.
671+data Tag = Tag
672+ { -- | The name of the tag.
673+ _tagName :: TagName
674+
675+ -- | A short description for the tag.
676+ -- GFM syntax can be used for rich text representation.
677+ , _tagDescription :: Maybe Text
678+
679+ -- | Additional external documentation for this tag.
680+ , _tagExternalDocs :: Maybe ExternalDocs
681+ } deriving (Eq, Show, Generic, Data, Typeable)
682+
683+-- | Allows referencing an external resource for extended documentation.
684+data ExternalDocs = ExternalDocs
685+ { -- | A short description of the target documentation.
686+ -- GFM syntax can be used for rich text representation.
687+ _externalDocsDescription :: Maybe Text
688+
689+ -- | The URL for the target documentation.
690+ , _externalDocsUrl :: URL
691+ } deriving (Eq, Show, Generic, Data, Typeable)
692+
693+-- | A simple object to allow referencing other definitions in the specification.
694+-- It can be used to reference parameters and responses that are defined at the top level for reuse.
695+newtype Reference = Reference { getReference :: Text }
696+ deriving (Eq, Show, Data, Typeable)
697+
698+data Referenced a
699+ = Ref Reference
700+ | Inline a
701+ deriving (Eq, Show, Data, Typeable)
702+
703+newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON, Data, Typeable)
704+
705+-- =======================================================================
706+-- Monoid instances
707+-- =======================================================================
708+
709+instance Monoid Swagger where
710+ mempty = genericMempty
711+ mappend = genericMappend
712+
713+instance Monoid Info where
714+ mempty = genericMempty
715+ mappend = genericMappend
716+
717+instance Monoid Contact where
718+ mempty = genericMempty
719+ mappend = genericMappend
720+
721+instance Monoid PathItem where
722+ mempty = genericMempty
723+ mappend = genericMappend
724+
725+instance Monoid Schema where
726+ mempty = genericMempty
727+ mappend = genericMappend
728+
729+instance Monoid (ParamSchema t) where
730+ mempty = genericMempty
731+ mappend = genericMappend
732+
733+instance Monoid Param where
734+ mempty = genericMempty
735+ mappend = genericMappend
736+
737+instance Monoid ParamOtherSchema where
738+ mempty = genericMempty
739+ mappend = genericMappend
740+
741+instance Monoid Header where
742+ mempty = genericMempty
743+ mappend = genericMappend
744+
745+instance Monoid Responses where
746+ mempty = genericMempty
747+ mappend = genericMappend
748+
749+instance Monoid Response where
750+ mempty = genericMempty
751+ mappend = genericMappend
752+
753+instance Monoid ExternalDocs where
754+ mempty = genericMempty
755+ mappend = genericMappend
756+
757+instance Monoid Operation where
758+ mempty = genericMempty
759+ mappend = genericMappend
760+
761+instance Monoid Example where
762+ mempty = genericMempty
763+ mappend = genericMappend
764+
765+-- =======================================================================
766+-- SwaggerMonoid helper instances
767+-- =======================================================================
768+
769+instance SwaggerMonoid Info
770+instance SwaggerMonoid PathItem
771+instance SwaggerMonoid Schema
772+instance SwaggerMonoid (ParamSchema t)
773+instance SwaggerMonoid Param
774+instance SwaggerMonoid ParamOtherSchema
775+instance SwaggerMonoid Responses
776+instance SwaggerMonoid Response
777+instance SwaggerMonoid ExternalDocs
778+instance SwaggerMonoid Operation
779+
780+instance SwaggerMonoid MimeList
781+deriving instance SwaggerMonoid URL
782+
783+instance SwaggerMonoid (SwaggerType t) where
784+ swaggerMempty = SwaggerString
785+ swaggerMappend _ y = y
786+
787+instance SwaggerMonoid ParamLocation where
788+ swaggerMempty = ParamQuery
789+ swaggerMappend _ y = y
790+
791+instance SwaggerMonoid (HashMap FilePath PathItem) where
792+ swaggerMempty = HashMap.empty
793+ swaggerMappend = HashMap.unionWith mappend
794+
795+instance Monoid a => SwaggerMonoid (Referenced a) where
796+ swaggerMempty = Inline mempty
797+ swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
798+ swaggerMappend _ y = y
799+
800+instance SwaggerMonoid ParamAnySchema where
801+ swaggerMempty = ParamOther swaggerMempty
802+ swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y)
803+ swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y)
804+ swaggerMappend _ y = y
805+
806+-- =======================================================================
807+-- Simple Generic-based ToJSON instances
808+-- =======================================================================
809+
810+instance ToJSON ParamLocation where
811+ toJSON = genericToJSON (jsonPrefix "Param")
812+
813+instance ToJSON Info where
814+ toJSON = genericToJSON (jsonPrefix "Info")
815+
816+instance ToJSON Contact where
817+ toJSON = genericToJSON (jsonPrefix "Contact")
818+
819+instance ToJSON License where
820+ toJSON = genericToJSON (jsonPrefix "License")
821+
822+instance ToJSON ApiKeyLocation where
823+ toJSON = genericToJSON (jsonPrefix "ApiKey")
824+
825+instance ToJSON ApiKeyParams where
826+ toJSON = genericToJSON (jsonPrefix "apiKey")
827+
828+instance ToJSON Scheme where
829+ toJSON = genericToJSON (jsonPrefix "")
830+
831+instance ToJSON Tag where
832+ toJSON = genericToJSON (jsonPrefix "Tag")
833+
834+instance ToJSON ExternalDocs where
835+ toJSON = genericToJSON (jsonPrefix "ExternalDocs")
836+
837+instance ToJSON Xml where
838+ toJSON = genericToJSON (jsonPrefix "Xml")
839+
840+-- =======================================================================
841+-- Simple Generic-based FromJSON instances
842+-- =======================================================================
843+
844+instance FromJSON ParamLocation where
845+ parseJSON = genericParseJSON (jsonPrefix "Param")
846+
847+instance FromJSON Info where
848+ parseJSON = genericParseJSON (jsonPrefix "Info")
849+
850+instance FromJSON Contact where
851+ parseJSON = genericParseJSON (jsonPrefix "Contact")
852+
853+instance FromJSON License where
854+ parseJSON = genericParseJSON (jsonPrefix "License")
855+
856+instance FromJSON ApiKeyLocation where
857+ parseJSON = genericParseJSON (jsonPrefix "ApiKey")
858+
859+instance FromJSON ApiKeyParams where
860+ parseJSON = genericParseJSON (jsonPrefix "apiKey")
861+
862+instance FromJSON Scheme where
863+ parseJSON = genericParseJSON (jsonPrefix "")
864+
865+instance FromJSON Tag where
866+ parseJSON = genericParseJSON (jsonPrefix "Tag")
867+
868+instance FromJSON ExternalDocs where
869+ parseJSON = genericParseJSON (jsonPrefix "ExternalDocs")
870+
871+-- =======================================================================
872+-- Manual ToJSON instances
873+-- =======================================================================
874+
875+instance ToJSON OAuth2Flow where
876+ toJSON (OAuth2Implicit authUrl) = object
877+ [ "flow" .= ("implicit" :: Text)
878+ , "authorizationUrl" .= authUrl ]
879+ toJSON (OAuth2Password tokenUrl) = object
880+ [ "flow" .= ("password" :: Text)
881+ , "tokenUrl" .= tokenUrl ]
882+ toJSON (OAuth2Application tokenUrl) = object
883+ [ "flow" .= ("application" :: Text)
884+ , "tokenUrl" .= tokenUrl ]
885+ toJSON (OAuth2AccessCode authUrl tokenUrl) = object
886+ [ "flow" .= ("accessCode" :: Text)
887+ , "authorizationUrl" .= authUrl
888+ , "tokenUrl" .= tokenUrl ]
889+
890+instance ToJSON OAuth2Params where
891+ toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")
892+
893+instance ToJSON SecuritySchemeType where
894+ toJSON SecuritySchemeBasic
895+ = object [ "type" .= ("basic" :: Text) ]
896+ toJSON (SecuritySchemeApiKey params)
897+ = toJSON params
898+ <+> object [ "type" .= ("apiKey" :: Text) ]
899+ toJSON (SecuritySchemeOAuth2 params)
900+ = toJSON params
901+ <+> object [ "type" .= ("oauth2" :: Text) ]
902+
903+instance ToJSON Swagger where
904+ toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")
905+ where
906+ addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
907+ addVersion _ = error "impossible"
908+
909+instance ToJSON SecurityScheme where
910+ toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
911+
912+instance ToJSON Schema where
913+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
914+ where
915+ f "items" (Array _) = True
916+ f _ _ = False
917+
918+instance ToJSON Header where
919+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
920+
921+instance ToJSON (SwaggerItems t) where
922+ toJSON (SwaggerItemsPrimitive fmt schema) = object
923+ [ "collectionFormat" .= fmt
924+ , "items" .= schema ]
925+ toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
926+ toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
927+
928+instance ToJSON Host where
929+ toJSON (Host host mport) = toJSON $
930+ case mport of
931+ Nothing -> host
932+ Just port -> host ++ ":" ++ show port
933+
934+instance ToJSON MimeList where
935+ toJSON (MimeList xs) = toJSON (map show xs)
936+
937+instance ToJSON Param where
938+ toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
939+
940+instance ToJSON ParamAnySchema where
941+ toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
942+ toJSON (ParamOther s) = toJSON s
943+
944+instance ToJSON ParamOtherSchema where
945+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
946+
947+instance ToJSON Responses where
948+ toJSON (Responses def rs) = omitEmpties $
949+ toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
950+
951+instance ToJSON Response where
952+ toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
953+
954+instance ToJSON Operation where
955+ toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")
956+
957+instance ToJSON PathItem where
958+ toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")
959+
960+instance ToJSON Example where
961+ toJSON = toJSON . Map.mapKeys show . getExample
962+
963+instance ToJSON Reference where
964+ toJSON (Reference ref) = object [ "$ref" .= ref ]
965+
966+referencedToJSON :: ToJSON a => Text -> Referenced a -> Value
967+referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ]
968+referencedToJSON _ (Inline x) = toJSON x
969+
970+instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/definitions/"
971+instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/parameters/"
972+instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/responses/"
973+
974+instance ToJSON (SwaggerType t) where
975+ toJSON SwaggerArray = "array"
976+ toJSON SwaggerString = "string"
977+ toJSON SwaggerInteger = "integer"
978+ toJSON SwaggerNumber = "number"
979+ toJSON SwaggerBoolean = "boolean"
980+ toJSON SwaggerFile = "file"
981+ toJSON SwaggerNull = "null"
982+ toJSON SwaggerObject = "object"
983+
984+instance ToJSON (CollectionFormat t) where
985+ toJSON CollectionCSV = "csv"
986+ toJSON CollectionSSV = "ssv"
987+ toJSON CollectionTSV = "tsv"
988+ toJSON CollectionPipes = "pipes"
989+ toJSON CollectionMulti = "multi"
990+
991+instance ToJSON (ParamSchema t) where
992+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
993+ where
994+ f "items" (Array _) = True
995+ f _ _ = False
996+
997+-- =======================================================================
998+-- Manual FromJSON instances
999+-- =======================================================================
1000+
1001+instance FromJSON OAuth2Flow where
1002+ parseJSON (Object o) = do
1003+ (flow :: Text) <- o .: "flow"
1004+ case flow of
1005+ "implicit" -> OAuth2Implicit <$> o .: "authorizationUrl"
1006+ "password" -> OAuth2Password <$> o .: "tokenUrl"
1007+ "application" -> OAuth2Application <$> o .: "tokenUrl"
1008+ "accessCode" -> OAuth2AccessCode
1009+ <$> o .: "authorizationUrl"
1010+ <*> o .: "tokenUrl"
1011+ _ -> empty
1012+ parseJSON _ = empty
1013+
1014+instance FromJSON OAuth2Params where
1015+ parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
1016+
1017+instance FromJSON SecuritySchemeType where
1018+ parseJSON js@(Object o) = do
1019+ (t :: Text) <- o .: "type"
1020+ case t of
1021+ "basic" -> pure SecuritySchemeBasic
1022+ "apiKey" -> SecuritySchemeApiKey <$> parseJSON js
1023+ "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js
1024+ _ -> empty
1025+ parseJSON _ = empty
1026+
1027+instance FromJSON Swagger where
1028+ parseJSON js@(Object o) = do
1029+ (version :: Text) <- o .: "swagger"
1030+ when (version /= "2.0") empty
1031+ (genericParseJSON (jsonPrefix "swagger")
1032+ `withDefaults` [ "consumes" .= (mempty :: MimeList)
1033+ , "produces" .= (mempty :: MimeList)
1034+ , "security" .= ([] :: [SecurityRequirement])
1035+ , "tags" .= ([] :: [Tag])
1036+ , "definitions" .= (mempty :: Definitions Schema)
1037+ , "parameters" .= (mempty :: Definitions Param)
1038+ , "responses" .= (mempty :: Definitions Response)
1039+ , "securityDefinitions" .= (mempty :: Definitions SecurityScheme)
1040+ ] ) js
1041+ parseJSON _ = empty
1042+
1043+instance FromJSON SecurityScheme where
1044+ parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
1045+
1046+instance FromJSON Schema where
1047+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
1048+ `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
1049+ , "required" .= ([] :: [ParamName]) ]
1050+
1051+instance FromJSON Header where
1052+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
1053+
1054+instance {-# OVERLAPPABLE #-} (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where
1055+ parseJSON (Object o) = SwaggerItemsPrimitive
1056+ <$> o .:? "collectionFormat"
1057+ <*> (o .: "items" >>= parseJSON)
1058+
1059+instance {-# OVERLAPPING #-} FromJSON (SwaggerItems Schema) where
1060+ parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
1061+ parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1062+ parseJSON _ = empty
1063+
1064+instance FromJSON Host where
1065+ parseJSON (String s) =
1066+ case fromInteger <$> readMaybe portStr of
1067+ Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'"
1068+ mport -> pure $ Host host mport
1069+ where
1070+ (hostText, portText) = Text.breakOn ":" s
1071+ [host, portStr] = map Text.unpack [hostText, portText]
1072+ parseJSON _ = empty
1073+
1074+instance FromJSON MimeList where
1075+ parseJSON js = (MimeList . map fromString) <$> parseJSON js
1076+
1077+instance FromJSON Param where
1078+ parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
1079+
1080+instance FromJSON ParamAnySchema where
1081+ parseJSON js@(Object o) = do
1082+ (i :: Text) <- o .: "in"
1083+ case i of
1084+ "body" -> do
1085+ schema <- o .: "schema"
1086+ ParamBody <$> parseJSON schema
1087+ _ -> ParamOther <$> parseJSON js
1088+ parseJSON _ = empty
1089+
1090+instance FromJSON ParamOtherSchema where
1091+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1092+
1093+instance FromJSON Responses where
1094+ parseJSON (Object o) = Responses
1095+ <$> o .:? "default"
1096+ <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
1097+ parseJSON _ = empty
1098+
1099+instance FromJSON Example where
1100+ parseJSON js = do
1101+ m <- parseJSON js
1102+ pure $ Example (Map.mapKeys fromString m)
1103+
1104+instance FromJSON Response where
1105+ parseJSON = genericParseJSON (jsonPrefix "response")
1106+ `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
1107+
1108+instance FromJSON Operation where
1109+ parseJSON = genericParseJSON (jsonPrefix "operation")
1110+ `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) ]
1111+
1112+instance FromJSON PathItem where
1113+ parseJSON = genericParseJSON (jsonPrefix "pathItem")
1114+ `withDefaults` [ "parameters" .= ([] :: [Param]) ]
1115+
1116+instance FromJSON Reference where
1117+ parseJSON (Object o) = Reference <$> o .: "$ref"
1118+ parseJSON _ = empty
1119+
1120+referencedParseJSON :: FromJSON a => Text -> Value -> JSON.Parser (Referenced a)
1121+referencedParseJSON prefix js@(Object o) = do
1122+ ms <- o .:? "$ref"
1123+ case ms of
1124+ Nothing -> Inline <$> parseJSON js
1125+ Just s -> Ref <$> parseRef s
1126+ where
1127+ parseRef s = do
1128+ case Text.stripPrefix prefix s of
1129+ Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s
1130+ Just suffix -> pure (Reference suffix)
1131+
1132+instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/definitions/"
1133+instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/parameters/"
1134+instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/responses/"
1135+
1136+instance FromJSON Xml where
1137+ parseJSON = genericParseJSON (jsonPrefix "xml")
1138+
1139+instance FromJSON (SwaggerType Schema) where
1140+ parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1141+
1142+instance FromJSON (SwaggerType ParamOtherSchema) where
1143+ parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1144+
1145+instance {-# OVERLAPPABLE #-} FromJSON (SwaggerType t) where
1146+ parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1147+
1148+instance {-# OVERLAPPABLE #-} FromJSON (CollectionFormat t) where
1149+ parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1150+
1151+instance FromJSON (CollectionFormat ParamOtherSchema) where
1152+ parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1153+
1154+-- NOTE: The constraints @FromJSON (SwaggerType t)@ and
1155+-- @FromJSON (SwaggerItems t)@ are necessary here!
1156+-- Without the constraint the general instance will be used
1157+-- that only accepts common types (i.e. NOT object, null or file)
1158+-- and primitive array items.
1159+instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
1160+ parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
1161+
src/Data/OpenApi/Internal/ParamSchema.hs → src/Data/Swagger/Internal/ParamSchema.hsrenamed+45−161
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
1{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
@@ -7,18 +6,12 @@
7{-# LANGUAGE PackageImports #-}
6{-# LANGUAGE PackageImports #-}
8{-# LANGUAGE PolyKinds #-}
7{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeSynonymInstances #-}
10{-# LANGUAGE TypeSynonymInstances #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−-- Generic a is redundant in ToParamSchema a default imple
15−{-# OPTIONS_GHC -Wno-redundant-constraints #-}
16−-- For TypeErrors
17−{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
18−module Data.OpenApi.Internal.ParamSchema where
11+module Data.Swagger.Internal.ParamSchema where
19
12
20import Control.Lens
13import Control.Lens
21−import Data.Aeson (ToJSON (..))
14+import Data.Aeson
22import Data.Proxy
15import Data.Proxy
23import GHC.Generics
16import GHC.Generics
24
17
@@ -27,54 +20,16 @@ import "unordered-containers" Data.HashSet (HashSet)
27import Data.Monoid
20import Data.Monoid
28import Data.Set (Set)
21import Data.Set (Set)
29import Data.Scientific
22import Data.Scientific
30−import Data.Fixed (HasResolution(..), Fixed, Pico)
31import qualified Data.Text as T
23import qualified Data.Text as T
32import qualified Data.Text.Lazy as TL
24import qualified Data.Text.Lazy as TL
33import Data.Time
25import Data.Time
34−import qualified Data.Vector as V
35−import qualified Data.Vector.Primitive as VP
36−import qualified Data.Vector.Storable as VS
37−import qualified Data.Vector.Unboxed as VU
38−import Data.Version (Version)
39−import Numeric.Natural.Compat (Natural)
40import Data.Word
26import Data.Word
41−import Data.UUID.Types (UUID)
27+
42−import Web.Cookie (SetCookie)
43−
44−import Data.OpenApi.Internal
28+import Data.Swagger.Internal
45−import Data.OpenApi.Lens
29+import Data.Swagger.Lens
46−import Data.OpenApi.SchemaOptions
30+import Data.Swagger.SchemaOptions
47−
31+
48−import qualified Data.ByteString as BS
49−import qualified Data.ByteString.Lazy.Char8 as BSL
50−import GHC.TypeLits (TypeError, ErrorMessage(..))
51−
52−-- | Default schema for binary data (any sequence of octets).
53−binarySchema :: Schema
54−binarySchema = mempty
55− & type_ ?~ OpenApiString
56− & format ?~ "binary"
57−
58−-- | Default schema for binary data (base64 encoded).
59−byteSchema :: Schema
60−byteSchema = mempty
61− & type_ ?~ OpenApiString
62− & format ?~ "byte"
63−
64−-- | Default schema for password string.
65−-- @"password"@ format is used to hint UIs the input needs to be obscured.
66−passwordSchema :: Schema
67−passwordSchema = mempty
68− & type_ ?~ OpenApiString
69− & format ?~ "password"
70−
71−-- | Convert a type into a plain @'Schema'@.
32+-- | Convert a type into a plain @'ParamSchema'@.
72−--
73−-- In previous versions of the package there was a separate type called @ParamSchema@, which was
74−-- included in a greater 'Schema'. Now this is a single class, but distinction for schema generators
75−-- for "simple" types is preserved.
76−--
77−-- 'ToParamSchema' is suited only for primitive-like types without nested fields and such.
78--
33--
79-- An example type and instance:
34-- An example type and instance:
80--
35--
@@ -86,9 +41,9 @@ passwordSchema = mempty
86-- data Direction = Up | Down
41-- data Direction = Up | Down
87--
42--
88-- instance ToParamSchema Direction where
43-- instance ToParamSchema Direction where
89−-- toParamSchema _ = mempty
44+-- toParamSchema = mempty
90−-- & type_ ?~ OpenApiString
45+-- & type_ .~ SwaggerString
91−-- & enum_ ?~ [ \"Up\", \"Down\" ]
46+-- & enum_ .~ [ \"Up\", \"Down\" ]
92-- @
47-- @
93--
48--
94-- Instead of manually writing your @'ToParamSchema'@ instance you can
49-- Instead of manually writing your @'ToParamSchema'@ instance you can
@@ -112,28 +67,20 @@ passwordSchema = mempty
112class ToParamSchema a where
67class ToParamSchema a where
113 -- | Convert a type into a plain parameter schema.
68 -- | Convert a type into a plain parameter schema.
114 --
69 --
115− -- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy Integer)
70+ -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
116− -- {
117− -- "type": "integer"
71+ -- "{\"type\":\"integer\"}"
118− -- }
119− toParamSchema :: Proxy a -> Schema
72+ toParamSchema :: proxy a -> ParamSchema t
120− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> Schema
73+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t
121 toParamSchema = genericToParamSchema defaultSchemaOptions
74 toParamSchema = genericToParamSchema defaultSchemaOptions
122
75
123instance {-# OVERLAPPING #-} ToParamSchema String where
76instance {-# OVERLAPPING #-} ToParamSchema String where
124− toParamSchema _ = mempty & type_ ?~ OpenApiString
77+ toParamSchema _ = mempty & type_ .~ SwaggerString
125
78
126instance ToParamSchema Bool where
79instance ToParamSchema Bool where
127− toParamSchema _ = mempty & type_ ?~ OpenApiBoolean
80+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean
128
81
129instance ToParamSchema Integer where
82instance ToParamSchema Integer where
130− toParamSchema _ = mempty & type_ ?~ OpenApiInteger
83+ toParamSchema _ = mempty & type_ .~ SwaggerInteger
131−
132−instance ToParamSchema Natural where
133− toParamSchema _ = mempty
134− & type_ ?~ OpenApiInteger
135− & minimum_ ?~ 0
136− & exclusiveMinimum ?~ False
137
84
138instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
85instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
139instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
86instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
@@ -148,66 +95,47 @@ instance ToParamSchema Int64 where
148instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral
95instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral
149instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral
96instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral
150instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral
97instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral
151−
152−instance ToParamSchema Word32 where
98+instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral
153− toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int32"
154−
155−instance ToParamSchema Word64 where
99+instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
156− toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64"
157
100
158-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
101-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
159--
102--
160−-- >>> BSL.putStrLn $ encodePretty $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
103+-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
161−-- {
162−-- "maximum": 127,
163−-- "minimum": -128,
164−-- "type": "integer"
104+-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
165−-- }
166−toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema
105+toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t
167toParamSchemaBoundedIntegral _ = mempty
106toParamSchemaBoundedIntegral _ = mempty
168− & type_ ?~ OpenApiInteger
107+ & type_ .~ SwaggerInteger
169 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
108 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
170 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
109 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
171
110
172instance ToParamSchema Char where
111instance ToParamSchema Char where
173 toParamSchema _ = mempty
112 toParamSchema _ = mempty
174− & type_ ?~ OpenApiString
113+ & type_ .~ SwaggerString
175 & maxLength ?~ 1
114 & maxLength ?~ 1
176 & minLength ?~ 1
115 & minLength ?~ 1
177
116
178instance ToParamSchema Scientific where
117instance ToParamSchema Scientific where
179− toParamSchema _ = mempty & type_ ?~ OpenApiNumber
118+ toParamSchema _ = mempty & type_ .~ SwaggerNumber
180−
181−instance HasResolution a => ToParamSchema (Fixed a) where
182− toParamSchema _ = mempty
183− & type_ ?~ OpenApiNumber
184− & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
185
119
186instance ToParamSchema Double where
120instance ToParamSchema Double where
187 toParamSchema _ = mempty
121 toParamSchema _ = mempty
188− & type_ ?~ OpenApiNumber
122+ & type_ .~ SwaggerNumber
189 & format ?~ "double"
123 & format ?~ "double"
190
124
191instance ToParamSchema Float where
125instance ToParamSchema Float where
192 toParamSchema _ = mempty
126 toParamSchema _ = mempty
193− & type_ ?~ OpenApiNumber
127+ & type_ .~ SwaggerNumber
194 & format ?~ "float"
128 & format ?~ "float"
195
129
196−timeParamSchema :: String -> Schema
130+timeParamSchema :: String -> ParamSchema t
197timeParamSchema fmt = mempty
131timeParamSchema fmt = mempty
198− & type_ ?~ OpenApiString
132+ & type_ .~ SwaggerString
199 & format ?~ T.pack fmt
133 & format ?~ T.pack fmt
200
134
201-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
135-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
202instance ToParamSchema Day where
136instance ToParamSchema Day where
203 toParamSchema _ = timeParamSchema "date"
137 toParamSchema _ = timeParamSchema "date"
204
138
205−-- |
206−-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
207−-- Just "hh:MM:ss"
208−instance ToParamSchema TimeOfDay where
209− toParamSchema _ = timeParamSchema "hh:MM:ss"
210−
211-- |
139-- |
212-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
140-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
213-- Just "yyyy-mm-ddThh:MM:ss"
141-- Just "yyyy-mm-ddThh:MM:ss"
@@ -216,9 +144,9 @@ instance ToParamSchema LocalTime where
216
144
217-- |
145-- |
218-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format
146-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format
219−-- Just "date-time"
147+-- Just "yyyy-mm-ddThh:MM:ss+hhMM"
220instance ToParamSchema ZonedTime where
148instance ToParamSchema ZonedTime where
221− toParamSchema _ = timeParamSchema "date-time"
149+ toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"
222
150
223-- |
151-- |
224-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format
152-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format
@@ -227,7 +155,7 @@ instance ToParamSchema UTCTime where
227 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
155 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
228
156
229instance ToParamSchema NominalDiffTime where
157instance ToParamSchema NominalDiffTime where
230− toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
158+ toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)
231
159
232instance ToParamSchema T.Text where
160instance ToParamSchema T.Text where
233 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
161 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
@@ -235,24 +163,6 @@ instance ToParamSchema T.Text where
235instance ToParamSchema TL.Text where
163instance ToParamSchema TL.Text where
236 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
164 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
237
165
238−instance ToParamSchema Version where
239− toParamSchema _ = mempty
240− & type_ ?~ OpenApiString
241− & pattern ?~ "^\\d+(\\.\\d+)*$"
242−
243−instance ToParamSchema SetCookie where
244− toParamSchema _ = mempty
245− & type_ ?~ OpenApiString
246−
247−type family ToParamSchemaByteStringError bs where
248− ToParamSchemaByteStringError bs = TypeError
249− ( 'Text "Impossible to have an instance " :<>: ShowType (ToParamSchema bs) :<>: Text "."
250− :$$: 'Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."
251− :$$: 'Text "Consider using byteParamSchema or binaryParamSchemaemplates." )
252−
253−instance ToParamSchemaByteStringError BS.ByteString => ToParamSchema BS.ByteString where toParamSchema = error "impossible"
254−instance ToParamSchemaByteStringError BSL.ByteString => ToParamSchema BSL.ByteString where toParamSchema = error "impossible"
255−
256instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
166instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
257instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
167instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
258instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
168instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
@@ -261,17 +171,10 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to
261instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
171instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
262instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
172instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
263
173
264−instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
265−
266instance ToParamSchema a => ToParamSchema [a] where
174instance ToParamSchema a => ToParamSchema [a] where
267 toParamSchema _ = mempty
175 toParamSchema _ = mempty
268− & type_ ?~ OpenApiArray
176+ & type_ .~ SwaggerArray
269− & items ?~ OpenApiItemsObject (Inline $ toParamSchema (Proxy :: Proxy a))
177+ & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
270−
271−instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
272−instance ToParamSchema a => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
273−instance ToParamSchema a => ToParamSchema (VS.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
274−instance ToParamSchema a => ToParamSchema (VU.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
275
178
276instance ToParamSchema a => ToParamSchema (Set a) where
179instance ToParamSchema a => ToParamSchema (Set a) where
277 toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
180 toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
@@ -281,40 +184,24 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
281 toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a))
184 toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a))
282
185
283-- |
186-- |
284−-- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy ())
187+-- >>> encode $ toParamSchema (Proxy :: Proxy ())
285−-- {
286−-- "enum": [
188+-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
287−-- "_"
288−-- ],
289−-- "type": "string"
290−-- }
291instance ToParamSchema () where
189instance ToParamSchema () where
292 toParamSchema _ = mempty
190 toParamSchema _ = mempty
293− & type_ ?~ OpenApiString
191+ & type_ .~ SwaggerString
294 & enum_ ?~ ["_"]
192 & enum_ ?~ ["_"]
295
193
296−instance ToParamSchema UUID where
297− toParamSchema _ = mempty
298− & type_ ?~ OpenApiString
299− & format ?~ "uuid"
300−
301−-- | A configurable generic @'Schema'@ creator.
194+-- | A configurable generic @'ParamSchema'@ creator.
302--
195--
303-- >>> :set -XDeriveGeneric
196-- >>> :set -XDeriveGeneric
304-- >>> data Color = Red | Blue deriving Generic
197-- >>> data Color = Red | Blue deriving Generic
305−-- >>> BSL.putStrLn $ encodePretty $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
198+-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
306−-- {
199+-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
307−-- "enum": [
308−-- "Red",
309−-- "Blue"
310−-- ],
311−-- "type": "string"
312−-- }
313−genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema
200+genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t
314genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
201genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
315
202
316class GToParamSchema (f :: * -> *) where
203class GToParamSchema (f :: * -> *) where
317− gtoParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema
204+ gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
318
205
319instance GToParamSchema f => GToParamSchema (D1 d f) where
206instance GToParamSchema f => GToParamSchema (D1 d f) where
320 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
207 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
@@ -332,14 +219,14 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
332 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
219 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
333
220
334class GEnumParamSchema (f :: * -> *) where
221class GEnumParamSchema (f :: * -> *) where
335− genumParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema
222+ genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
336
223
337instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
224instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
338 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
225 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
339
226
340instance Constructor c => GEnumParamSchema (C1 c U1) where
227instance Constructor c => GEnumParamSchema (C1 c U1) where
341 genumParamSchema opts _ s = s
228 genumParamSchema opts _ s = s
342− & type_ ?~ OpenApiString
229+ & type_ .~ SwaggerString
343 & enum_ %~ addEnumValue tag
230 & enum_ %~ addEnumValue tag
344 where
231 where
345 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
232 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
@@ -349,6 +236,3 @@ instance Constructor c => GEnumParamSchema (C1 c U1) where
349
236
350data Proxy3 a b c = Proxy3
237data Proxy3 a b c = Proxy3
351
238
352−-- $setup
353−-- >>> import Data.Aeson (encode)
354−-- >>> import Data.OpenApi.Internal.Utils
src/Data/Swagger/Internal/Schema.hsnew file+566
@@ -0,0 +1,566 @@
1+{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE OverloadedLists #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE PackageImports #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE TypeSynonymInstances #-}
14+module Data.Swagger.Internal.Schema where
15+
16+import Control.Lens
17+import Data.Data.Lens (template)
18+
19+import Control.Monad
20+import Control.Monad.Writer
21+import Data.Aeson
22+import Data.Char
23+import Data.Data (Data)
24+import Data.Foldable (traverse_)
25+import Data.HashMap.Strict (HashMap)
26+import qualified Data.HashMap.Strict as HashMap
27+import "unordered-containers" Data.HashSet (HashSet)
28+import Data.Int
29+import Data.IntSet (IntSet)
30+import Data.IntMap (IntMap)
31+import Data.Map (Map)
32+import Data.Monoid
33+import Data.Proxy
34+import Data.Scientific (Scientific)
35+import Data.Set (Set)
36+import qualified Data.Text as T
37+import qualified Data.Text.Lazy as TL
38+import Data.Time
39+import Data.Word
40+import GHC.Generics
41+
42+import Data.Swagger.Declare
43+import Data.Swagger.Internal
44+import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
45+import Data.Swagger.Lens
46+import Data.Swagger.SchemaOptions
47+
48+unnamed :: Schema -> NamedSchema
49+unnamed schema = NamedSchema Nothing schema
50+
51+named :: T.Text -> Schema -> NamedSchema
52+named name schema = NamedSchema (Just name) schema
53+
54+plain :: Schema -> Declare (Definitions Schema) NamedSchema
55+plain = pure . unnamed
56+
57+unname :: NamedSchema -> NamedSchema
58+unname (NamedSchema _ schema) = unnamed schema
59+
60+rename :: Maybe T.Text -> NamedSchema -> NamedSchema
61+rename name (NamedSchema _ schema) = NamedSchema name schema
62+
63+-- | Convert a type into @'Schema'@.
64+--
65+-- An example type and instance:
66+--
67+-- @
68+-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
69+-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
70+--
71+-- import Control.Lens
72+--
73+-- data Coord = Coord { x :: Double, y :: Double }
74+--
75+-- instance ToSchema Coord where
76+-- declareNamedSchema = pure (Just \"Coord\", schema)
77+-- where
78+-- schema = mempty
79+-- & type_ .~ SwaggerObject
80+-- & properties .~
81+-- [ (\"x\", toSchemaRef (Proxy :: Proxy Double))
82+-- , (\"y\", toSchemaRef (Proxy :: Proxy Double))
83+-- ]
84+-- & required .~ [ \"x\", \"y\" ]
85+-- @
86+--
87+-- Instead of manually writing your @'ToSchema'@ instance you can
88+-- use a default generic implementation of @'declareNamedSchema'@.
89+--
90+-- To do that, simply add @deriving 'Generic'@ clause to your datatype
91+-- and declare a @'ToSchema'@ instance for your datatype without
92+-- giving definition for @'declareNamedSchema'@.
93+--
94+-- For instance, the previous example can be simplified into this:
95+--
96+-- @
97+-- {-\# LANGUAGE DeriveGeneric \#-}
98+--
99+-- import GHC.Generics (Generic)
100+--
101+-- data Coord = Coord { x :: Double, y :: Double } deriving Generic
102+--
103+-- instance ToSchema Coord
104+-- @
105+class ToSchema a where
106+ -- | Convert a type into an optionally named schema
107+ -- together with all used definitions.
108+ -- Note that the schema itself is included in definitions
109+ -- only if it is recursive (and thus needs its definition in scope).
110+ declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
111+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
112+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
113+
114+-- | Convert a type into a schema and declare all used schema definitions.
115+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
116+declareSchema = fmap _namedSchemaSchema . declareNamedSchema
117+
118+-- | Convert a type into an optionally named schema.
119+--
120+-- >>> toNamedSchema (Proxy :: Proxy String) ^. name
121+-- Nothing
122+-- >>> encode (toNamedSchema (Proxy :: Proxy String) ^. schema)
123+-- "{\"type\":\"string\"}"
124+--
125+-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
126+-- Just "Day"
127+-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
128+-- "{\"format\":\"date\",\"type\":\"string\"}"
129+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
130+toNamedSchema = undeclare . declareNamedSchema
131+
132+-- | Get type's schema name according to its @'ToSchema'@ instance.
133+--
134+-- >>> schemaName (Proxy :: Proxy Int)
135+-- Nothing
136+--
137+-- >>> schemaName (Proxy :: Proxy UTCTime)
138+-- Just "UTCTime"
139+schemaName :: ToSchema a => proxy a -> Maybe T.Text
140+schemaName = _namedSchemaName . toNamedSchema
141+
142+-- | Convert a type into a schema.
143+--
144+-- >>> encode $ toSchema (Proxy :: Proxy Int8)
145+-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
146+--
147+-- >>> encode $ toSchema (Proxy :: Proxy [Day])
148+-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
149+toSchema :: ToSchema a => proxy a -> Schema
150+toSchema = _namedSchemaSchema . toNamedSchema
151+
152+-- | Convert a type into a referenced schema if possible.
153+-- Only named schemas can be referenced, nameless schemas are inlined.
154+--
155+-- >>> encode $ toSchemaRef (Proxy :: Proxy Integer)
156+-- "{\"type\":\"integer\"}"
157+--
158+-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
159+-- "{\"$ref\":\"#/definitions/Day\"}"
160+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
161+toSchemaRef = undeclare . declareSchemaRef
162+
163+-- | Convert a type into a referenced schema if possible
164+-- and declare all used schema definitions.
165+-- Only named schemas can be referenced, nameless schemas are inlined.
166+--
167+-- Schema definitions are typically declared for every referenced schema.
168+-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
169+-- will be declared (regardless of whether it is recusive or not).
170+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
171+declareSchemaRef proxy = do
172+ case toNamedSchema proxy of
173+ NamedSchema (Just name) schema -> do
174+ -- This check is very important as it allows generically
175+ -- derive used definitions for recursive schemas.
176+ -- Lazy Declare monad allows toNamedSchema to ignore
177+ -- any declarations (which would otherwise loop) and
178+ -- retrieve the schema and its name to check if we
179+ -- have already declared it.
180+ -- If we have, we don't need to declare anything for
181+ -- this schema this time and thus simply return the reference.
182+ known <- looks (HashMap.member name)
183+ when (not known) $ do
184+ declare [(name, schema)]
185+ void $ declareNamedSchema proxy
186+ return $ Ref (Reference name)
187+ _ -> Inline <$> declareSchema proxy
188+
189+-- | Inline any referenced schema if its name satisfies given predicate.
190+--
191+-- /NOTE:/ if a referenced schema is not found in definitions the predicate is ignored
192+-- and schema stays referenced.
193+--
194+-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas
195+-- when inlining recursive schemas.
196+inlineSchemasWhen :: Data s => (T.Text -> Bool) -> (Definitions Schema) -> s -> s
197+inlineSchemasWhen p defs = template %~ deref
198+ where
199+ deref r@(Ref (Reference name))
200+ | p name =
201+ case HashMap.lookup name defs of
202+ Just schema -> Inline (inlineSchemasWhen p defs schema)
203+ Nothing -> r
204+ | otherwise = r
205+ deref (Inline schema) = Inline (inlineSchemasWhen p defs schema)
206+
207+-- | Inline any referenced schema if its name is in the given list.
208+--
209+-- /NOTE:/ if a referenced schema is not found in definitions
210+-- it stays referenced even if it appears in the list of names.
211+--
212+-- __WARNING:__ @'inlineSchemas'@ will produce infinite schemas
213+-- when inlining recursive schemas.
214+inlineSchemas :: Data s => [T.Text] -> (Definitions Schema) -> s -> s
215+inlineSchemas names = inlineSchemasWhen (`elem` names)
216+
217+-- | Inline all schema references for which the definition
218+-- can be found in @'Definitions'@.
219+--
220+-- __WARNING:__ @'inlineAllSchemas'@ will produce infinite schemas
221+-- when inlining recursive schemas.
222+inlineAllSchemas :: Data s => (Definitions Schema) -> s -> s
223+inlineAllSchemas = inlineSchemasWhen (const True)
224+
225+-- | Convert a type into a schema without references.
226+--
227+-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
228+-- "{\"items\":{\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
229+--
230+-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
231+-- when inlining recursive schemas.
232+toInlinedSchema :: ToSchema a => proxy a -> Schema
233+toInlinedSchema proxy = inlineAllSchemas defs schema
234+ where
235+ (defs, schema) = runDeclare (declareSchema proxy) mempty
236+
237+-- | Inline all /non-recursive/ schemas for which the definition
238+-- can be found in @'Definitions'@.
239+inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
240+inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
241+ where
242+ nonRecursive name =
243+ case HashMap.lookup name defs of
244+ Just schema -> name `notElem` execDeclare (usedNames schema) mempty
245+ Nothing -> False
246+
247+ usedNames schema = traverse_ schemaRefNames (schema ^.. template)
248+
249+ schemaRefNames :: Referenced Schema -> Declare [T.Text] ()
250+ schemaRefNames ref = case ref of
251+ Ref (Reference name) -> do
252+ seen <- looks (name `elem`)
253+ when (not seen) $ do
254+ declare [name]
255+ traverse_ usedNames (HashMap.lookup name defs)
256+ Inline subschema -> usedNames subschema
257+
258+class GToSchema (f :: * -> *) where
259+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
260+
261+instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
262+ declareNamedSchema _ = do
263+ ref <- declareSchemaRef (Proxy :: Proxy a)
264+ return $ unnamed $ mempty
265+ & type_ .~ SwaggerArray
266+ & items ?~ SwaggerItemsObject ref
267+
268+instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
269+instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
270+instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
271+instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
272+instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
273+instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
274+instance ToSchema Int32 where declareNamedSchema = plain . paramSchemaToSchema
275+instance ToSchema Int64 where declareNamedSchema = plain . paramSchemaToSchema
276+instance ToSchema Word where declareNamedSchema = plain . paramSchemaToSchema
277+instance ToSchema Word8 where declareNamedSchema = plain . paramSchemaToSchema
278+instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
279+instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
280+instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
281+
282+instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema
283+instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
284+instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
285+instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
286+
287+instance ToSchema a => ToSchema (Maybe a) where
288+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
289+
290+instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
291+
292+instance ToSchema () where
293+ declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
294+
295+instance (ToSchema a, ToSchema b) => ToSchema (a, b)
296+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
297+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
298+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
299+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
300+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
301+
302+timeSchema :: T.Text -> Schema
303+timeSchema fmt = mempty
304+ & type_ .~ SwaggerString
305+ & format ?~ fmt
306+
307+-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
308+instance ToSchema Day where
309+ declareNamedSchema _ = pure $ named "Day" (timeSchema "date")
310+
311+-- |
312+-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
313+-- Just "yyyy-mm-ddThh:MM:ss"
314+instance ToSchema LocalTime where
315+ declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")
316+
317+-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
318+instance ToSchema ZonedTime where
319+ declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
320+
321+instance ToSchema NominalDiffTime where
322+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
323+
324+-- |
325+-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
326+-- Just "yyyy-mm-ddThh:MM:ssZ"
327+instance ToSchema UTCTime where
328+ declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")
329+
330+instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
331+instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
332+
333+instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
334+
335+-- | NOTE: This schema does not account for the uniqueness of keys.
336+instance ToSchema a => ToSchema (IntMap a) where
337+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
338+
339+instance ToSchema a => ToSchema (Map String a) where
340+ declareNamedSchema _ = do
341+ schema <- declareSchema (Proxy :: Proxy a)
342+ return $ unnamed $ mempty
343+ & type_ .~ SwaggerObject
344+ & additionalProperties ?~ schema
345+
346+instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
347+instance ToSchema a => ToSchema (Map TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
348+
349+instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
350+instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
351+instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
352+
353+instance ToSchema a => ToSchema (Set a) where
354+ declareNamedSchema _ = do
355+ schema <- declareSchema (Proxy :: Proxy [a])
356+ return $ unnamed $ schema
357+ & uniqueItems ?~ True
358+
359+instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
360+
361+instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
362+instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
363+
364+instance ToSchema a => ToSchema (Sum a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
365+instance ToSchema a => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
366+instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
367+instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
368+instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
369+
370+-- | Default schema for @'Bounded'@, @'Integral'@ types.
371+--
372+-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
373+-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
374+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
375+toSchemaBoundedIntegral _ = mempty
376+ & type_ .~ SwaggerInteger
377+ & minimum_ ?~ fromInteger (toInteger (minBound :: a))
378+ & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
379+
380+-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
381+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
382+ ( Bounded a, Integral a
383+ , Generic a, Rep a ~ D1 d f, Datatype d)
384+ => SchemaOptions -> proxy a -> NamedSchema
385+genericToNamedSchemaBoundedIntegral opts proxy
386+ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
387+
388+-- | A configurable generic @'Schema'@ creator.
389+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
390+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
391+
392+-- | A configurable generic @'NamedSchema'@ creator.
393+-- This function applied to @'defaultSchemaOptions'@
394+-- is used as the default for @'declareNamedSchema'@
395+-- when the type is an instance of @'Generic'@.
396+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
397+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
398+
399+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
400+gdatatypeSchemaName opts _ = case name of
401+ (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
402+ _ -> Nothing
403+ where
404+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
405+
406+-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
407+paramSchemaToNamedSchema :: forall a d f proxy.
408+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
409+ => SchemaOptions -> proxy a -> NamedSchema
410+paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
411+
412+-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
413+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
414+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
415+
416+nullarySchema :: Schema
417+nullarySchema = mempty
418+ & type_ .~ SwaggerArray
419+ & enum_ ?~ [ toJSON () ]
420+ & items ?~ SwaggerItemsArray []
421+
422+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
423+gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
424+
425+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
426+gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
427+
428+instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
429+ gdeclareNamedSchema opts _ schema = do
430+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema
431+ gdeclareNamedSchema opts (Proxy :: Proxy f) gschema
432+
433+instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
434+ gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
435+ where
436+ name = gdatatypeSchemaName opts (Proxy :: Proxy d)
437+
438+instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
439+ gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)
440+
441+instance {-# OVERLAPPING #-} Constructor c => GToSchema (C1 c U1) where
442+ gdeclareNamedSchema = gdeclareNamedSumSchema
443+
444+-- | Single field constructor.
445+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
446+ gdeclareNamedSchema opts _ s
447+ | unwrapUnaryRecords opts = fieldSchema
448+ | otherwise =
449+ case schema ^. items of
450+ Just (SwaggerItemsArray [_]) -> fieldSchema
451+ _ -> do
452+ declare defs
453+ return (unnamed schema)
454+ where
455+ (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
456+ recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
457+ fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
458+
459+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
460+gdeclareSchemaRef opts proxy = do
461+ case gtoNamedSchema opts proxy of
462+ NamedSchema (Just name) schema -> do
463+ -- This check is very important as it allows generically
464+ -- derive used definitions for recursive schemas.
465+ -- Lazy Declare monad allows toNamedSchema to ignore
466+ -- any declarations (which would otherwise loop) and
467+ -- retrieve the schema and its name to check if we
468+ -- have already declared it.
469+ -- If we have, we don't need to declare anything for
470+ -- this schema this time and thus simply return the reference.
471+ known <- looks (HashMap.member name)
472+ when (not known) $ do
473+ declare [(name, schema)]
474+ void $ gdeclareNamedSchema opts proxy mempty
475+ return $ Ref (Reference name)
476+ _ -> Inline <$> gdeclareSchema opts proxy
477+
478+appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)
479+appendItem x Nothing = Just (SwaggerItemsArray [x])
480+appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs))
481+appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
482+
483+withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
484+ SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
485+withFieldSchema opts _ isRequiredField schema = do
486+ ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
487+ return $
488+ if T.null fname
489+ then schema
490+ & type_ .~ SwaggerArray
491+ & items %~ appendItem ref
492+ else schema
493+ & type_ .~ SwaggerObject
494+ & properties . at fname ?~ ref
495+ & if isRequiredField
496+ then required %~ (fname :)
497+ else id
498+ where
499+ fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
500+
501+-- | Optional record fields.
502+instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
503+ gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
504+
505+-- | Record fields.
506+instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
507+ gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
508+
509+instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
510+ gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
511+
512+instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
513+ gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
514+
515+instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
516+ gdeclareNamedSchema = gdeclareNamedSumSchema
517+
518+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
519+gdeclareNamedSumSchema opts proxy s
520+ | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
521+ | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
522+ where
523+ declareSumSchema = gsumToSchema opts proxy s
524+ (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
525+
526+ toStringTag schema = mempty
527+ & type_ .~ SwaggerString
528+ & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
529+
530+type AllNullary = All
531+
532+class GSumToSchema f where
533+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
534+
535+instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
536+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)
537+
538+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
539+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
540+gsumConToSchema opts _ schema = do
541+ ref <- gdeclareSchemaRef opts (Proxy :: Proxy (C1 c f))
542+ return $ schema
543+ & type_ .~ SwaggerObject
544+ & properties . at tag ?~ ref
545+ & maxProperties ?~ 1
546+ & minProperties ?~ 1
547+ where
548+ tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
549+
550+instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
551+ gsumToSchema opts proxy schema = do
552+ tell (All False)
553+ lift $ gsumConToSchema opts proxy schema
554+
555+instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
556+ gsumToSchema opts proxy schema = do
557+ tell (All False)
558+ lift $ gsumConToSchema opts proxy schema
559+
560+instance Constructor c => GSumToSchema (C1 c U1) where
561+ gsumToSchema opts proxy = lift . gsumConToSchema opts proxy
562+
563+data Proxy2 a b = Proxy2
564+
565+data Proxy3 a b c = Proxy3
566+
src/Data/OpenApi/Internal/Utils.hs → src/Data/Swagger/Internal/Utils.hsrenamed+47−19
@@ -4,29 +4,25 @@
4{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7−module Data.OpenApi.Internal.Utils where
7+module Data.Swagger.Internal.Utils where
8−
9−import Prelude ()
10−import Prelude.Compat
11
8
9+import Control.Arrow (first)
10+import Control.Applicative
12import Control.Lens ((&), (%~))
11import Control.Lens ((&), (%~))
13import Control.Lens.TH
12import Control.Lens.TH
14import Data.Aeson
13import Data.Aeson
15import Data.Aeson.Types
14import Data.Aeson.Types
16−import qualified Data.Aeson.Encode.Pretty as P
17−import qualified Data.ByteString.Lazy as BSL
18import Data.Char
15import Data.Char
19import Data.Data
16import Data.Data
20import Data.Hashable (Hashable)
17import Data.Hashable (Hashable)
21import Data.HashMap.Strict (HashMap)
18import Data.HashMap.Strict (HashMap)
22import qualified Data.HashMap.Strict as HashMap
19import qualified Data.HashMap.Strict as HashMap
23−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
24−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
25import Data.Map (Map)
20import Data.Map (Map)
26−import Data.Set (Set)
21+import Data.Monoid
27import Data.Text (Text)
22import Data.Text (Text)
28import GHC.Generics
23import GHC.Generics
29import Language.Haskell.TH (mkName)
24import Language.Haskell.TH (mkName)
25+import Text.Read (readMaybe)
30
26
31swaggerFieldRules :: LensRules
27swaggerFieldRules :: LensRules
32swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
28swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
@@ -45,8 +41,6 @@ swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
45 fixName' "minimum" = "minimum_" -- Prelude conflict
41 fixName' "minimum" = "minimum_" -- Prelude conflict
46 fixName' "maximum" = "maximum_" -- Prelude conflict
42 fixName' "maximum" = "maximum_" -- Prelude conflict
47 fixName' "enum" = "enum_" -- Control.Lens conflict
43 fixName' "enum" = "enum_" -- Control.Lens conflict
48− fixName' "head" = "head_" -- Prelude conflict
49− fixName' "not" = "not_" -- Prelude conflict
50 fixName' n = n
44 fixName' n = n
51
45
52gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
46gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
@@ -54,6 +48,17 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of
54 Just x -> z x
48 Just x -> z x
55 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
49 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
56
50
51+hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v
52+hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList
53+
54+hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)
55+hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList
56+ where
57+ g (x, y) = (\a -> (a, y)) <$> f x
58+
59+hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)
60+hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)
61+
57jsonPrefix :: String -> Options
62jsonPrefix :: String -> Options
58jsonPrefix prefix = defaultOptions
63jsonPrefix prefix = defaultOptions
59 { fieldLabelModifier = modifier . drop 1
64 { fieldLabelModifier = modifier . drop 1
@@ -75,10 +80,40 @@ parseOneOf xs js =
75 where
80 where
76 ys = zip (map toJSON xs) xs
81 ys = zip (map toJSON xs) xs
77
82
83+omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value
84+omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o)
85+ where
86+ nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
87+omitEmptiesExcept _ js = js
88+
89+omitEmpties :: Value -> Value
90+omitEmpties = omitEmptiesExcept (\_ _ -> False)
91+
92+genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
93+genericToJSONWithSub sub opts x =
94+ case genericToJSON opts x of
95+ Object o ->
96+ case HashMap.lookup sub o of
97+ Just so -> Object (HashMap.delete sub o) <+> so
98+ Nothing -> Object o -- no subjson, leaving object as is
99+ _ -> error "genericToJSONWithSub: subjson is not an object"
100+
101+genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
102+genericParseJSONWithSub sub opts js@(Object o)
103+ = genericParseJSON opts js -- try without subjson
104+ <|> genericParseJSON opts js' -- try with subjson
105+ where
106+ js' = Object (HashMap.insert sub (Object o) o)
107+genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"
108+
78(<+>) :: Value -> Value -> Value
109(<+>) :: Value -> Value -> Value
79Object x <+> Object y = Object (x <> y)
110Object x <+> Object y = Object (x <> y)
80_ <+> _ = error "<+>: merging non-objects"
111_ <+> _ = error "<+>: merging non-objects"
81
112
113+withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
114+withDefaults parser defs js@(Object _) = parser (js <+> object defs)
115+withDefaults _ _ _ = empty
116+
82genericMempty :: (Generic a, GMonoid (Rep a)) => a
117genericMempty :: (Generic a, GMonoid (Rep a)) => a
83genericMempty = to gmempty
118genericMempty = to gmempty
84
119
@@ -114,17 +149,12 @@ class SwaggerMonoid m where
114 swaggerMappend = mappend
149 swaggerMappend = mappend
115
150
116instance SwaggerMonoid [a]
151instance SwaggerMonoid [a]
117−instance Ord a => SwaggerMonoid (Set a)
118instance Ord k => SwaggerMonoid (Map k v)
152instance Ord k => SwaggerMonoid (Map k v)
119
153
120−instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
154+instance {-# OVERLAPPABLE #-} (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
121 swaggerMempty = mempty
155 swaggerMempty = mempty
122 swaggerMappend = HashMap.unionWith (\_old new -> new)
156 swaggerMappend = HashMap.unionWith (\_old new -> new)
123
157
124−instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where
125− swaggerMempty = mempty
126− swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)
127−
128instance SwaggerMonoid Text where
158instance SwaggerMonoid Text where
129 swaggerMempty = mempty
159 swaggerMempty = mempty
130 swaggerMappend x "" = x
160 swaggerMappend x "" = x
@@ -135,5 +165,3 @@ instance SwaggerMonoid (Maybe a) where
135 swaggerMappend x Nothing = x
165 swaggerMappend x Nothing = x
136 swaggerMappend _ y = y
166 swaggerMappend _ y = y
137
167
138−encodePretty :: ToJSON a => a -> BSL.ByteString
139−encodePretty = P.encodePretty' $ P.defConfig { P.confCompare = P.compare }
src/Data/Swagger/Lens.hsnew file+150
@@ -0,0 +1,150 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE TemplateHaskell #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+module Data.Swagger.Lens where
11+
12+import Control.Lens
13+import Data.Aeson (Value)
14+import Data.Scientific (Scientific)
15+import Data.Swagger.Internal
16+import Data.Swagger.Internal.Utils
17+import Data.Text (Text)
18+
19+-- * Classy lenses
20+
21+makeFields ''Swagger
22+makeFields ''Host
23+makeFields ''Info
24+makeFields ''Contact
25+makeFields ''License
26+makeFields ''PathItem
27+makeFields ''Tag
28+makeFields ''Operation
29+makeFields ''Param
30+makeLensesWith swaggerFieldRules ''ParamOtherSchema
31+makeFields ''Header
32+makeFields ''Schema
33+makeFields ''NamedSchema
34+makeLensesWith swaggerFieldRules ''ParamSchema
35+makeFields ''Xml
36+makeLensesWith swaggerFieldRules ''Responses
37+makeFields ''Response
38+makeLensesWith swaggerFieldRules ''SecurityScheme
39+makeFields ''ApiKeyParams
40+makeFields ''OAuth2Params
41+makeFields ''ExternalDocs
42+
43+-- * Prisms
44+-- ** 'ParamAnySchema' prisms
45+makePrisms ''ParamAnySchema
46+-- ** 'SecuritySchemeType' prisms
47+makePrisms ''SecuritySchemeType
48+
49+-- ** 'SwaggerItems' prisms
50+
51+_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema]
52+_SwaggerItemsArray
53+ = prism (\x -> SwaggerItemsArray x) $ \x -> case x of
54+ SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
55+ SwaggerItemsObject o -> Left (SwaggerItemsObject o)
56+ SwaggerItemsArray a -> Right a
57+
58+_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema)
59+_SwaggerItemsObject
60+ = prism (\x -> SwaggerItemsObject x) $ \x -> case x of
61+ SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
62+ SwaggerItemsObject o -> Right o
63+ SwaggerItemsArray a -> Left (SwaggerItemsArray a)
64+
65+_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)
66+_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)
67+
68+-- =============================================================
69+-- More helpful instances for easier access to schema properties
70+
71+type instance Index Responses = HttpStatusCode
72+type instance Index Operation = HttpStatusCode
73+
74+type instance IxValue Responses = Referenced Response
75+type instance IxValue Operation = Referenced Response
76+
77+instance Ixed Responses where ix n = responses . ix n
78+instance At Responses where at n = responses . at n
79+
80+instance Ixed Operation where ix n = responses . ix n
81+instance At Operation where at n = responses . at n
82+
83+-- HasType instances
84+instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_
85+instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_
86+instance HasType NamedSchema (SwaggerType Schema) where type_ = schema.paramSchema.type_
87+instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_
88+
89+-- HasDefault instances
90+instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
91+instance HasDefault Schema (Maybe Value) where default_ = paramSchema.default_
92+instance HasDefault ParamOtherSchema (Maybe Value) where default_ = paramSchema.default_
93+
94+-- OVERLAPPABLE instances
95+
96+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
97+ => HasFormat s (Maybe Format) where
98+ format = paramSchema.format
99+
100+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
101+ => HasItems s (Maybe (SwaggerItems t)) where
102+ items = paramSchema.items
103+
104+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
105+ => HasMaximum s (Maybe Scientific) where
106+ maximum_ = paramSchema.maximum_
107+
108+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
109+ => HasExclusiveMaximum s (Maybe Bool) where
110+ exclusiveMaximum = paramSchema.exclusiveMaximum
111+
112+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
113+ => HasMinimum s (Maybe Scientific) where
114+ minimum_ = paramSchema.minimum_
115+
116+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
117+ => HasExclusiveMinimum s (Maybe Bool) where
118+ exclusiveMinimum = paramSchema.exclusiveMinimum
119+
120+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
121+ => HasMaxLength s (Maybe Integer) where
122+ maxLength = paramSchema.maxLength
123+
124+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
125+ => HasMinLength s (Maybe Integer) where
126+ minLength = paramSchema.minLength
127+
128+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
129+ => HasPattern s (Maybe Text) where
130+ pattern = paramSchema.pattern
131+
132+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
133+ => HasMaxItems s (Maybe Integer) where
134+ maxItems = paramSchema.maxItems
135+
136+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
137+ => HasMinItems s (Maybe Integer) where
138+ minItems = paramSchema.minItems
139+
140+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
141+ => HasUniqueItems s (Maybe Bool) where
142+ uniqueItems = paramSchema.uniqueItems
143+
144+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
145+ => HasEnum s (Maybe [Value]) where
146+ enum_ = paramSchema.enum_
147+
148+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
149+ => HasMultipleOf s (Maybe Scientific) where
150+ multipleOf = paramSchema.multipleOf
src/Data/OpenApi/ParamSchema.hs → src/Data/Swagger/ParamSchema.hsrenamed+6−9
@@ -1,10 +1,12 @@
1-- |
1-- |
2−-- Module: Data.OpenApi.ParamSchema
2+-- Module: Data.Swagger.ParamSchema
3+-- Copyright: (c) 2015 GetShopTV
4+-- License: BSD3
3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4-- Stability: experimental
6-- Stability: experimental
5--
7--
6-- Types and functions for working with Swagger parameter schema.
8-- Types and functions for working with Swagger parameter schema.
7−module Data.OpenApi.ParamSchema (
9+module Data.Swagger.ParamSchema (
8 -- * Encoding
10 -- * Encoding
9 ToParamSchema(..),
11 ToParamSchema(..),
10
12
@@ -12,15 +14,10 @@ module Data.OpenApi.ParamSchema (
12 genericToParamSchema,
14 genericToParamSchema,
13 toParamSchemaBoundedIntegral,
15 toParamSchemaBoundedIntegral,
14
16
15− -- * Schema templates
16− passwordSchema,
17− binarySchema,
18− byteSchema,
19−
20 -- * Generic encoding configuration
17 -- * Generic encoding configuration
21 SchemaOptions(..),
18 SchemaOptions(..),
22 defaultSchemaOptions,
19 defaultSchemaOptions,
23) where
20) where
24
21
25−import Data.OpenApi.Internal.ParamSchema
22+import Data.Swagger.Internal.ParamSchema
26−import Data.OpenApi.SchemaOptions
23+import Data.Swagger.SchemaOptions
src/Data/OpenApi/Schema.hs → src/Data/Swagger/Schema.hsrenamed+6−19
@@ -1,10 +1,12 @@
1-- |
1-- |
2−-- Module: Data.OpenApi.Schema
2+-- Module: Data.Swagger.Schema
3+-- Copyright: (c) 2015 GetShopTV
4+-- License: BSD3
3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4-- Stability: experimental
6-- Stability: experimental
5--
7--
6-- Types and functions for working with Swagger schema.
8-- Types and functions for working with Swagger schema.
7−module Data.OpenApi.Schema (
9+module Data.Swagger.Schema (
8 -- * Encoding
10 -- * Encoding
9 ToSchema(..),
11 ToSchema(..),
10 declareSchema,
12 declareSchema,
@@ -17,25 +19,11 @@ module Data.OpenApi.Schema (
17 -- * Generic schema encoding
19 -- * Generic schema encoding
18 genericDeclareNamedSchema,
20 genericDeclareNamedSchema,
19 genericDeclareSchema,
21 genericDeclareSchema,
20− genericDeclareNamedSchemaNewtype,
21− genericNameSchema,
22−
23− -- ** 'Bounded' 'Integral'
24 genericToNamedSchemaBoundedIntegral,
22 genericToNamedSchemaBoundedIntegral,
25 toSchemaBoundedIntegral,
23 toSchemaBoundedIntegral,
26−
27− -- ** 'Bounded' 'Enum' key mappings
28− declareSchemaBoundedEnumKeyMapping,
29− toSchemaBoundedEnumKeyMapping,
30−
31− -- ** Reusing 'ToParamSchema'
32 paramSchemaToNamedSchema,
24 paramSchemaToNamedSchema,
33 paramSchemaToSchema,
25 paramSchemaToSchema,
34
26
35− -- * Sketching @'Schema'@s using @'ToJSON'@
36− sketchSchema,
37− sketchStrictSchema,
38−
39 -- * Inlining @'Schema'@s
27 -- * Inlining @'Schema'@s
40 inlineNonRecursiveSchemas,
28 inlineNonRecursiveSchemas,
41 inlineAllSchemas,
29 inlineAllSchemas,
@@ -45,8 +33,7 @@ module Data.OpenApi.Schema (
45 -- * Generic encoding configuration
33 -- * Generic encoding configuration
46 SchemaOptions(..),
34 SchemaOptions(..),
47 defaultSchemaOptions,
35 defaultSchemaOptions,
48− fromAesonOptions,
49) where
36) where
50
37
51−import Data.OpenApi.Internal.Schema
38+import Data.Swagger.Internal.Schema
52−import Data.OpenApi.SchemaOptions
39+import Data.Swagger.SchemaOptions
src/Data/Swagger/SchemaOptions.hsnew file+37
@@ -0,0 +1,37 @@
1+module Data.Swagger.SchemaOptions where
2+
3+-- | Options that specify how to encode your type to Swagger schema.
4+data SchemaOptions = SchemaOptions
5+ { -- | Function applied to field labels. Handy for removing common record prefixes for example.
6+ fieldLabelModifier :: String -> String
7+ -- | Function applied to constructor tags which could be handy for lower-casing them for example.
8+ , constructorTagModifier :: String -> String
9+ -- | Function applied to datatype name.
10+ , datatypeNameModifier :: String -> String
11+ -- | If @'True'@ the constructors of a datatype, with all nullary constructors,
12+ -- will be encoded to a string enumeration schema with the constructor tags as possible values.
13+ , allNullaryToStringTag :: Bool
14+ -- | Hide the field name when a record constructor has only one field, like a newtype.
15+ , unwrapUnaryRecords :: Bool
16+ }
17+
18+-- | Default encoding @'SchemaOptions'@.
19+--
20+-- @
21+-- 'SchemaOptions'
22+-- { 'fieldLabelModifier' = id
23+-- , 'constructorTagModifier' = id
24+-- , 'datatypeNameModifier' = id
25+-- , 'allNullaryToStringTag' = True
26+-- , 'unwrapUnaryRecords' = False
27+-- }
28+-- @
29+defaultSchemaOptions :: SchemaOptions
30+defaultSchemaOptions = SchemaOptions
31+ { fieldLabelModifier = id
32+ , constructorTagModifier = id
33+ , datatypeNameModifier = id
34+ , allNullaryToStringTag = True
35+ , unwrapUnaryRecords = False
36+ }
37+
stack.yaml+2−6
@@ -1,9 +1,5 @@
1−resolver: lts-16.31
1+flags: {}
2packages:
2packages:
3- '.'
3- '.'
4extra-deps:
4extra-deps:
5−- optics-core-0.3
5+resolver: lts-3.12
6−- optics-th-0.3
7−- optics-extra-0.3
8−- indexed-profunctors-0.1
9−- insert-ordered-containers-0.2.3.1
swagger2.cabalnew file+81
@@ -0,0 +1,81 @@
1+name: swagger2
2+version: 1.2.1
3+synopsis: Swagger 2.0 data model
4+description: Please see README.md
5+homepage: https://github.com/GetShopTV/swagger2
6+bug-reports: https://github.com/GetShopTV/swagger2/issues
7+license: BSD3
8+license-file: LICENSE
9+author: Nickolay Kudasov
10+maintainer: nickolay@getshoptv.com
11+copyright: (c) 2015, GetShopTV
12+category: Web
13+build-type: Simple
14+extra-source-files:
15+ README.md
16+ , CHANGELOG.md
17+ , examples/*.hs
18+cabal-version: >=1.10
19+
20+library
21+ hs-source-dirs: src
22+ exposed-modules:
23+ Data.Swagger
24+ Data.Swagger.Declare
25+ Data.Swagger.Lens
26+ Data.Swagger.ParamSchema
27+ Data.Swagger.Schema
28+ Data.Swagger.SchemaOptions
29+
30+ -- internal modules
31+ Data.Swagger.Internal
32+ Data.Swagger.Internal.Schema
33+ Data.Swagger.Internal.ParamSchema
34+ Data.Swagger.Internal.Utils
35+ build-depends: base == 4.*
36+ , aeson
37+ , containers
38+ , hashable
39+ , http-media
40+ , mtl
41+ , network
42+ , text
43+ , template-haskell
44+ , time
45+ , unordered-containers
46+ , lens
47+ , scientific
48+ default-language: Haskell2010
49+
50+test-suite spec
51+ type: exitcode-stdio-1.0
52+ hs-source-dirs: test
53+ main-is: Spec.hs
54+ build-depends: base == 4.*
55+ , swagger2
56+ , hspec
57+ , HUnit
58+ , QuickCheck
59+ , text
60+ , aeson
61+ , aeson-qq
62+ , containers
63+ , unordered-containers
64+ , vector
65+ , lens
66+ other-modules:
67+ SpecCommon
68+ Data.SwaggerSpec
69+ Data.Swagger.SchemaSpec
70+ default-language: Haskell2010
71+
72+test-suite doctest
73+ build-depends: base, doctest, Glob
74+ default-language: Haskell2010
75+ hs-source-dirs: test
76+ main-is: DocTest.hs
77+ type: exitcode-stdio-1.0
78+
79+source-repository head
80+ type: git
81+ location: https://github.com/GetShopTV/swagger2.git
test/Data/OpenApi/CommonTestTypes.hsdeleted−1042
@@ -1,1042 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE QuasiQuotes #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.OpenApi.CommonTestTypes where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)
11−import Data.Aeson.QQ.Simple
12−import Data.Aeson.Types (toJSONKeyText)
13−import Data.Char
14−import Data.Map (Map)
15−import Data.Proxy
16−import Data.Set (Set)
17−import qualified Data.Text as Text
18−import Data.Word
19−import GHC.Generics
20−
21−import Data.OpenApi
22−
23−-- ========================================================================
24−-- Unit type
25−-- ========================================================================
26−
27−data Unit = Unit deriving (Generic)
28−instance ToParamSchema Unit
29−instance ToSchema Unit
30−
31−unitSchemaJSON :: Value
32−unitSchemaJSON = [aesonQQ|
33−{
34− "type": "string",
35− "enum": ["Unit"]
36−}
37−|]
38−
39−-- ========================================================================
40−-- Color (enum)
41−-- ========================================================================
42−data Color
43− = Red
44− | Green
45− | Blue
46− deriving (Generic)
47−instance ToParamSchema Color
48−instance ToSchema Color
49−
50−colorSchemaJSON :: Value
51−colorSchemaJSON = [aesonQQ|
52−{
53− "type": "string",
54− "enum": ["Red", "Green", "Blue"]
55−}
56−|]
57−
58−-- ========================================================================
59−-- Shade (paramSchemaToNamedSchema)
60−-- ========================================================================
61−
62−data Shade = Dim | Bright deriving (Generic)
63−instance ToParamSchema Shade
64−
65−instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
66−
67−shadeSchemaJSON :: Value
68−shadeSchemaJSON = [aesonQQ|
69−{
70− "type": "string",
71− "enum": ["Dim", "Bright"]
72−}
73−|]
74−
75−-- ========================================================================
76−-- Paint (record with bounded enum property)
77−-- ========================================================================
78−
79−newtype Paint = Paint { color :: Color }
80− deriving (Generic)
81−instance ToSchema Paint
82−
83−paintSchemaJSON :: Value
84−paintSchemaJSON = [aesonQQ|
85−{
86− "type": "object",
87− "properties":
88− {
89− "color":
90− {
91− "$ref": "#/components/schemas/Color"
92− }
93− },
94− "required": ["color"]
95−}
96−|]
97−
98−paintInlinedSchemaJSON :: Value
99−paintInlinedSchemaJSON = [aesonQQ|
100−{
101− "type": "object",
102− "properties":
103− {
104− "color":
105− {
106− "type": "string",
107− "enum": ["Red", "Green", "Blue"]
108− }
109− },
110− "required": ["color"]
111−}
112−|]
113−
114−-- ========================================================================
115−-- Status (constructorTagModifier)
116−-- ========================================================================
117−
118−data Status
119− = StatusOk
120− | StatusError
121− deriving (Generic)
122−
123−instance ToParamSchema Status where
124− toParamSchema = genericToParamSchema defaultSchemaOptions
125− { constructorTagModifier = map toLower . drop (length "Status") }
126−instance ToSchema Status where
127− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
128− { constructorTagModifier = map toLower . drop (length "Status") }
129−
130−statusSchemaJSON :: Value
131−statusSchemaJSON = [aesonQQ|
132−{
133− "type": "string",
134− "enum": ["ok", "error"]
135−}
136−|]
137−
138−-- ========================================================================
139−-- Email (newtype with unwrapUnaryRecords set to True)
140−-- ========================================================================
141−
142−newtype Email = Email { getEmail :: String }
143− deriving (Generic)
144−instance ToParamSchema Email
145−instance ToSchema Email where
146− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
147− { unwrapUnaryRecords = True }
148−
149−emailSchemaJSON :: Value
150−emailSchemaJSON = [aesonQQ|
151−{
152− "type": "string"
153−}
154−|]
155−
156−-- ========================================================================
157−-- UserId (non-record newtype)
158−-- ========================================================================
159−
160−newtype UserId = UserId Integer
161− deriving (Eq, Ord, Generic)
162−instance ToParamSchema UserId
163−instance ToSchema UserId
164−
165−userIdSchemaJSON :: Value
166−userIdSchemaJSON = [aesonQQ|
167−{
168− "type": "integer"
169−}
170−|]
171−
172−-- ========================================================================
173−-- UserGroup (set newtype)
174−-- ========================================================================
175−
176−newtype UserGroup = UserGroup (Set UserId)
177− deriving (Generic)
178−instance ToSchema UserGroup
179−
180−userGroupSchemaJSON :: Value
181−userGroupSchemaJSON = [aesonQQ|
182−{
183− "type": "array",
184− "items": { "$ref": "#/components/schemas/UserId" },
185− "uniqueItems": true
186−}
187−|]
188−
189−-- ========================================================================
190−-- Person (simple record with optional fields)
191−-- ========================================================================
192−data Person = Person
193− { name :: String
194− , phone :: Integer
195− , email :: Maybe String
196− } deriving (Generic)
197−
198−instance ToSchema Person
199−
200−personSchemaJSON :: Value
201−personSchemaJSON = [aesonQQ|
202−{
203− "type": "object",
204− "properties":
205− {
206− "name": { "type": "string" },
207− "phone": { "type": "integer" },
208− "email": { "type": "string" }
209− },
210− "required": ["name", "phone"]
211−}
212−|]
213−
214−-- ========================================================================
215−-- Player (record newtype)
216−-- ========================================================================
217−
218−newtype Player = Player
219− { position :: Point
220− } deriving (Generic)
221−instance ToSchema Player
222−
223−playerSchemaJSON :: Value
224−playerSchemaJSON = [aesonQQ|
225−{
226− "type": "object",
227− "properties":
228− {
229− "position":
230− {
231− "$ref": "#/components/schemas/Point"
232− }
233− },
234− "required": ["position"]
235−}
236−|]
237−
238−newtype Players = Players [Inlined Player]
239− deriving (Generic)
240−instance ToSchema Players
241−
242−playersSchemaJSON :: Value
243−playersSchemaJSON = [aesonQQ|
244−{
245− "type": "array",
246− "items":
247− {
248− "type": "object",
249− "properties":
250− {
251− "position":
252− {
253− "$ref": "#/components/schemas/Point"
254− }
255− },
256− "required": ["position"]
257− }
258−}
259−|]
260−
261−-- ========================================================================
262−-- Character (sum type with ref and record in alternative)
263−-- ========================================================================
264−
265−data Character
266− = PC Player
267− | NPC { npcName :: String, npcPosition :: Point }
268− deriving (Generic)
269−instance ToSchema Character
270−
271−characterSchemaJSON :: Value
272−characterSchemaJSON = [aesonQQ|
273−{
274− "oneOf": [
275− {
276− "required": [
277− "tag",
278− "contents"
279− ],
280− "type": "object",
281− "properties": {
282− "tag": {
283− "type": "string",
284− "enum": [
285− "PC"
286− ]
287− },
288− "contents": {
289− "$ref": "#/components/schemas/Player"
290− }
291− }
292− },
293− {
294− "required": [
295− "npcName",
296− "npcPosition",
297− "tag"
298− ],
299− "type": "object",
300− "properties": {
301− "tag": {
302− "type": "string",
303− "enum": [
304− "NPC"
305− ]
306− },
307− "npcPosition": {
308− "$ref": "#/components/schemas/Point"
309− },
310− "npcName": {
311− "type": "string"
312− }
313− }
314− }
315− ],
316− "type": "object"
317−}
318−
319−|]
320−
321−characterInlinedSchemaJSON :: Value
322−characterInlinedSchemaJSON = [aesonQQ|
323−{
324− "oneOf": [
325− {
326− "required": [
327− "tag",
328− "contents"
329− ],
330− "type": "object",
331− "properties": {
332− "tag": {
333− "type": "string",
334− "enum": [
335− "PC"
336− ]
337− },
338− "contents": {
339− "required": [
340− "position"
341− ],
342− "type": "object",
343− "properties": {
344− "position": {
345− "required": [
346− "x",
347− "y"
348− ],
349− "type": "object",
350− "properties": {
351− "x": {
352− "format": "double",
353− "type": "number"
354− },
355− "y": {
356− "format": "double",
357− "type": "number"
358− }
359− }
360− }
361− }
362− }
363− }
364− },
365− {
366− "required": [
367− "npcName",
368− "npcPosition",
369− "tag"
370− ],
371− "type": "object",
372− "properties": {
373− "tag": {
374− "type": "string",
375− "enum": [
376− "NPC"
377− ]
378− },
379− "npcPosition": {
380− "required": [
381− "x",
382− "y"
383− ],
384− "type": "object",
385− "properties": {
386− "x": {
387− "format": "double",
388− "type": "number"
389− },
390− "y": {
391− "format": "double",
392− "type": "number"
393− }
394− }
395− },
396− "npcName": {
397− "type": "string"
398− }
399− }
400− }
401− ],
402− "type": "object"
403−}
404−|]
405−
406−characterInlinedPlayerSchemaJSON :: Value
407−characterInlinedPlayerSchemaJSON = [aesonQQ|
408−{
409− "oneOf": [
410− {
411− "required": [
412− "tag",
413− "contents"
414− ],
415− "type": "object",
416− "properties": {
417− "tag": {
418− "type": "string",
419− "enum": [
420− "PC"
421− ]
422− },
423− "contents": {
424− "required": [
425− "position"
426− ],
427− "type": "object",
428− "properties": {
429− "position": {
430− "$ref": "#/components/schemas/Point"
431− }
432− }
433− }
434− }
435− },
436− {
437− "required": [
438− "npcName",
439− "npcPosition",
440− "tag"
441− ],
442− "type": "object",
443− "properties": {
444− "tag": {
445− "type": "string",
446− "enum": [
447− "NPC"
448− ]
449− },
450− "npcPosition": {
451− "$ref": "#/components/schemas/Point"
452− },
453− "npcName": {
454− "type": "string"
455− }
456− }
457− }
458− ],
459− "type": "object"
460−}
461−|]
462−
463−-- ========================================================================
464−-- ISPair (non-record product data type)
465−-- ========================================================================
466−data ISPair = ISPair Integer String
467− deriving (Generic)
468−
469−instance ToSchema ISPair
470−
471−ispairSchemaJSON :: Value
472−ispairSchemaJSON = [aesonQQ|
473−{
474− "type": "array",
475− "items":
476− [
477− { "type": "integer" },
478− { "type": "string" }
479− ],
480− "minItems": 2,
481− "maxItems": 2
482−}
483−|]
484−
485−-- ========================================================================
486−-- Point (record data type with custom fieldLabelModifier)
487−-- ========================================================================
488−
489−data Point = Point
490− { pointX :: Double
491− , pointY :: Double
492− } deriving (Generic)
493−
494−instance ToSchema Point where
495− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
496− { fieldLabelModifier = map toLower . drop (length "point") }
497−
498−pointSchemaJSON :: Value
499−pointSchemaJSON = [aesonQQ|
500−{
501− "type": "object",
502− "properties":
503− {
504− "x": { "type": "number", "format": "double" },
505− "y": { "type": "number", "format": "double" }
506− },
507− "required": ["x", "y"]
508−}
509−|]
510−
511−-- ========================================================================
512−-- Point (record data type with multiple fields)
513−-- ========================================================================
514−
515−data Point5 = Point5
516− { point5X :: Double
517− , point5Y :: Double
518− , point5Z :: Double
519− , point5U :: Double
520− , point5V :: Double -- 5 dimensional!
521− } deriving (Generic)
522−
523−instance ToSchema Point5 where
524− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
525− { fieldLabelModifier = map toLower . drop (length "point5") }
526−
527−point5SchemaJSON :: Value
528−point5SchemaJSON = [aesonQQ|
529−{
530− "type": "object",
531− "properties":
532− {
533− "x": { "type": "number", "format": "double" },
534− "y": { "type": "number", "format": "double" },
535− "z": { "type": "number", "format": "double" },
536− "u": { "type": "number", "format": "double" },
537− "v": { "type": "number", "format": "double" }
538− },
539− "required": ["x", "y", "z", "u", "v"]
540−}
541−|]
542−
543−point5Properties :: [String]
544−point5Properties = ["x", "y", "z", "u", "v"]
545−
546−-- ========================================================================
547−-- MyRoseTree (custom datatypeNameModifier)
548−-- ========================================================================
549−
550−data MyRoseTree = MyRoseTree
551− { root :: String
552− , trees :: [MyRoseTree]
553− } deriving (Generic)
554−
555−instance ToSchema MyRoseTree where
556− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
557− { datatypeNameModifier = drop (length "My") }
558−
559−myRoseTreeSchemaJSON :: Value
560−myRoseTreeSchemaJSON = [aesonQQ|
561−{
562− "type": "object",
563− "properties":
564− {
565− "root": { "type": "string" },
566− "trees":
567− {
568− "type": "array",
569− "items":
570− {
571− "$ref": "#/components/schemas/RoseTree"
572− }
573− }
574− },
575− "required": ["root", "trees"]
576−}
577−|]
578−
579−data MyRoseTree' = MyRoseTree'
580− { root' :: String
581− , trees' :: [MyRoseTree']
582− } deriving (Generic)
583−
584−instance ToSchema MyRoseTree' where
585− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
586− { datatypeNameModifier = map toLower }
587−
588−myRoseTreeSchemaJSON' :: Value
589−myRoseTreeSchemaJSON' = [aesonQQ|
590−{
591− "type": "object",
592− "properties":
593− {
594− "root'": { "type": "string" },
595− "trees'":
596− {
597− "type": "array",
598− "items":
599− {
600− "$ref": "#/components/schemas/myrosetree'"
601− }
602− }
603− },
604− "required": ["root'", "trees'"]
605−}
606−|]
607−
608−-- ========================================================================
609−-- Inlined (newtype for inlining schemas)
610−-- ========================================================================
611−
612−newtype Inlined a = Inlined { getInlined :: a }
613−
614−instance ToSchema a => ToSchema (Inlined a) where
615− declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
616− where
617− unname (NamedSchema _ s) = NamedSchema Nothing s
618−
619−-- ========================================================================
620−-- Light (sum type with unwrapUnaryRecords)
621−-- ========================================================================
622−
623−data Light
624− = NoLight
625− | LightFreq Double
626− | LightColor Color
627− | LightWaveLength { waveLength :: Double }
628− deriving (Generic)
629−
630−instance ToSchema Light where
631− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
632− { unwrapUnaryRecords = True }
633−
634−lightSchemaJSON :: Value
635−lightSchemaJSON = [aesonQQ|
636−{
637− "oneOf": [
638− {
639− "required": [
640− "tag"
641− ],
642− "type": "object",
643− "properties": {
644− "tag": {
645− "type": "string",
646− "enum": [
647− "NoLight"
648− ]
649− }
650− }
651− },
652− {
653− "required": [
654− "tag",
655− "contents"
656− ],
657− "type": "object",
658− "properties": {
659− "tag": {
660− "type": "string",
661− "enum": [
662− "LightFreq"
663− ]
664− },
665− "contents": {
666− "format": "double",
667− "type": "number"
668− }
669− }
670− },
671− {
672− "required": [
673− "tag",
674− "contents"
675− ],
676− "type": "object",
677− "properties": {
678− "tag": {
679− "type": "string",
680− "enum": [
681− "LightColor"
682− ]
683− },
684− "contents": {
685− "$ref": "#/components/schemas/Color"
686− }
687− }
688− },
689− {
690− "required": [
691− "waveLength",
692− "tag"
693− ],
694− "type": "object",
695− "properties": {
696− "tag": {
697− "type": "string",
698− "enum": [
699− "LightWaveLength"
700− ]
701− },
702− "waveLength": {
703− "format": "double",
704− "type": "number"
705− }
706− }
707− }
708− ],
709− "type": "object"
710−}
711−|]
712−
713−lightInlinedSchemaJSON :: Value
714−lightInlinedSchemaJSON = [aesonQQ|
715−{
716− "oneOf": [
717− {
718− "required": [
719− "tag"
720− ],
721− "type": "object",
722− "properties": {
723− "tag": {
724− "type": "string",
725− "enum": [
726− "NoLight"
727− ]
728− }
729− }
730− },
731− {
732− "required": [
733− "tag",
734− "contents"
735− ],
736− "type": "object",
737− "properties": {
738− "tag": {
739− "type": "string",
740− "enum": [
741− "LightFreq"
742− ]
743− },
744− "contents": {
745− "format": "double",
746− "type": "number"
747− }
748− }
749− },
750− {
751− "required": [
752− "tag",
753− "contents"
754− ],
755− "type": "object",
756− "properties": {
757− "tag": {
758− "type": "string",
759− "enum": [
760− "LightColor"
761− ]
762− },
763− "contents": {
764− "type": "string",
765− "enum": [
766− "Red",
767− "Green",
768− "Blue"
769− ]
770− }
771− }
772− },
773− {
774− "required": [
775− "waveLength",
776− "tag"
777− ],
778− "type": "object",
779− "properties": {
780− "tag": {
781− "type": "string",
782− "enum": [
783− "LightWaveLength"
784− ]
785− },
786− "waveLength": {
787− "format": "double",
788− "type": "number"
789− }
790− }
791− }
792− ],
793− "type": "object"
794−}
795−|]
796−
797−-- ========================================================================
798−-- ResourceId (series of newtypes)
799−-- ========================================================================
800−
801−newtype Id = Id String deriving (Generic)
802−instance ToSchema Id
803−
804−newtype ResourceId = ResourceId Id deriving (Generic)
805−instance ToSchema ResourceId
806−
807−-- ========================================================================
808−-- ButtonImages (bounded enum key mapping)
809−-- ========================================================================
810−
811−data ButtonState = Neutral | Focus | Active | Hover | Disabled
812− deriving (Show, Bounded, Enum, Generic)
813−
814−instance ToJSON ButtonState
815−instance ToSchema ButtonState
816−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)
817−
818−type ImageUrl = Text.Text
819−
820−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
821− deriving (Generic)
822−
823−instance ToJSON ButtonImages where
824− toJSON = toJSON . getButtonImages
825−
826−instance ToSchema ButtonImages where
827− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
828− declareSchemaBoundedEnumKeyMapping
829−
830−buttonImagesSchemaJSON :: Value
831−buttonImagesSchemaJSON = [aesonQQ|
832−{
833− "type": "object",
834− "properties":
835− {
836− "Neutral": { "type": "string" },
837− "Focus": { "type": "string" },
838− "Active": { "type": "string" },
839− "Hover": { "type": "string" },
840− "Disabled": { "type": "string" }
841− }
842−}
843−|]
844−
845−-- ========================================================================
846−-- SingleMaybeField (single field data with optional field)
847−-- ========================================================================
848−
849−data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }
850− deriving (Show, Generic)
851−
852−instance ToJSON SingleMaybeField
853−instance ToSchema SingleMaybeField
854−
855−singleMaybeFieldSchemaJSON :: Value
856−singleMaybeFieldSchemaJSON = [aesonQQ|
857−{
858− "type": "object",
859− "properties":
860− {
861− "singleMaybeField": { "type": "string" }
862− }
863−}
864−|]
865−
866−-- ========================================================================
867−-- Natural Language (single field data with recursive fields)
868−-- ========================================================================
869−
870−data Predicate
871− = PredicateNoun Noun
872− | PredicateOmitted Omitted
873− deriving (Eq, Ord, Read, Show, Generic)
874−instance ToJSON Predicate
875−instance ToSchema Predicate
876−
877−data Noun
878− = Noun
879− { nounSurf :: LangWord
880− , nounModify :: [Modifier]
881− }
882− deriving (Eq, Ord, Read, Show, Generic)
883−instance ToJSON Noun
884−instance ToSchema Noun
885−
886−data LangWord
887− = LangWord
888− { langWordSurf :: String
889− , langWordBase :: String
890− }
891− deriving (Eq, Ord, Read, Show, Generic)
892−instance ToJSON LangWord
893−instance ToSchema LangWord
894−
895−data Modifier
896− = ModifierNoun Noun
897− | ModifierOmitted Omitted
898− deriving (Eq, Ord, Read, Show, Generic)
899−instance ToJSON Modifier
900−instance ToSchema Modifier
901−
902−newtype Omitted
903− = Omitted
904− { omittedModify :: [Modifier]
905− }
906− deriving (Eq, Ord, Read, Show, Generic)
907−instance ToJSON Omitted
908−instance ToSchema Omitted
909−
910−predicateSchemaDeclareJSON :: Value
911−predicateSchemaDeclareJSON = [aesonQQ|
912−[
913− {
914− "Predicate": {
915− "oneOf": [
916− {
917− "properties": {
918− "contents": { "$ref": "#/components/schemas/Noun" },
919− "tag": { "enum": ["PredicateNoun"], "type": "string" }
920− },
921− "required": ["tag", "contents"],
922− "type": "object"
923− },
924− {
925− "properties": {
926− "contents": { "$ref": "#/components/schemas/Omitted" },
927− "tag": { "enum": ["PredicateOmitted"], "type": "string" }
928− },
929− "required": ["tag", "contents"],
930− "type": "object"
931− }
932− ],
933− "type": "object"
934− },
935− "Noun": {
936− "properties": {
937− "nounModify": {
938− "items": { "$ref": "#/components/schemas/Modifier" },
939− "type": "array"
940− },
941− "nounSurf": { "$ref": "#/components/schemas/LangWord" }
942− },
943− "required": ["nounSurf", "nounModify"],
944− "type": "object"
945− },
946− "LangWord": {
947− "properties": {
948− "langWordBase": { "type": "string" },
949− "langWordSurf": { "type": "string" }
950− },
951− "required": ["langWordSurf", "langWordBase"],
952− "type": "object"
953− },
954− "Modifier": {
955− "oneOf": [
956− {
957− "properties": {
958− "contents": { "$ref": "#/components/schemas/Noun" },
959− "tag": { "enum": ["ModifierNoun"], "type": "string" }
960− },
961− "required": ["tag", "contents"],
962− "type": "object"
963− },
964− {
965− "properties": {
966− "contents": { "$ref": "#/components/schemas/Omitted" },
967− "tag": { "enum": ["ModifierOmitted"], "type": "string" }
968− },
969− "required": ["tag", "contents"],
970− "type": "object"
971− }
972− ],
973− "type": "object"
974− },
975− "Omitted": {
976− "properties": {
977− "omittedModify": {
978− "items": { "$ref": "#/components/schemas/Modifier" },
979− "type": "array"
980− }
981− },
982− "required": ["omittedModify"],
983− "type": "object"
984− }
985− },
986− { "$ref": "#/components/schemas/Predicate" }
987−]
988−|]
989−
990−-- ========================================================================
991−-- TimeOfDay
992−-- ========================================================================
993−data TimeOfDay
994− = Int
995− | Pico
996− deriving (Generic)
997−instance ToSchema TimeOfDay
998−instance ToParamSchema TimeOfDay
999−
1000−
1001−timeOfDaySchemaJSON :: Value
1002−timeOfDaySchemaJSON = [aesonQQ|
1003−{
1004− "example": "12:33:15",
1005− "type": "string",
1006− "format": "hh:MM:ss"
1007−}
1008−|]
1009−
1010−timeOfDayParamSchemaJSON :: Value
1011−timeOfDayParamSchemaJSON = [aesonQQ|
1012−{
1013− "type": "string",
1014− "format": "hh:MM:ss"
1015−}
1016−|]
1017−
1018−
1019−-- ========================================================================
1020−-- UnsignedInts
1021−-- ========================================================================
1022−data UnsignedInts = UnsignedInts
1023− { unsignedIntsUint32 :: Word32
1024− , unsignedIntsUint64 :: Word64
1025− } deriving (Generic)
1026−
1027−instance ToSchema UnsignedInts where
1028− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
1029− { fieldLabelModifier = map toLower . drop (length "unsignedInts") }
1030−
1031−unsignedIntsSchemaJSON :: Value
1032−unsignedIntsSchemaJSON = [aesonQQ|
1033−{
1034− "type": "object",
1035− "properties":
1036− {
1037− "uint32": { "type": "integer", "format": "int32", "minimum": 0, "maximum": 4294967295 },
1038− "uint64": { "type": "integer", "format": "int64", "minimum": 0, "maximum": 18446744073709551615 }
1039− },
1040− "required": ["uint32", "uint64"]
1041−}
1042−|]
test/Data/OpenApi/ParamSchemaSpec.hsdeleted−39
@@ -1,39 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE QuasiQuotes #-}
6−{-# LANGUAGE OverloadedStrings #-}
7−module Data.OpenApi.ParamSchemaSpec where
8−
9−import Data.Aeson
10−import Data.Aeson.QQ.Simple
11−import Data.Char
12−import Data.Proxy
13−import GHC.Generics
14−
15−import Data.OpenApi
16−
17−import Data.OpenApi.CommonTestTypes
18−import SpecCommon
19−import Test.Hspec
20−import Data.Time.LocalTime
21−
22−import qualified Data.HashMap.Strict as HM
23−
24−checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
25−checkToParamSchema proxy js = (toParamSchema proxy :: Schema) <=> js
26−
27−spec :: Spec
28−spec = do
29− describe "Generic ToParamSchema" $ do
30− context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON
31− context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON
32− context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON
33− context "Unary records" $ do
34− context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
35− context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
36− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
37−
38−main :: IO ()
39−main = hspec spec
test/Data/OpenApi/Schema/GeneratorSpec.hsdeleted−168
@@ -1,168 +0,0 @@
1−{-# LANGUAGE OverloadedLists #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE PackageImports #-}
4−module Data.OpenApi.Schema.GeneratorSpec where
5−
6−import Prelude ()
7−import Prelude.Compat
8−
9−import Data.OpenApi
10−import Data.OpenApi.Schema.Generator
11−
12−import Control.Lens.Operators
13−import Data.Aeson
14−import Data.Hashable (Hashable)
15−import Data.HashMap.Strict (HashMap)
16−import qualified Data.HashMap.Strict as HashMap
17−import "unordered-containers" Data.HashSet (HashSet)
18−import qualified "unordered-containers" Data.HashSet as HashSet
19−import Data.Int
20−import Data.IntMap (IntMap)
21−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
22−import Data.Map (Map, fromList)
23−import Data.Monoid (mempty)
24−import Data.Proxy
25−import Data.Proxy
26−import Data.Set (Set)
27−import qualified Data.Text as T
28−import qualified Data.Text.Lazy as TL
29−import Data.Time
30−import Data.Version (Version)
31−import Data.Word
32−import GHC.Generics
33−
34−import Test.Hspec
35−import Test.Hspec.QuickCheck
36−import Test.QuickCheck
37−
38−shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
39−shouldValidate = validateFromJSON
40−
41−
42−shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
43−shouldNotValidate = expectFailure . shouldValidate
44−
45−
46−spec :: Spec
47−spec = do
48− describe "FromJSON validation" $ do
49− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
50− prop "Char" $ shouldValidate (Proxy :: Proxy Char)
51− prop "Double" $ shouldValidate (Proxy :: Proxy Double)
52− prop "Float" $ shouldValidate (Proxy :: Proxy Float)
53− prop "Int" $ shouldValidate (Proxy :: Proxy Int)
54− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
55− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
56− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
57− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
58− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
59− prop "Word" $ shouldValidate (Proxy :: Proxy Word)
60− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
61− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
62− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
63− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
64− prop "String" $ shouldValidate (Proxy :: Proxy String)
65− prop "()" $ shouldValidate (Proxy :: Proxy ())
66−-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
67−-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
68− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
69− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
70− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
71− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
72− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
73− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
74− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
75− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
76− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
77− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
78− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
79− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
80− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
81− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
82− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
83− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
84− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
85− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
86− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
87− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
88− describe "Invalid FromJSON validation" $ do
89− prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)
90− prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)
91− prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)
92− prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)
93−
94−-- =============================
95−-- Data types and bunk instances
96−-- =============================
97−
98−data WrongType = WrongType Bool
99−
100−instance FromJSON WrongType where
101− parseJSON = withBool "WrongType" $ return . WrongType
102−
103−instance ToSchema WrongType where
104− declareNamedSchema _ = return . NamedSchema (Just "WrongType") $
105− mempty
106− & type_ ?~ OpenApiObject
107−
108−
109−data MissingRequired = MissingRequired
110− { propA :: String
111− , propB :: Bool
112− }
113−
114−instance FromJSON MissingRequired where
115− parseJSON = withObject "MissingRequired" $ \o ->
116− MissingRequired
117− <$> o .: "propA"
118− <*> o .: "propB"
119−
120−instance ToSchema MissingRequired where
121− declareNamedSchema _ = do
122− stringSchema <- declareSchemaRef (Proxy :: Proxy String)
123− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
124− return . NamedSchema (Just "MissingRequired") $
125− mempty
126− & type_ ?~ OpenApiObject
127− & properties .~ [("propA", stringSchema)
128− ,("propB", boolSchema)
129− ]
130− & required .~ ["propA"]
131−
132−data MissingProperty = MissingProperty
133− { propC :: String
134− , propD :: Bool
135− }
136−
137−instance FromJSON MissingProperty where
138− parseJSON = withObject "MissingProperty" $ \o ->
139− MissingProperty
140− <$> o .: "propC"
141− <*> o .: "propD"
142−
143−instance ToSchema MissingProperty where
144− declareNamedSchema _ = do
145− stringSchema <- declareSchemaRef (Proxy :: Proxy String)
146− return . NamedSchema (Just "MissingProperty") $
147− mempty
148− & type_ ?~ OpenApiObject
149− & properties .~ [("propC", stringSchema)]
150− & required .~ ["propC"]
151−
152−data WrongPropType = WrongPropType
153− { propE :: String
154− }
155−
156−instance FromJSON WrongPropType where
157− parseJSON = withObject "WrongPropType" $ \o ->
158− WrongPropType
159− <$> o .: "propE"
160−
161−instance ToSchema WrongPropType where
162− declareNamedSchema _ = do
163− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
164− return . NamedSchema (Just "WrongPropType") $
165− mempty
166− & type_ ?~ OpenApiObject
167− & properties .~ [("propE", boolSchema)]
168− & required .~ ["propE"]
test/Data/OpenApi/Schema/ValidationSpec.hsdeleted−324
@@ -1,324 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE PackageImports #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# OPTIONS_GHC -fno-warn-orphans #-}
7−module Data.OpenApi.Schema.ValidationSpec where
8−
9−import Control.Applicative
10−import Control.Lens ((&), (.~), (?~))
11−import Data.Aeson
12−#if MIN_VERSION_aeson(2,0,0)
13−import qualified Data.Aeson.Key as Key
14−import qualified Data.Aeson.KeyMap as KeyMap
15−#endif
16−import Data.Aeson.Types
17−import Data.Hashable (Hashable)
18−import Data.HashMap.Strict (HashMap)
19−import qualified Data.HashMap.Strict as HashMap
20−import "unordered-containers" Data.HashSet (HashSet)
21−import qualified "unordered-containers" Data.HashSet as HashSet
22−import Data.Int
23−import Data.IntMap (IntMap)
24−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
25−import Data.Map (Map, fromList)
26−import Data.Monoid (mempty)
27−import Data.Proxy
28−import Data.Set (Set)
29−import qualified Data.Text as T
30−import qualified Data.Text.Lazy as TL
31−import Data.Time
32−import Data.Version (Version)
33−import Data.Word
34−import GHC.Generics
35−
36−import Data.OpenApi
37−import Data.OpenApi.Declare
38−import Data.OpenApi.Aeson.Compat (stringToKey)
39−
40−import Test.Hspec
41−import Test.Hspec.QuickCheck
42−import Test.QuickCheck
43−import Test.QuickCheck.Instances ()
44−
45−shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
46−shouldValidate _ x = validateToJSON x == []
47−
48−shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool
49−shouldNotValidate f = not . null . validateJSON defs sch . f
50− where
51− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
52−
53−spec :: Spec
54−spec = do
55− describe "Validation" $ do
56− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
57− prop "Char" $ shouldValidate (Proxy :: Proxy Char)
58− prop "Double" $ shouldValidate (Proxy :: Proxy Double)
59− prop "Float" $ shouldValidate (Proxy :: Proxy Float)
60− prop "Int" $ shouldValidate (Proxy :: Proxy Int)
61− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
62− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
63− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
64− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
65− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
66− prop "Word" $ shouldValidate (Proxy :: Proxy Word)
67− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
68− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
69− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
70− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
71− prop "String" $ shouldValidate (Proxy :: Proxy String)
72− prop "()" $ shouldValidate (Proxy :: Proxy ())
73− prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
74− prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
75− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
76− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
77− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
78− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
79− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
80− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
81− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
82− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
83− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
84− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
85− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
86− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
87− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
88− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
89− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
90− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
91− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
92− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
93− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
94− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
95− prop "Person" $ shouldValidate (Proxy :: Proxy Person)
96− prop "Color" $ shouldValidate (Proxy :: Proxy Color)
97− prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
98− prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
99− prop "Light" $ shouldValidate (Proxy :: Proxy Light)
100− prop "Light TaggedObject" $ shouldValidate (Proxy :: Proxy LightTaggedObject)
101− prop "Light UntaggedValue" $ shouldValidate (Proxy :: Proxy LightUntaggedValue)
102− prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)
103− prop "Version" $ shouldValidate (Proxy :: Proxy Version)
104− prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)
105−
106− describe "invalid cases" $ do
107− prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON
108− prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON
109− prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON
110− prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON
111− prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON
112−
113−main :: IO ()
114−main = hspec spec
115−
116−-- ========================================================================
117−-- Person (simple record with optional fields)
118−-- ========================================================================
119−data Person = Person
120− { name :: String
121− , phone :: Integer
122− , email :: Maybe String
123− } deriving (Show, Generic)
124−
125−instance ToJSON Person
126−instance ToSchema Person
127−
128−instance Arbitrary Person where
129− arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
130−
131−invalidPersonToJSON :: Person -> Value
132−invalidPersonToJSON Person{..} = object
133− [ stringToKey "personName" .= toJSON name
134− , stringToKey "personPhone" .= toJSON phone
135− , stringToKey "personEmail" .= toJSON email
136− ]
137−
138−-- ========================================================================
139−-- Color (enum)
140−-- ========================================================================
141−data Color = Red | Green | Blue deriving (Show, Generic, Bounded, Enum)
142−
143−instance ToJSON Color
144−instance ToSchema Color
145−
146−instance Arbitrary Color where
147− arbitrary = arbitraryBoundedEnum
148−
149−invalidColorToJSON :: Color -> Value
150−invalidColorToJSON Red = toJSON "red"
151−invalidColorToJSON Green = toJSON "green"
152−invalidColorToJSON Blue = toJSON "blue"
153−
154−-- ========================================================================
155−-- Paint (record with bounded enum property)
156−-- ========================================================================
157−
158−newtype Paint = Paint { color :: Color }
159− deriving (Show, Generic)
160−
161−instance ToJSON Paint
162−instance ToSchema Paint
163−
164−instance Arbitrary Paint where
165− arbitrary = Paint <$> arbitrary
166−
167−invalidPaintToJSON :: Paint -> Value
168−invalidPaintToJSON = toJSON . color
169−
170−-- ========================================================================
171−-- MyRoseTree (custom datatypeNameModifier)
172−-- ========================================================================
173−
174−data MyRoseTree = MyRoseTree
175− { root :: String
176− , trees :: [MyRoseTree]
177− } deriving (Show, Generic)
178−
179−instance ToJSON MyRoseTree
180−
181−instance ToSchema MyRoseTree where
182− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
183− { datatypeNameModifier = drop (length "My") }
184−
185−instance Arbitrary MyRoseTree where
186− arbitrary = fmap (cut limit) $ MyRoseTree <$> arbitrary <*> (take limit <$> arbitrary)
187− where
188− limit = 4
189− cut 0 (MyRoseTree x _ ) = MyRoseTree x []
190− cut n (MyRoseTree x xs) = MyRoseTree x (map (cut (n - 1)) xs)
191−
192−-- ========================================================================
193−-- Light (sum type)
194−-- ========================================================================
195−
196−data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
197−
198−instance ToSchema Light where
199− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { Data.OpenApi.sumEncoding = ObjectWithSingleField }
200−
201−instance ToJSON Light where
202− toJSON = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = ObjectWithSingleField }
203−
204−instance Arbitrary Light where
205− arbitrary = oneof
206− [ return NoLight
207− , LightFreq <$> arbitrary
208− , LightColor <$> arbitrary
209− ]
210−
211−invalidLightToJSON :: Light -> Value
212−invalidLightToJSON = genericToJSON defaultOptions
213−
214−-- Check all SumEncoding flavors.
215−
216−newtype LightTaggedObject = LightTaggedObject Light
217− deriving (Show)
218−
219−instance ToJSON LightTaggedObject where
220− toJSON (LightTaggedObject light) = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = defaultTaggedObject } light
221−
222−instance ToSchema LightTaggedObject where
223− declareNamedSchema _ =
224− genericDeclareNamedSchema defaultSchemaOptions { Data.OpenApi.sumEncoding = defaultTaggedObject } (Proxy :: Proxy Light)
225−
226−instance Arbitrary LightTaggedObject where
227− arbitrary = LightTaggedObject <$> arbitrary
228−
229−newtype LightUntaggedValue = LightUntaggedValue Light
230− deriving (Show)
231−
232−instance ToJSON LightUntaggedValue where
233− toJSON (LightUntaggedValue light) = genericToJSON defaultOptions { Data.Aeson.Types.sumEncoding = UntaggedValue } light
234−
235−instance ToSchema LightUntaggedValue where
236− declareNamedSchema _ =
237− genericDeclareNamedSchema defaultSchemaOptions { Data.OpenApi.sumEncoding = UntaggedValue } (Proxy :: Proxy Light)
238−
239−instance Arbitrary LightUntaggedValue where
240− arbitrary = LightUntaggedValue <$> arbitrary
241−
242−-- ========================================================================
243−-- ButtonImages (bounded enum key mapping)
244−-- ========================================================================
245−
246−data ButtonState = Neutral | Focus | Active | Hover | Disabled
247− deriving (Show, Eq, Ord, Bounded, Enum, Generic)
248−
249−instance ToJSON ButtonState
250−instance ToSchema ButtonState
251−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
252−
253−instance Arbitrary ButtonState where
254− arbitrary = arbitraryBoundedEnum
255−
256−type ImageUrl = T.Text
257−
258−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
259− deriving (Show, Generic)
260−
261−instance ToJSON ButtonImages where
262− toJSON = toJSON . getButtonImages
263−
264−instance ToSchema ButtonImages where
265− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
266− declareSchemaBoundedEnumKeyMapping
267−
268−invalidButtonImagesToJSON :: ButtonImages -> Value
269−invalidButtonImagesToJSON = genericToJSON defaultOptions
270−
271−instance Arbitrary ButtonImages where
272− arbitrary = ButtonImages <$> arbitrary
273−
274−-- ========================================================================
275−-- FreeForm (wraps a raw JSON Value)
276−-- ========================================================================
277−
278−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
279− deriving (Show, Generic)
280−
281−instance ToJSON FreeForm where
282− toJSON = toJSON . jsonContent
283−
284−instance ToSchema FreeForm where
285− declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
286− & type_ ?~ OpenApiObject
287− & additionalProperties ?~ AdditionalPropertiesAllowed True
288−
289−instance Arbitrary FreeForm where
290− arbitrary = (FreeForm . fromList) <$> genObj
291− where
292− genObj = listOf $ do
293− k <- arbitrary
294− v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]
295− pure (k, v)
296−
297−instance Eq ZonedTime where
298− ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
299−
300−-- ========================================================================
301−-- Arbitrary instance for Data.Aeson.Value
302−-- ========================================================================
303−
304−-- These instances were introduces in aeson upstream in 2.0.3
305−#if !MIN_VERSION_aeson(2,0,3)
306−instance Arbitrary Value where
307− -- Weights are almost random
308− -- Uniform oneof tends not to build complex objects cause of recursive call.
309− arbitrary = resize 4 $ frequency
310− [ (3, Object <$> arbitrary)
311− , (3, Array <$> arbitrary)
312− , (3, String <$> arbitrary)
313− , (3, Number <$> arbitrary)
314− , (3, Bool <$> arbitrary)
315− , (1, return Null) ]
316−
317−#if MIN_VERSION_aeson(2,0,0)
318−instance Arbitrary v => Arbitrary (KeyMap.KeyMap v) where
319− arbitrary = KeyMap.fromList <$> arbitrary
320−
321−instance Arbitrary Key.Key where
322− arbitrary = Key.fromText <$> arbitrary
323−#endif
324−#endif
test/Data/OpenApi/SchemaSpec.hsdeleted−119
@@ -1,119 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−{-# LANGUAGE QuasiQuotes #-}
5−module Data.OpenApi.SchemaSpec where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens ((^.))
11−import Data.Aeson (Value)
12−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
13−import Data.Proxy
14−import Data.Set (Set)
15−import qualified Data.Text as Text
16−
17−import Data.OpenApi
18−import Data.OpenApi.Declare
19−
20−import Data.OpenApi.CommonTestTypes
21−import SpecCommon
22−import Test.Hspec
23−
24−import qualified Data.HashMap.Strict as HM
25−import Data.Time.LocalTime
26−
27−checkToSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec
28−checkToSchema proxy js = toSchema proxy <=> js
29−
30−checkSchemaName :: (HasCallStack, ToSchema a) => Maybe String -> Proxy a -> Spec
31−checkSchemaName sname proxy =
32− it ("schema name is " ++ show sname) $
33− schemaName proxy `shouldBe` fmap Text.pack sname
34−
35−checkDefs :: (HasCallStack, ToSchema a) => Proxy a -> [String] -> Spec
36−checkDefs proxy names =
37− it ("uses these definitions " ++ show names) $
38− InsOrdHashMap.keys defs `shouldBe` map Text.pack names
39− where
40− defs = execDeclare (declareNamedSchema proxy) mempty
41−
42−checkProperties :: (HasCallStack, ToSchema a) => Proxy a -> [String] -> Spec
43−checkProperties proxy names =
44− it ("has these fields in order " ++ show names) $
45− InsOrdHashMap.keys fields `shouldBe` map Text.pack names
46− where
47− fields = toSchema proxy ^. properties
48−
49−checkInlinedSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec
50−checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
51−
52−checkInlinedSchemas :: (HasCallStack, ToSchema a) => [String] -> Proxy a -> Value -> Spec
53−checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js
54− where
55− (defs, s) = runDeclare (declareSchema proxy) mempty
56−
57−checkInlinedRecSchema :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec
58−checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js
59− where
60− (defs, s) = runDeclare (declareSchema proxy) mempty
61−
62−checkToSchemaDeclare :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec
63−checkToSchemaDeclare proxy js = runDeclare (declareSchemaRef proxy) mempty <=> js
64−
65−spec :: Spec
66−spec = do
67− describe "Generic ToSchema" $ do
68− context "Unit" $ checkToSchema (Proxy :: Proxy Unit) unitSchemaJSON
69− context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
70− context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
71− context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
72− context "Point5 (many field record)" $ do
73− checkToSchema (Proxy :: Proxy Point5) point5SchemaJSON
74− checkProperties (Proxy :: Proxy Point5) point5Properties
75− context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
76− context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
77− context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
78− context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON
79− context "Unary records" $ do
80− context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
81− context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
82− context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
83− context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
84− context "Natural Language (single field data with recursive fields)" $ checkToSchemaDeclare (Proxy :: Proxy Predicate) predicateSchemaDeclareJSON
85− context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
86− context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
87− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
88− context "Sum types" $ do
89− context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
90− context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
91− context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON
92− context "UnsignedInts" $ checkToSchema (Proxy :: Proxy UnsignedInts) unsignedIntsSchemaJSON
93− context "Schema name" $ do
94− context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)
95− context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
96− context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
97− context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
98− describe "Generic Definitions" $ do
99− context "Unit" $ checkDefs (Proxy :: Proxy Unit) []
100− context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]
101− context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
102− context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
103− context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
104− context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]
105− context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
106− context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
107− describe "Inlining Schemas" $ do
108− context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON
109− context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON
110− context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
111− context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
112− context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
113− context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
114− describe "Bounded Enum key mapping" $ do
115− context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON
116− context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON
117−
118−main :: IO ()
119−main = hspec spec
test/Data/OpenApiSpec.hsdeleted−962
@@ -1,962 +0,0 @@
1−{-# LANGUAGE OverloadedLists #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE QuasiQuotes #-}
5−module Data.OpenApiSpec where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens
11−
12−import Data.Aeson
13−import Data.Aeson.QQ.Simple
14−import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashSet.InsOrd as InsOrdHS
16−import Data.Text (Text)
17−
18−import Data.OpenApi
19−import SpecCommon
20−import Test.Hspec hiding (example)
21−
22−spec :: Spec
23−spec = do
24− describe "License Object" $ licenseExample <=> licenseExampleJSON
25− describe "Contact Object" $ contactExample <=> contactExampleJSON
26− describe "Info Object" $ infoExample <=> infoExampleJSON
27− describe "Operation Object" $ operationExample <=> operationExampleJSON
28− describe "Schema Object" $ do
29− context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
30− context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
31− context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
32− context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON
33− context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
34− describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
35− describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
36− describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
37− describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
38− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON
39− describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
40− describe "Swagger Object" $ do
41− context "Example with no paths" $ emptyPathsFieldExample <=> emptyPathsFieldExampleJSON
42− context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
43− context "PetStore Example" $ do
44− it "decodes successfully" $ do
45− fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: OpenApi) -> True; _ -> False)
46− it "roundtrips: fmap toJSON . fromJSON" $ do
47− (toJSON :: OpenApi -> Value) <$> fromJSON petstoreExampleJSON `shouldBe` Success petstoreExampleJSON
48− context "Security schemes" $ do
49− it "merged correctly" $ do
50− let merged = oAuth2SecurityDefinitionsReadOpenApi <> oAuth2SecurityDefinitionsWriteOpenApi
51− merged `shouldBe` oAuth2SecurityDefinitionsOpenApi
52−
53−main :: IO ()
54−main = hspec spec
55−
56−-- =======================================================================
57−-- Info object
58−-- =======================================================================
59−
60−infoExample :: Info
61−infoExample = mempty
62− & title .~ "Swagger Sample App"
63− & description ?~ "This is a sample server Petstore server."
64− & termsOfService ?~ "http://swagger.io/terms/"
65− & contact ?~ contactExample
66− & license ?~ licenseExample
67− & version .~ "1.0.1"
68−
69−infoExampleJSON :: Value
70−infoExampleJSON = [aesonQQ|
71−{
72− "title": "Swagger Sample App",
73− "description": "This is a sample server Petstore server.",
74− "termsOfService": "http://swagger.io/terms/",
75− "contact": {
76− "name": "API Support",
77− "url": "http://www.swagger.io/support",
78− "email": "support@swagger.io"
79− },
80− "license": {
81− "name": "Apache 2.0",
82− "url": "http://www.apache.org/licenses/LICENSE-2.0.html"
83− },
84− "version": "1.0.1"
85−}
86−|]
87−
88−-- =======================================================================
89−-- Contact object
90−-- =======================================================================
91−
92−contactExample :: Contact
93−contactExample = mempty
94− & name ?~ "API Support"
95− & url ?~ URL "http://www.swagger.io/support"
96− & email ?~ "support@swagger.io"
97−
98−contactExampleJSON :: Value
99−contactExampleJSON = [aesonQQ|
100−{
101− "name": "API Support",
102− "url": "http://www.swagger.io/support",
103− "email": "support@swagger.io"
104−}
105−|]
106−
107−-- =======================================================================
108−-- License object
109−-- =======================================================================
110−
111−licenseExample :: License
112−licenseExample = "Apache 2.0"
113− & url ?~ URL "http://www.apache.org/licenses/LICENSE-2.0.html"
114−
115−licenseExampleJSON :: Value
116−licenseExampleJSON = [aesonQQ|
117−{
118− "name": "Apache 2.0",
119− "url": "http://www.apache.org/licenses/LICENSE-2.0.html"
120−}
121−|]
122−
123−
124−-- =======================================================================
125−-- Operation object
126−-- =======================================================================
127−
128−operationExample :: Operation
129−operationExample = mempty
130− & tags .~ InsOrdHS.fromList ["pet"]
131− & summary ?~ "Updates a pet in the store with form data"
132− & description ?~ ""
133− & operationId ?~ "updatePetWithForm"
134− & parameters .~ [Inline (mempty
135− & name .~ "petId"
136− & description ?~ "ID of pet that needs to be updated"
137− & required ?~ True
138− & in_ .~ ParamPath
139− & schema ?~ Inline (mempty & type_ ?~ OpenApiString))]
140− & requestBody ?~ Inline (
141− mempty & content . at "application/x-www-form-urlencoded" ?~ (mempty & schema ?~ (Inline (mempty
142− & properties . at "petId" ?~ Inline (mempty
143− & description ?~ "Updated name of the pet"
144− & type_ ?~ OpenApiString)
145− & properties . at "status" ?~ Inline (mempty
146− & description ?~ "Updated status of the pet"
147− & type_ ?~ OpenApiString)))))
148− & at 200 ?~ "Pet updated."
149− & at 405 ?~ "Invalid input"
150− & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]
151−
152−operationExampleJSON :: Value
153−operationExampleJSON = [aesonQQ|
154−{
155− "tags": [
156− "pet"
157− ],
158− "summary": "Updates a pet in the store with form data",
159− "description": "",
160− "operationId": "updatePetWithForm",
161− "parameters": [
162− {
163− "required": true,
164− "schema": {
165− "type": "string"
166− },
167− "in": "path",
168− "name": "petId",
169− "description": "ID of pet that needs to be updated"
170− }
171− ],
172− "requestBody": {
173− "content": {
174− "application/x-www-form-urlencoded": {
175− "schema": {
176− "properties": {
177− "petId": {
178− "type": "string",
179− "description": "Updated name of the pet"
180− },
181− "status": {
182− "type": "string",
183− "description": "Updated status of the pet"
184− }
185− }
186− }
187− }
188− }
189− },
190− "responses": {
191− "200": {
192− "description": "Pet updated."
193− },
194− "405": {
195− "description": "Invalid input"
196− }
197− },
198− "security": [
199− {
200− "petstore_auth": [
201− "write:pets",
202− "read:pets"
203− ]
204− }
205− ]
206−}
207−|]
208−
209−-- =======================================================================
210−-- Schema object
211−-- =======================================================================
212−
213−schemaPrimitiveExample :: Schema
214−schemaPrimitiveExample = mempty
215− & type_ ?~ OpenApiString
216− & format ?~ "email"
217−
218−schemaPrimitiveExampleJSON :: Value
219−schemaPrimitiveExampleJSON = [aesonQQ|
220−{
221− "type": "string",
222− "format": "email"
223−}
224−|]
225−
226−schemaSimpleModelExample :: Schema
227−schemaSimpleModelExample = mempty
228− & type_ ?~ OpenApiObject
229− & required .~ [ "name" ]
230− & properties .~
231− [ ("name", Inline (mempty & type_ ?~ OpenApiString))
232− , ("address", Ref (Reference "Address"))
233− , ("age", Inline $ mempty
234− & minimum_ ?~ 0
235− & type_ ?~ OpenApiInteger
236− & format ?~ "int32" ) ]
237−
238−schemaSimpleModelExampleJSON :: Value
239−schemaSimpleModelExampleJSON = [aesonQQ|
240−{ "required": [ "name" ],
241− "properties": {
242− "name": {
243− "type": "string"
244− },
245− "address": {
246− "$ref": "#/components/schemas/Address"
247− },
248− "age": {
249− "format": "int32",
250− "minimum": 0,
251− "type": "integer"
252− }
253− },
254− "type": "object"
255−}
256−|]
257−
258−schemaModelDictExample :: Schema
259−schemaModelDictExample = mempty
260− & type_ ?~ OpenApiObject
261− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ OpenApiString))
262−
263−schemaModelDictExampleJSON :: Value
264−schemaModelDictExampleJSON = [aesonQQ|
265−{
266− "type": "object",
267− "additionalProperties": {
268− "type": "string"
269− }
270−}
271−|]
272−
273−schemaAdditionalExample :: Schema
274−schemaAdditionalExample = mempty
275− & type_ ?~ OpenApiObject
276− & additionalProperties ?~ AdditionalPropertiesAllowed True
277−
278−schemaAdditionalExampleJSON :: Value
279−schemaAdditionalExampleJSON = [aesonQQ|
280−{
281− "type": "object",
282− "additionalProperties": true
283−}
284−|]
285−
286−schemaWithExampleExample :: Schema
287−schemaWithExampleExample = mempty
288− & type_ ?~ OpenApiObject
289− & properties .~
290− [ ("id", Inline $ mempty
291− & type_ ?~ OpenApiInteger
292− & format ?~ "int64" )
293− , ("name", Inline $ mempty
294− & type_ ?~ OpenApiString) ]
295− & required .~ [ "name" ]
296− & example ?~ [aesonQQ|
297− {
298− "name": "Puma",
299− "id": 1
300− }
301− |]
302−
303−schemaWithExampleExampleJSON :: Value
304−schemaWithExampleExampleJSON = [aesonQQ|
305−{
306− "type": "object",
307− "properties": {
308− "id": {
309− "type": "integer",
310− "format": "int64"
311− },
312− "name": {
313− "type": "string"
314− }
315− },
316− "required": [
317− "name"
318− ],
319− "example": {
320− "name": "Puma",
321− "id": 1
322− }
323−}
324−|]
325−
326−-- =======================================================================
327−-- Definitions object
328−-- =======================================================================
329−
330−definitionsExample :: HashMap Text Schema
331−definitionsExample =
332− [ ("Category", mempty
333− & type_ ?~ OpenApiObject
334− & properties .~
335− [ ("id", Inline $ mempty
336− & type_ ?~ OpenApiInteger
337− & format ?~ "int64")
338− , ("name", Inline (mempty & type_ ?~ OpenApiString)) ] )
339− , ("Tag", mempty
340− & type_ ?~ OpenApiObject
341− & properties .~
342− [ ("id", Inline $ mempty
343− & type_ ?~ OpenApiInteger
344− & format ?~ "int64")
345− , ("name", Inline (mempty & type_ ?~ OpenApiString)) ] ) ]
346−
347−definitionsExampleJSON :: Value
348−definitionsExampleJSON = [aesonQQ|
349−{
350− "Category": {
351− "type": "object",
352− "properties": {
353− "id": {
354− "type": "integer",
355− "format": "int64"
356− },
357− "name": {
358− "type": "string"
359− }
360− }
361− },
362− "Tag": {
363− "type": "object",
364− "properties": {
365− "id": {
366− "type": "integer",
367− "format": "int64"
368− },
369− "name": {
370− "type": "string"
371− }
372− }
373− }
374−}
375−|]
376−
377−-- =======================================================================
378−-- Parameters Definition object
379−-- =======================================================================
380−
381−paramsDefinitionExample :: HashMap Text Param
382−paramsDefinitionExample =
383− [ ("skipParam", mempty
384− & name .~ "skip"
385− & description ?~ "number of items to skip"
386− & required ?~ True
387− & in_ .~ ParamQuery
388− & schema ?~ Inline (mempty
389− & type_ ?~ OpenApiInteger
390− & format ?~ "int32" ))
391− , ("limitParam", mempty
392− & name .~ "limit"
393− & description ?~ "max records to return"
394− & required ?~ True
395− & in_ .~ ParamQuery
396− & schema ?~ Inline (mempty
397− & type_ ?~ OpenApiInteger
398− & format ?~ "int32" )) ]
399−
400−paramsDefinitionExampleJSON :: Value
401−paramsDefinitionExampleJSON = [aesonQQ|
402−{
403− "skipParam": {
404− "name": "skip",
405− "in": "query",
406− "description": "number of items to skip",
407− "required": true,
408− "schema": {
409− "type": "integer",
410− "format": "int32"
411− }
412− },
413− "limitParam": {
414− "name": "limit",
415− "in": "query",
416− "description": "max records to return",
417− "required": true,
418− "schema": {
419− "type": "integer",
420− "format": "int32"
421− }
422− }
423−}
424−|]
425−
426−-- =======================================================================
427−-- Responses Definition object
428−-- =======================================================================
429−
430−responsesDefinitionExample :: HashMap Text Response
431−responsesDefinitionExample =
432− [ ("NotFound", mempty & description .~ "Entity not found.")
433− , ("IllegalInput", mempty & description .~ "Illegal input for operation.") ]
434−
435−responsesDefinitionExampleJSON :: Value
436−responsesDefinitionExampleJSON = [aesonQQ|
437−{
438− "NotFound": {
439− "description": "Entity not found."
440− },
441− "IllegalInput": {
442− "description": "Illegal input for operation."
443− }
444−}
445−|]
446−
447−-- =======================================================================
448−-- Security Definition object
449−-- =======================================================================
450−
451−securityDefinitionsExample :: SecurityDefinitions
452−securityDefinitionsExample = SecurityDefinitions
453− [ ("api_key", SecurityScheme
454− { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
455− , _securitySchemeDescription = Nothing })
456− , ("petstore_auth", SecurityScheme
457− { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow
458− { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog"
459− , _oAath2RefreshUrl = Nothing
460− , _oAuth2Scopes =
461− [ ("write:pets", "modify pets in your account")
462− , ("read:pets", "read your pets") ] } )
463− , _securitySchemeDescription = Nothing }) ]
464−
465−securityDefinitionsExampleJSON :: Value
466−securityDefinitionsExampleJSON = [aesonQQ|
467−{
468− "api_key": {
469− "in": "header",
470− "name": "api_key",
471− "type": "apiKey"
472− },
473− "petstore_auth": {
474− "type": "oauth2",
475− "flows": {
476− "implicit": {
477− "scopes": {
478− "write:pets": "modify pets in your account",
479− "read:pets": "read your pets"
480− },
481− "authorizationUrl": "http://swagger.io/api/oauth/dialog"
482− }
483− }
484− }
485−}
486−
487−|]
488−
489−oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions
490−oAuth2SecurityDefinitionsReadExample = SecurityDefinitions
491− [ ("petstore_auth", SecurityScheme
492− { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow
493− { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog"
494− , _oAath2RefreshUrl = Nothing
495− , _oAuth2Scopes =
496− [ ("read:pets", "read your pets") ] } )
497− , _securitySchemeDescription = Nothing })
498− ]
499−
500−oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions
501−oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions
502− [ ("petstore_auth", SecurityScheme
503− { _securitySchemeType = SecuritySchemeOAuth2 (mempty & implicit ?~ OAuth2Flow
504− { _oAuth2Params = OAuth2ImplicitFlow "http://swagger.io/api/oauth/dialog"
505− , _oAath2RefreshUrl = Nothing
506− , _oAuth2Scopes =
507− [ ("write:pets", "modify pets in your account") ] } )
508− , _securitySchemeDescription = Nothing })
509− ]
510−
511−oAuth2SecurityDefinitionsExample :: SecurityDefinitions
512−oAuth2SecurityDefinitionsExample =
513− oAuth2SecurityDefinitionsWriteExample <>
514− oAuth2SecurityDefinitionsReadExample
515−
516−oAuth2SecurityDefinitionsExampleJSON :: Value
517−oAuth2SecurityDefinitionsExampleJSON = [aesonQQ|
518−{
519− "petstore_auth": {
520− "type": "oauth2",
521− "flows": {
522− "implicit": {
523− "scopes": {
524− "write:pets": "modify pets in your account",
525− "read:pets": "read your pets"
526− },
527− "authorizationUrl": "http://swagger.io/api/oauth/dialog"
528− }
529− }
530− }
531−}
532−|]
533−
534−oAuth2SecurityDefinitionsReadOpenApi :: OpenApi
535−oAuth2SecurityDefinitionsReadOpenApi =
536− mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsReadExample
537−
538−oAuth2SecurityDefinitionsWriteOpenApi :: OpenApi
539−oAuth2SecurityDefinitionsWriteOpenApi =
540− mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsWriteExample
541−
542−oAuth2SecurityDefinitionsOpenApi :: OpenApi
543−oAuth2SecurityDefinitionsOpenApi =
544− mempty & components . securitySchemes .~ oAuth2SecurityDefinitionsExample
545−
546−-- =======================================================================
547−-- Swagger object
548−-- =======================================================================
549−
550−emptyPathsFieldExample :: OpenApi
551−emptyPathsFieldExample = mempty
552−
553−emptyPathsFieldExampleJSON :: Value
554−emptyPathsFieldExampleJSON = [aesonQQ|
555−{
556− "openapi": "3.0.0",
557− "info": {"version": "", "title": ""},
558− "paths": {},
559− "components": {}
560−}
561−|]
562−
563−swaggerExample :: OpenApi
564−swaggerExample = mempty
565− -- & basePath ?~ "/"
566− -- & schemes ?~ [Http]
567− & info .~ (mempty
568− & version .~ "1.0"
569− & title .~ "Todo API"
570− & license ?~ "MIT"
571− & license._Just.url ?~ URL "http://mit.com"
572− & description ?~ "This is an API that tests servant-swagger support for a Todo API")
573− & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation)
574− & responses . at 200 ?~ Inline (mempty
575− & description .~ "OK"
576− & content . at "application/json" ?~ (mempty
577− & schema ?~ Inline (mempty
578− & type_ ?~ OpenApiObject
579− & example ?~ [aesonQQ|
580− {
581− "created": 100,
582− "description": "get milk"
583− } |]
584− & description ?~ "This is some real Todo right here"
585− & properties .~
586− [ ("created", Inline $ mempty
587− & type_ ?~ OpenApiInteger
588− & format ?~ "int32")
589− , ("description", Inline (mempty & type_ ?~ OpenApiString))])))
590− & parameters .~
591− [ Inline $ mempty
592− & required ?~ True
593− & name .~ "id"
594− & description ?~ "TodoId param"
595− & in_ .~ ParamPath
596− & schema ?~ Inline (mempty
597− & type_ ?~ OpenApiString ) ]
598− & tags .~ InsOrdHS.fromList [ "todo" ] ))
599−
600−swaggerExampleJSON :: Value
601−swaggerExampleJSON = [aesonQQ|
602−{
603− "openapi": "3.0.0",
604− "info": {
605− "version": "1.0",
606− "title": "Todo API",
607− "license": {
608− "url": "http://mit.com",
609− "name": "MIT"
610− },
611− "description": "This is an API that tests servant-swagger support for a Todo API"
612− },
613− "paths": {
614− "/todo/{id}": {
615− "get": {
616− "tags": [
617− "todo"
618− ],
619− "parameters": [
620− {
621− "required": true,
622− "schema": {
623− "type": "string"
624− },
625− "in": "path",
626− "name": "id",
627− "description": "TodoId param"
628− }
629− ],
630− "responses": {
631− "200": {
632− "content": {
633− "application/json": {
634− "schema": {
635− "example": {
636− "created": 100,
637− "description": "get milk"
638− },
639− "type": "object",
640− "description": "This is some real Todo right here",
641− "properties": {
642− "created": {
643− "format": "int32",
644− "type": "integer"
645− },
646− "description": {
647− "type": "string"
648− }
649− }
650− }
651− }
652− },
653− "description": "OK"
654− }
655− }
656− }
657− }
658− },
659− "components": {}
660−}
661−|]
662−
663−petstoreExampleJSON :: Value
664−petstoreExampleJSON = [aesonQQ|
665−{
666− "openapi": "3.0.0",
667− "info": {
668− "version": "1.0.0",
669− "title": "Swagger Petstore",
670− "license": {
671− "name": "MIT"
672− }
673− },
674− "servers": [
675− {
676− "url": "http://petstore.swagger.io/v1"
677− }
678− ],
679− "paths": {
680− "/pets": {
681− "get": {
682− "summary": "List all pets",
683− "operationId": "listPets",
684− "tags": [
685− "pets"
686− ],
687− "parameters": [
688− {
689− "name": "limit",
690− "in": "query",
691− "description": "How many items to return at one time (max 100)",
692− "required": false,
693− "schema": {
694− "type": "integer",
695− "format": "int32"
696− }
697− }
698− ],
699− "responses": {
700− "200": {
701− "description": "A paged array of pets",
702− "headers": {
703− "x-next": {
704− "description": "A link to the next page of responses",
705− "schema": {
706− "type": "string"
707− }
708− }
709− },
710− "content": {
711− "application/json": {
712− "schema": {
713− "type": "array",
714− "items": {
715− "type": "object",
716− "required": [
717− "id",
718− "name"
719− ],
720− "properties": {
721− "id": {
722− "type": "integer",
723− "format": "int64"
724− },
725− "name": {
726− "type": "string"
727− },
728− "tag": {
729− "type": "string"
730− }
731− }
732− }
733− }
734− }
735− }
736− },
737− "default": {
738− "description": "unexpected error",
739− "content": {
740− "application/json": {
741− "schema": {
742− "type": "object",
743− "required": [
744− "code",
745− "message"
746− ],
747− "properties": {
748− "code": {
749− "type": "integer",
750− "format": "int32"
751− },
752− "message": {
753− "type": "string"
754− }
755− }
756− }
757− }
758− }
759− }
760− }
761− },
762− "post": {
763− "summary": "Create a pet",
764− "operationId": "createPets",
765− "tags": [
766− "pets"
767− ],
768− "responses": {
769− "201": {
770− "description": "Null response"
771− },
772− "default": {
773− "description": "unexpected error",
774− "content": {
775− "application/json": {
776− "schema": {
777− "type": "object",
778− "required": [
779− "code",
780− "message"
781− ],
782− "properties": {
783− "code": {
784− "type": "integer",
785− "format": "int32"
786− },
787− "message": {
788− "type": "string"
789− }
790− }
791− }
792− }
793− }
794− }
795− }
796− }
797− },
798− "/pets/{petId}": {
799− "get": {
800− "summary": "Info for a specific pet",
801− "operationId": "showPetById",
802− "tags": [
803− "pets"
804− ],
805− "parameters": [
806− {
807− "name": "petId",
808− "in": "path",
809− "required": true,
810− "description": "The id of the pet to retrieve",
811− "schema": {
812− "type": "string"
813− }
814− }
815− ],
816− "responses": {
817− "200": {
818− "description": "Expected response to a valid request",
819− "content": {
820− "application/json": {
821− "schema": {
822− "type": "object",
823− "required": [
824− "id",
825− "name"
826− ],
827− "properties": {
828− "id": {
829− "type": "integer",
830− "format": "int64"
831− },
832− "name": {
833− "type": "string"
834− },
835− "tag": {
836− "type": "string"
837− }
838− }
839− }
840− }
841− }
842− },
843− "default": {
844− "description": "unexpected error",
845− "content": {
846− "application/json": {
847− "schema": {
848− "type": "object",
849− "required": [
850− "code",
851− "message"
852− ],
853− "properties": {
854− "code": {
855− "type": "integer",
856− "format": "int32"
857− },
858− "message": {
859− "type": "string"
860− }
861− }
862− }
863− }
864− }
865− }
866− }
867− }
868− }
869− },
870− "components": {
871− "schemas": {
872− "Pet": {
873− "type": "object",
874− "required": [
875− "id",
876− "name"
877− ],
878− "properties": {
879− "id": {
880− "type": "integer",
881− "format": "int64"
882− },
883− "name": {
884− "type": "string"
885− },
886− "tag": {
887− "type": "string"
888− }
889− }
890− },
891− "Pets": {
892− "type": "array",
893− "items": {
894− "type": "object",
895− "required": [
896− "id",
897− "name"
898− ],
899− "properties": {
900− "id": {
901− "type": "integer",
902− "format": "int64"
903− },
904− "name": {
905− "type": "string"
906− },
907− "tag": {
908− "type": "string"
909− }
910− }
911− }
912− },
913− "Error": {
914− "type": "object",
915− "required": [
916− "code",
917− "message"
918− ],
919− "properties": {
920− "code": {
921− "type": "integer",
922− "format": "int32"
923− },
924− "message": {
925− "type": "string"
926− }
927− }
928− }
929− }
930− }
931−}
932−|]
933−
934−compositionSchemaExample :: Schema
935−compositionSchemaExample = mempty
936− & type_ ?~ OpenApiObject
937− & Data.OpenApi.allOf ?~ [
938− Ref (Reference "Other")
939− , Inline (mempty
940− & type_ ?~ OpenApiObject
941− & properties .~
942− [ ("greet", Inline $ mempty
943− & type_ ?~ OpenApiString) ])
944− ]
945−
946−compositionSchemaExampleJSON :: Value
947−compositionSchemaExampleJSON = [aesonQQ|
948−{
949− "type": "object",
950− "allOf": [
951− {
952− "$ref": "#/components/schemas/Other"
953− },
954− {
955− "type": "object",
956− "properties": {
957− "greet": { "type": "string" }
958− }
959− }
960− ]
961−}
962−|]
test/Data/Swagger/ParamSchemaSpec.hsnew file+112
@@ -0,0 +1,112 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveAnyClass #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE QuasiQuotes #-}
6+module Data.Swagger.ParamSchemaSpec where
7+
8+import Data.Aeson
9+import Data.Aeson.QQ
10+import Data.Char
11+import Data.Proxy
12+import Data.Set (Set)
13+import GHC.Generics
14+
15+import Data.Swagger
16+
17+import SpecCommon
18+import Test.Hspec
19+
20+checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
21+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js
22+
23+spec :: Spec
24+spec = do
25+ describe "Generic ToParamSchema" $ do
26+ context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON
27+ context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON
28+ context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON
29+ context "Unary records" $ do
30+ context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
31+ context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
32+
33+main :: IO ()
34+main = hspec spec
35+
36+-- ========================================================================
37+-- Unit type
38+-- ========================================================================
39+
40+data Unit = Unit deriving (Generic, ToParamSchema)
41+
42+unitSchemaJSON :: Value
43+unitSchemaJSON = [aesonQQ|
44+{
45+ "type": "string",
46+ "enum": ["Unit"]
47+}
48+|]
49+
50+-- ========================================================================
51+-- Color (enum)
52+-- ========================================================================
53+data Color
54+ = Red
55+ | Green
56+ | Blue
57+ deriving (Generic, ToParamSchema)
58+
59+colorSchemaJSON :: Value
60+colorSchemaJSON = [aesonQQ|
61+{
62+ "type": "string",
63+ "enum": ["Red", "Green", "Blue"]
64+}
65+|]
66+
67+-- ========================================================================
68+-- Status (constructorTagModifier)
69+-- ========================================================================
70+
71+data Status = StatusOk | StatusError deriving (Generic)
72+
73+instance ToParamSchema Status where
74+ toParamSchema = genericToParamSchema defaultSchemaOptions
75+ { constructorTagModifier = map toLower . drop (length "Status") }
76+
77+statusSchemaJSON :: Value
78+statusSchemaJSON = [aesonQQ|
79+{
80+ "type": "string",
81+ "enum": ["ok", "error"]
82+}
83+|]
84+
85+-- ========================================================================
86+-- Email (newtype with unwrapUnaryRecords set to True)
87+-- ========================================================================
88+
89+newtype Email = Email { getEmail :: String }
90+ deriving (Generic, ToParamSchema)
91+
92+emailSchemaJSON :: Value
93+emailSchemaJSON = [aesonQQ|
94+{
95+ "type": "string"
96+}
97+|]
98+
99+-- ========================================================================
100+-- UserId (non-record newtype)
101+-- ========================================================================
102+
103+newtype UserId = UserId Integer
104+ deriving (Generic, ToParamSchema)
105+
106+userIdSchemaJSON :: Value
107+userIdSchemaJSON = [aesonQQ|
108+{
109+ "type": "integer"
110+}
111+|]
112+
test/Data/Swagger/SchemaSpec.hsnew file+583
@@ -0,0 +1,583 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveAnyClass #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE QuasiQuotes #-}
6+module Data.Swagger.SchemaSpec where
7+
8+import Data.Aeson
9+import Data.Aeson.QQ
10+import Data.Char
11+import qualified Data.HashMap.Strict as HashMap
12+import Data.Proxy
13+import Data.Set (Set)
14+import qualified Data.Set as Set
15+import Data.Text (Text)
16+import qualified Data.Text as Text
17+import GHC.Generics
18+
19+import Data.Swagger
20+import Data.Swagger.Declare
21+
22+import SpecCommon
23+import Test.Hspec
24+
25+checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
26+checkToSchema proxy js = toSchema proxy <=> js
27+
28+checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec
29+checkSchemaName sname proxy =
30+ it ("schema name is " ++ show sname) $
31+ schemaName proxy `shouldBe` fmap Text.pack sname
32+
33+checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
34+checkDefs proxy names =
35+ it ("uses these definitions " ++ show names) $
36+ Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)
37+ where
38+ defs = execDeclare (declareNamedSchema proxy) mempty
39+
40+checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
41+checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
42+
43+checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec
44+checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs schema <=> js
45+ where
46+ (defs, schema) = runDeclare (declareSchema proxy) mempty
47+
48+checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec
49+checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs schema <=> js
50+ where
51+ (defs, schema) = runDeclare (declareSchema proxy) mempty
52+
53+spec :: Spec
54+spec = do
55+ describe "Generic ToSchema" $ do
56+ context "Unit" $ checkToSchema (Proxy :: Proxy Unit) unitSchemaJSON
57+ context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
58+ context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
59+ context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
60+ context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
61+ context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
62+ context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
63+ context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON
64+ context "Unary records" $ do
65+ context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
66+ context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
67+ context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
68+ context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
69+ context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
70+ context "Sum types" $ do
71+ context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
72+ context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
73+ context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON
74+ context "Schema name" $ do
75+ context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)
76+ context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
77+ context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
78+ context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
79+ describe "Generic Definitions" $ do
80+ context "Unit" $ checkDefs (Proxy :: Proxy Unit) []
81+ context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]
82+ context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
83+ context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
84+ context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
85+ context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
86+ context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
87+ describe "Inlining Schemas" $ do
88+ context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON
89+ context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON
90+ context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
91+ context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
92+ context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
93+
94+main :: IO ()
95+main = hspec spec
96+
97+-- ========================================================================
98+-- Person (simple record with optional fields)
99+-- ========================================================================
100+data Person = Person
101+ { name :: String
102+ , phone :: Integer
103+ , email :: Maybe String
104+ } deriving (Generic, ToSchema)
105+
106+personSchemaJSON :: Value
107+personSchemaJSON = [aesonQQ|
108+{
109+ "type": "object",
110+ "properties":
111+ {
112+ "name": { "type": "string" },
113+ "phone": { "type": "integer" },
114+ "email": { "type": "string" }
115+ },
116+ "required": ["name", "phone"]
117+}
118+|]
119+
120+-- ========================================================================
121+-- ISPair (non-record product data type)
122+-- ========================================================================
123+data ISPair = ISPair Integer String
124+ deriving (Generic, ToSchema)
125+
126+ispairSchemaJSON :: Value
127+ispairSchemaJSON = [aesonQQ|
128+{
129+ "type": "array",
130+ "items":
131+ [
132+ { "type": "integer" },
133+ { "type": "string" }
134+ ]
135+}
136+|]
137+
138+-- ========================================================================
139+-- Point (record data type with custom fieldLabelModifier)
140+-- ========================================================================
141+data Point = Point
142+ { pointX :: Double
143+ , pointY :: Double
144+ } deriving (Generic)
145+
146+instance ToSchema Point where
147+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
148+ { fieldLabelModifier = map toLower . drop (length "point") }
149+
150+pointSchemaJSON :: Value
151+pointSchemaJSON = [aesonQQ|
152+{
153+ "type": "object",
154+ "properties":
155+ {
156+ "x": { "type": "number", "format": "double" },
157+ "y": { "type": "number", "format": "double" }
158+ },
159+ "required": ["x", "y"]
160+}
161+|]
162+
163+
164+-- ========================================================================
165+-- Color (enum)
166+-- ========================================================================
167+data Color
168+ = Red
169+ | Green
170+ | Blue
171+ deriving (Generic, ToSchema)
172+
173+colorSchemaJSON :: Value
174+colorSchemaJSON = [aesonQQ|
175+{
176+ "type": "string",
177+ "enum": ["Red", "Green", "Blue"]
178+}
179+|]
180+
181+-- ========================================================================
182+-- Shade (paramSchemaToNamedSchema)
183+-- ========================================================================
184+
185+data Shade = Dim | Bright deriving (Generic, ToParamSchema)
186+
187+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
188+
189+shadeSchemaJSON :: Value
190+shadeSchemaJSON = [aesonQQ|
191+{
192+ "type": "string",
193+ "enum": ["Dim", "Bright"]
194+}
195+|]
196+
197+-- ========================================================================
198+-- Paint (record with bounded enum property)
199+-- ========================================================================
200+
201+newtype Paint = Paint { color :: Color }
202+ deriving (Generic, ToSchema)
203+
204+paintSchemaJSON :: Value
205+paintSchemaJSON = [aesonQQ|
206+{
207+ "type": "object",
208+ "properties":
209+ {
210+ "color":
211+ {
212+ "$ref": "#/definitions/Color"
213+ }
214+ },
215+ "required": ["color"]
216+}
217+|]
218+
219+paintInlinedSchemaJSON :: Value
220+paintInlinedSchemaJSON = [aesonQQ|
221+{
222+ "type": "object",
223+ "properties":
224+ {
225+ "color":
226+ {
227+ "type": "string",
228+ "enum": ["Red", "Green", "Blue"]
229+ }
230+ },
231+ "required": ["color"]
232+}
233+|]
234+
235+-- ========================================================================
236+-- Email (newtype with unwrapUnaryRecords set to True)
237+-- ========================================================================
238+
239+newtype Email = Email { getEmail :: String }
240+ deriving (Generic)
241+
242+instance ToSchema Email where
243+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
244+ { unwrapUnaryRecords = True }
245+
246+emailSchemaJSON :: Value
247+emailSchemaJSON = [aesonQQ|
248+{
249+ "type": "string"
250+}
251+|]
252+
253+-- ========================================================================
254+-- UserId (non-record newtype)
255+-- ========================================================================
256+
257+newtype UserId = UserId Integer
258+ deriving (Eq, Ord, Generic, ToSchema)
259+
260+userIdSchemaJSON :: Value
261+userIdSchemaJSON = [aesonQQ|
262+{
263+ "type": "integer"
264+}
265+|]
266+
267+-- ========================================================================
268+-- UserGroup (set newtype)
269+-- ========================================================================
270+
271+newtype UserGroup = UserGroup (Set UserId)
272+ deriving (Generic, ToSchema)
273+
274+userGroupSchemaJSON :: Value
275+userGroupSchemaJSON = [aesonQQ|
276+{
277+ "type": "array",
278+ "items": { "$ref": "#/definitions/UserId" },
279+ "uniqueItems": true
280+}
281+|]
282+
283+-- ========================================================================
284+-- Player (record newtype)
285+-- ========================================================================
286+
287+newtype Player = Player
288+ { position :: Point
289+ } deriving (Generic, ToSchema)
290+
291+playerSchemaJSON :: Value
292+playerSchemaJSON = [aesonQQ|
293+{
294+ "type": "object",
295+ "properties":
296+ {
297+ "position":
298+ {
299+ "$ref": "#/definitions/Point"
300+ }
301+ },
302+ "required": ["position"]
303+}
304+|]
305+
306+-- ========================================================================
307+-- MyRoseTree (custom datatypeNameModifier)
308+-- ========================================================================
309+
310+data MyRoseTree = MyRoseTree
311+ { root :: String
312+ , trees :: [MyRoseTree]
313+ } deriving (Generic)
314+
315+instance ToSchema MyRoseTree where
316+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
317+ { datatypeNameModifier = drop (length "My") }
318+
319+myRoseTreeSchemaJSON :: Value
320+myRoseTreeSchemaJSON = [aesonQQ|
321+{
322+ "type": "object",
323+ "properties":
324+ {
325+ "root": { "type": "string" },
326+ "trees":
327+ {
328+ "type": "array",
329+ "items":
330+ {
331+ "$ref": "#/definitions/RoseTree"
332+ }
333+ }
334+ },
335+ "required": ["root", "trees"]
336+}
337+|]
338+
339+-- ========================================================================
340+-- Inlined (newtype for inlining schemas)
341+-- ========================================================================
342+
343+newtype Inlined a = Inlined { getInlined :: a }
344+
345+instance ToSchema a => ToSchema (Inlined a) where
346+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
347+ where
348+ unname (NamedSchema _ schema) = NamedSchema Nothing schema
349+
350+newtype Players = Players [Inlined Player]
351+ deriving (Generic, ToSchema)
352+
353+playersSchemaJSON :: Value
354+playersSchemaJSON = [aesonQQ|
355+{
356+ "type": "array",
357+ "items":
358+ {
359+ "type": "object",
360+ "properties":
361+ {
362+ "position":
363+ {
364+ "$ref": "#/definitions/Point"
365+ }
366+ },
367+ "required": ["position"]
368+ }
369+}
370+|]
371+
372+-- ========================================================================
373+-- Status (sum type with unary constructors)
374+-- ========================================================================
375+
376+data Status
377+ = StatusOk String
378+ | StatusError String
379+ deriving (Generic)
380+
381+instance ToSchema Status where
382+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
383+ { constructorTagModifier = map toLower . drop (length "Status") }
384+
385+statusSchemaJSON :: Value
386+statusSchemaJSON = [aesonQQ|
387+{
388+ "type": "object",
389+ "properties":
390+ {
391+ "ok": { "type": "string" },
392+ "error": { "type": "string" }
393+ },
394+ "maxProperties": 1,
395+ "minProperties": 1
396+}
397+|]
398+
399+-- ========================================================================
400+-- Unit type
401+-- ========================================================================
402+
403+data Unit = Unit deriving (Generic, ToSchema)
404+
405+unitSchemaJSON :: Value
406+unitSchemaJSON = [aesonQQ|
407+{
408+ "type": "string",
409+ "enum": ["Unit"]
410+}
411+|]
412+
413+
414+-- ========================================================================
415+-- Character (sum type with ref and record in alternative)
416+-- ========================================================================
417+
418+data Character
419+ = PC Player
420+ | NPC { npcName :: String, npcPosition :: Point }
421+ deriving (Generic, ToSchema)
422+
423+characterSchemaJSON :: Value
424+characterSchemaJSON = [aesonQQ|
425+{
426+ "type": "object",
427+ "properties":
428+ {
429+ "PC": { "$ref": "#/definitions/Player" },
430+ "NPC":
431+ {
432+ "type": "object",
433+ "properties":
434+ {
435+ "npcName": { "type": "string" },
436+ "npcPosition": { "$ref": "#/definitions/Point" }
437+ },
438+ "required": ["npcName", "npcPosition"]
439+ }
440+ },
441+ "maxProperties": 1,
442+ "minProperties": 1
443+}
444+|]
445+
446+characterInlinedSchemaJSON :: Value
447+characterInlinedSchemaJSON = [aesonQQ|
448+{
449+ "type": "object",
450+ "properties":
451+ {
452+ "PC":
453+ {
454+ "type": "object",
455+ "properties":
456+ {
457+ "position":
458+ {
459+ "type": "object",
460+ "properties":
461+ {
462+ "x": { "type": "number", "format": "double" },
463+ "y": { "type": "number", "format": "double" }
464+ },
465+ "required": ["x", "y"]
466+ }
467+ },
468+ "required": ["position"]
469+ },
470+ "NPC":
471+ {
472+ "type": "object",
473+ "properties":
474+ {
475+ "npcName": { "type": "string" },
476+ "npcPosition":
477+ {
478+ "type": "object",
479+ "properties":
480+ {
481+ "x": { "type": "number", "format": "double" },
482+ "y": { "type": "number", "format": "double" }
483+ },
484+ "required": ["x", "y"]
485+ }
486+ },
487+ "required": ["npcName", "npcPosition"]
488+ }
489+ },
490+ "maxProperties": 1,
491+ "minProperties": 1
492+}
493+|]
494+
495+characterInlinedPlayerSchemaJSON :: Value
496+characterInlinedPlayerSchemaJSON = [aesonQQ|
497+{
498+ "type": "object",
499+ "properties":
500+ {
501+ "PC":
502+ {
503+ "type": "object",
504+ "properties":
505+ {
506+ "position":
507+ {
508+ "$ref": "#/definitions/Point"
509+ }
510+ },
511+ "required": ["position"]
512+ },
513+ "NPC":
514+ {
515+ "type": "object",
516+ "properties":
517+ {
518+ "npcName": { "type": "string" },
519+ "npcPosition": { "$ref": "#/definitions/Point" }
520+ },
521+ "required": ["npcName", "npcPosition"]
522+ }
523+ },
524+ "maxProperties": 1,
525+ "minProperties": 1
526+}
527+|]
528+
529+-- ========================================================================
530+-- Light (sum type with unwrapUnaryRecords)
531+-- ========================================================================
532+
533+data Light
534+ = LightFreq Double
535+ | LightColor Color
536+ | LightWaveLength { waveLength :: Double }
537+ deriving (Generic)
538+
539+instance ToSchema Light where
540+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
541+ { unwrapUnaryRecords = True }
542+
543+lightSchemaJSON :: Value
544+lightSchemaJSON = [aesonQQ|
545+{
546+ "type": "object",
547+ "properties":
548+ {
549+ "LightFreq": { "type": "number", "format": "double" },
550+ "LightColor": { "$ref": "#/definitions/Color" },
551+ "LightWaveLength": { "type": "number", "format": "double" }
552+ },
553+ "maxProperties": 1,
554+ "minProperties": 1
555+}
556+|]
557+
558+lightInlinedSchemaJSON :: Value
559+lightInlinedSchemaJSON = [aesonQQ|
560+{
561+ "type": "object",
562+ "properties":
563+ {
564+ "LightFreq": { "type": "number", "format": "double" },
565+ "LightColor":
566+ {
567+ "type": "string",
568+ "enum": ["Red", "Green", "Blue"]
569+ },
570+ "LightWaveLength": { "type": "number", "format": "double" }
571+ },
572+ "maxProperties": 1,
573+ "minProperties": 1
574+}
575+|]
576+
577+-- ========================================================================
578+-- ResourceId (series of newtypes)
579+-- ========================================================================
580+
581+newtype Id = Id String deriving (Generic, ToSchema)
582+
583+newtype ResourceId = ResourceId Id deriving (Generic, ToSchema)
test/Data/SwaggerSpec.hsnew file+1607
@@ -0,0 +1,1607 @@
1+{-# LANGUAGE OverloadedLists #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE QuasiQuotes #-}
5+module Data.SwaggerSpec where
6+
7+import Control.Lens
8+
9+import Data.Aeson
10+import Data.Aeson.QQ
11+import Data.HashMap.Strict (HashMap)
12+import Data.Text (Text)
13+
14+import Data.Swagger
15+import SpecCommon
16+import Test.Hspec hiding (example)
17+
18+spec :: Spec
19+spec = do
20+ describe "License Object" $ licenseExample <=> licenseExampleJSON
21+ describe "Contact Object" $ contactExample <=> contactExampleJSON
22+ describe "Info Object" $ infoExample <=> infoExampleJSON
23+ describe "Operation Object" $ operationExample <=> operationExampleJSON
24+ describe "Schema Object" $ do
25+ context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
26+ context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
27+ context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
28+ context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
29+ describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
30+ describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
31+ describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
32+ describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
33+ describe "Swagger Object" $ do
34+ context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
35+ context "PetStore Example" $
36+ it "decodes successfully" $ do
37+ fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: Swagger) -> True; _ -> False)
38+
39+main :: IO ()
40+main = hspec spec
41+
42+-- =======================================================================
43+-- Info object
44+-- =======================================================================
45+
46+infoExample :: Info
47+infoExample = mempty
48+ & title .~ "Swagger Sample App"
49+ & description ?~ "This is a sample server Petstore server."
50+ & termsOfService ?~ "http://swagger.io/terms/"
51+ & contact ?~ contactExample
52+ & license ?~ licenseExample
53+ & version .~ "1.0.1"
54+
55+infoExampleJSON :: Value
56+infoExampleJSON = [aesonQQ|
57+{
58+ "title": "Swagger Sample App",
59+ "description": "This is a sample server Petstore server.",
60+ "termsOfService": "http://swagger.io/terms/",
61+ "contact": {
62+ "name": "API Support",
63+ "url": "http://www.swagger.io/support",
64+ "email": "support@swagger.io"
65+ },
66+ "license": {
67+ "name": "Apache 2.0",
68+ "url": "http://www.apache.org/licenses/LICENSE-2.0.html"
69+ },
70+ "version": "1.0.1"
71+}
72+|]
73+
74+-- =======================================================================
75+-- Contact object
76+-- =======================================================================
77+
78+contactExample :: Contact
79+contactExample = mempty
80+ & name ?~ "API Support"
81+ & url ?~ URL "http://www.swagger.io/support"
82+ & email ?~ "support@swagger.io"
83+
84+contactExampleJSON :: Value
85+contactExampleJSON = [aesonQQ|
86+{
87+ "name": "API Support",
88+ "url": "http://www.swagger.io/support",
89+ "email": "support@swagger.io"
90+}
91+|]
92+
93+-- =======================================================================
94+-- License object
95+-- =======================================================================
96+
97+licenseExample :: License
98+licenseExample = License "Apache 2.0" (Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html"))
99+
100+licenseExampleJSON :: Value
101+licenseExampleJSON = [aesonQQ|
102+{
103+ "name": "Apache 2.0",
104+ "url": "http://www.apache.org/licenses/LICENSE-2.0.html"
105+}
106+|]
107+
108+
109+-- =======================================================================
110+-- Operation object
111+-- =======================================================================
112+
113+operationExample :: Operation
114+operationExample = mempty
115+ & tags .~ ["pet"]
116+ & summary ?~ "Updates a pet in the store with form data"
117+ & description ?~ ""
118+ & operationId ?~ "updatePetWithForm"
119+ & consumes ?~ MimeList ["application/x-www-form-urlencoded"]
120+ & produces ?~ MimeList ["application/json", "application/xml"]
121+ & parameters .~ map Inline
122+ [ mempty
123+ & name .~ "petId"
124+ & description ?~ "ID of pet that needs to be updated"
125+ & required ?~ True
126+ & schema .~ ParamOther (stringSchema ParamPath)
127+ , mempty
128+ & name .~ "name"
129+ & description ?~ "Updated name of the pet"
130+ & required ?~ False
131+ & schema .~ ParamOther (stringSchema ParamFormData)
132+ , mempty
133+ & name .~ "status"
134+ & description ?~ "Updated status of the pet"
135+ & required ?~ False
136+ & schema .~ ParamOther (stringSchema ParamFormData)
137+ ]
138+
139+ & responses .~ (mempty & responses .~
140+ [ (200, Inline (mempty & description .~ "Pet updated."))
141+ , (405, Inline (mempty & description .~ "Invalid input")) ])
142+ & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]
143+ where
144+ stringSchema :: ParamLocation -> ParamOtherSchema
145+ stringSchema loc = mempty
146+ & in_ .~ loc
147+ & type_ .~ SwaggerString
148+
149+operationExampleJSON :: Value
150+operationExampleJSON = [aesonQQ|
151+{
152+ "tags": [
153+ "pet"
154+ ],
155+ "summary": "Updates a pet in the store with form data",
156+ "description": "",
157+ "operationId": "updatePetWithForm",
158+ "consumes": [
159+ "application/x-www-form-urlencoded"
160+ ],
161+ "produces": [
162+ "application/json",
163+ "application/xml"
164+ ],
165+ "parameters": [
166+ {
167+ "name": "petId",
168+ "in": "path",
169+ "description": "ID of pet that needs to be updated",
170+ "required": true,
171+ "type": "string"
172+ },
173+ {
174+ "name": "name",
175+ "in": "formData",
176+ "description": "Updated name of the pet",
177+ "required": false,
178+ "type": "string"
179+ },
180+ {
181+ "name": "status",
182+ "in": "formData",
183+ "description": "Updated status of the pet",
184+ "required": false,
185+ "type": "string"
186+ }
187+ ],
188+ "responses": {
189+ "200": {
190+ "description": "Pet updated."
191+ },
192+ "405": {
193+ "description": "Invalid input"
194+ }
195+ },
196+ "security": [
197+ {
198+ "petstore_auth": [
199+ "write:pets",
200+ "read:pets"
201+ ]
202+ }
203+ ]
204+}
205+|]
206+
207+-- =======================================================================
208+-- Schema object
209+-- =======================================================================
210+
211+schemaPrimitiveExample :: Schema
212+schemaPrimitiveExample = mempty
213+ & type_ .~ SwaggerString
214+ & format ?~ "email"
215+
216+schemaPrimitiveExampleJSON :: Value
217+schemaPrimitiveExampleJSON = [aesonQQ|
218+{
219+ "type": "string",
220+ "format": "email"
221+}
222+|]
223+
224+schemaSimpleModelExample :: Schema
225+schemaSimpleModelExample = mempty
226+ & type_ .~ SwaggerObject
227+ & required .~ [ "name" ]
228+ & properties .~
229+ [ ("name", Inline (mempty & type_ .~ SwaggerString))
230+ , ("address", Ref (Reference "Address"))
231+ , ("age", Inline $ mempty
232+ & minimum_ ?~ 0
233+ & type_ .~ SwaggerInteger
234+ & format ?~ "int32" ) ]
235+
236+schemaSimpleModelExampleJSON :: Value
237+schemaSimpleModelExampleJSON = [aesonQQ|
238+{
239+ "type": "object",
240+ "required": [
241+ "name"
242+ ],
243+ "properties": {
244+ "name": {
245+ "type": "string"
246+ },
247+ "address": {
248+ "$ref": "#/definitions/Address"
249+ },
250+ "age": {
251+ "type": "integer",
252+ "format": "int32",
253+ "minimum": 0
254+ }
255+ }
256+}
257+|]
258+
259+schemaModelDictExample :: Schema
260+schemaModelDictExample = mempty
261+ & type_ .~ SwaggerObject
262+ & additionalProperties ?~ (mempty & type_ .~ SwaggerString)
263+
264+schemaModelDictExampleJSON :: Value
265+schemaModelDictExampleJSON = [aesonQQ|
266+{
267+ "type": "object",
268+ "additionalProperties": {
269+ "type": "string"
270+ }
271+}
272+|]
273+
274+schemaWithExampleExample :: Schema
275+schemaWithExampleExample = mempty
276+ & type_ .~ SwaggerObject
277+ & properties .~
278+ [ ("id", Inline $ mempty
279+ & type_ .~ SwaggerInteger
280+ & format ?~ "int64" )
281+ , ("name", Inline $ mempty
282+ & type_ .~ SwaggerString) ]
283+ & required .~ [ "name" ]
284+ & example ?~ [aesonQQ|
285+ {
286+ "name": "Puma",
287+ "id": 1
288+ }
289+ |]
290+
291+schemaWithExampleExampleJSON :: Value
292+schemaWithExampleExampleJSON = [aesonQQ|
293+{
294+ "type": "object",
295+ "properties": {
296+ "id": {
297+ "type": "integer",
298+ "format": "int64"
299+ },
300+ "name": {
301+ "type": "string"
302+ }
303+ },
304+ "required": [
305+ "name"
306+ ],
307+ "example": {
308+ "name": "Puma",
309+ "id": 1
310+ }
311+}
312+|]
313+
314+-- =======================================================================
315+-- Definitions object
316+-- =======================================================================
317+
318+definitionsExample :: HashMap Text Schema
319+definitionsExample =
320+ [ ("Category", mempty
321+ & type_ .~ SwaggerObject
322+ & properties .~
323+ [ ("id", Inline $ mempty
324+ & type_ .~ SwaggerInteger
325+ & format ?~ "int64")
326+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )
327+ , ("Tag", mempty
328+ & type_ .~ SwaggerObject
329+ & properties .~
330+ [ ("id", Inline $ mempty
331+ & type_ .~ SwaggerInteger
332+ & format ?~ "int64")
333+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]
334+
335+definitionsExampleJSON :: Value
336+definitionsExampleJSON = [aesonQQ|
337+{
338+ "Category": {
339+ "type": "object",
340+ "properties": {
341+ "id": {
342+ "type": "integer",
343+ "format": "int64"
344+ },
345+ "name": {
346+ "type": "string"
347+ }
348+ }
349+ },
350+ "Tag": {
351+ "type": "object",
352+ "properties": {
353+ "id": {
354+ "type": "integer",
355+ "format": "int64"
356+ },
357+ "name": {
358+ "type": "string"
359+ }
360+ }
361+ }
362+}
363+|]
364+
365+-- =======================================================================
366+-- Parameters Definition object
367+-- =======================================================================
368+
369+paramsDefinitionExample :: HashMap Text Param
370+paramsDefinitionExample =
371+ [ ("skipParam", mempty
372+ & name .~ "skip"
373+ & description ?~ "number of items to skip"
374+ & required ?~ True
375+ & schema .~ ParamOther (mempty
376+ & in_ .~ ParamQuery
377+ & type_ .~ SwaggerInteger
378+ & format ?~ "int32" ))
379+ , ("limitParam", mempty
380+ & name .~ "limit"
381+ & description ?~ "max records to return"
382+ & required ?~ True
383+ & schema .~ ParamOther (mempty
384+ & in_ .~ ParamQuery
385+ & type_ .~ SwaggerInteger
386+ & format ?~ "int32" )) ]
387+
388+paramsDefinitionExampleJSON :: Value
389+paramsDefinitionExampleJSON = [aesonQQ|
390+{
391+ "skipParam": {
392+ "name": "skip",
393+ "in": "query",
394+ "description": "number of items to skip",
395+ "required": true,
396+ "type": "integer",
397+ "format": "int32"
398+ },
399+ "limitParam": {
400+ "name": "limit",
401+ "in": "query",
402+ "description": "max records to return",
403+ "required": true,
404+ "type": "integer",
405+ "format": "int32"
406+ }
407+}
408+|]
409+
410+-- =======================================================================
411+-- Responses Definition object
412+-- =======================================================================
413+
414+responsesDefinitionExample :: HashMap Text Response
415+responsesDefinitionExample =
416+ [ ("NotFound", mempty & description .~ "Entity not found.")
417+ , ("IllegalInput", mempty & description .~ "Illegal input for operation.") ]
418+
419+responsesDefinitionExampleJSON :: Value
420+responsesDefinitionExampleJSON = [aesonQQ|
421+{
422+ "NotFound": {
423+ "description": "Entity not found."
424+ },
425+ "IllegalInput": {
426+ "description": "Illegal input for operation."
427+ }
428+}
429+|]
430+
431+-- =======================================================================
432+-- Responses Definition object
433+-- =======================================================================
434+
435+securityDefinitionsExample :: HashMap Text SecurityScheme
436+securityDefinitionsExample =
437+ [ ("api_key", SecurityScheme
438+ { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
439+ , _securitySchemeDescription = Nothing })
440+ , ("petstore_auth", SecurityScheme
441+ { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params
442+ { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"
443+ , _oauth2Scopes =
444+ [ ("write:pets", "modify pets in your account")
445+ , ("read:pets", "read your pets") ] } )
446+ , _securitySchemeDescription = Nothing }) ]
447+
448+securityDefinitionsExampleJSON :: Value
449+securityDefinitionsExampleJSON = [aesonQQ|
450+{
451+ "api_key": {
452+ "type": "apiKey",
453+ "name": "api_key",
454+ "in": "header"
455+ },
456+ "petstore_auth": {
457+ "type": "oauth2",
458+ "authorizationUrl": "http://swagger.io/api/oauth/dialog",
459+ "flow": "implicit",
460+ "scopes": {
461+ "write:pets": "modify pets in your account",
462+ "read:pets": "read your pets"
463+ }
464+ }
465+}
466+|]
467+
468+-- =======================================================================
469+-- Swagger object
470+-- =======================================================================
471+
472+swaggerExample :: Swagger
473+swaggerExample = mempty
474+ & basePath ?~ "/"
475+ & schemes ?~ [Http]
476+ & info .~ (mempty
477+ & version .~ "1.0"
478+ & title .~ "Todo API"
479+ & license ?~ License "MIT" (Just (URL "http://mit.com"))
480+ & description ?~ "This is a an API that tests servant-swagger support for a Todo API")
481+ & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation)
482+ & at 200 ?~ Inline (mempty
483+ & description .~ "OK"
484+ & schema ?~ Inline (mempty
485+ & type_ .~ SwaggerObject
486+ & example ?~ [aesonQQ|
487+ {
488+ "created": 100,
489+ "description": "get milk"
490+ } |]
491+ & description ?~ "This is some real Todo right here"
492+ & properties .~
493+ [ ("created", Inline $ mempty
494+ & type_ .~ SwaggerInteger
495+ & format ?~ "int32")
496+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))
497+ & produces ?~ MimeList [ "application/json" ]
498+ & parameters .~
499+ [ Inline $ mempty
500+ & required ?~ True
501+ & name .~ "id"
502+ & description ?~ "TodoId param"
503+ & schema .~ ParamOther (mempty
504+ & in_ .~ ParamPath
505+ & type_ .~ SwaggerString ) ]
506+ & tags .~ [ "todo" ] ))
507+
508+swaggerExampleJSON :: Value
509+swaggerExampleJSON = [aesonQQ|
510+{
511+ "swagger": "2.0",
512+ "basePath": "/",
513+ "schemes": [
514+ "http"
515+ ],
516+ "info": {
517+ "version": "1.0",
518+ "title": "Todo API",
519+ "license": {
520+ "url": "http://mit.com",
521+ "name": "MIT"
522+ },
523+ "description": "This is a an API that tests servant-swagger support for a Todo API"
524+ },
525+ "paths": {
526+ "/todo/{id}": {
527+ "get": {
528+ "responses": {
529+ "200": {
530+ "schema": {
531+ "example": {
532+ "created": 100,
533+ "description": "get milk"
534+ },
535+ "type": "object",
536+ "description": "This is some real Todo right here",
537+ "properties": {
538+ "created": {
539+ "format": "int32",
540+ "type": "integer"
541+ },
542+ "description": {
543+ "type": "string"
544+ }
545+ }
546+ },
547+ "description": "OK"
548+ }
549+ },
550+ "produces": [
551+ "application/json"
552+ ],
553+ "parameters": [
554+ {
555+ "required": true,
556+ "in": "path",
557+ "name": "id",
558+ "type": "string",
559+ "description": "TodoId param"
560+ }
561+ ],
562+ "tags": [
563+ "todo"
564+ ]
565+ }
566+ }
567+ }
568+}
569+|]
570+
571+petstoreExampleJSON :: Value
572+petstoreExampleJSON = [aesonQQ|
573+{
574+ "swagger":"2.0",
575+ "info":{
576+ "description":"This is a sample server Petstore server. You can find out more about Swagger at [http://swagger.io](http://swagger.io) or on [irc.freenode.net, #swagger](http://swagger.io/irc/). For this sample, you can use the api key `special-key` to test the authorization filters.",
577+ "version":"1.0.0",
578+ "title":"Swagger Petstore",
579+ "termsOfService":"http://swagger.io/terms/",
580+ "contact":{
581+ "email":"apiteam@swagger.io"
582+ },
583+ "license":{
584+ "name":"Apache 2.0",
585+ "url":"http://www.apache.org/licenses/LICENSE-2.0.html"
586+ }
587+ },
588+ "host":"petstore.swagger.io",
589+ "basePath":"/v2",
590+ "tags":[
591+ {
592+ "name":"pet",
593+ "description":"Everything about your Pets",
594+ "externalDocs":{
595+ "description":"Find out more",
596+ "url":"http://swagger.io"
597+ }
598+ },
599+ {
600+ "name":"store",
601+ "description":"Access to Petstore orders"
602+ },
603+ {
604+ "name":"user",
605+ "description":"Operations about user",
606+ "externalDocs":{
607+ "description":"Find out more about our store",
608+ "url":"http://swagger.io"
609+ }
610+ }
611+ ],
612+ "schemes":[
613+ "http"
614+ ],
615+ "paths":{
616+ "/pet":{
617+ "post":{
618+ "tags":[
619+ "pet"
620+ ],
621+ "summary":"Add a new pet to the store",
622+ "description":"",
623+ "operationId":"addPet",
624+ "consumes":[
625+ "application/json",
626+ "application/xml"
627+ ],
628+ "produces":[
629+ "application/xml",
630+ "application/json"
631+ ],
632+ "parameters":[
633+ {
634+ "in":"body",
635+ "name":"body",
636+ "description":"Pet object that needs to be added to the store",
637+ "required":true,
638+ "schema":{
639+ "$ref":"#/definitions/Pet"
640+ }
641+ }
642+ ],
643+ "responses":{
644+ "405":{
645+ "description":"Invalid input"
646+ }
647+ },
648+ "security":[
649+ {
650+ "petstore_auth":[
651+ "write:pets",
652+ "read:pets"
653+ ]
654+ }
655+ ]
656+ },
657+ "put":{
658+ "tags":[
659+ "pet"
660+ ],
661+ "summary":"Update an existing pet",
662+ "description":"",
663+ "operationId":"updatePet",
664+ "consumes":[
665+ "application/json",
666+ "application/xml"
667+ ],
668+ "produces":[
669+ "application/xml",
670+ "application/json"
671+ ],
672+ "parameters":[
673+ {
674+ "in":"body",
675+ "name":"body",
676+ "description":"Pet object that needs to be added to the store",
677+ "required":true,
678+ "schema":{
679+ "$ref":"#/definitions/Pet"
680+ }
681+ }
682+ ],
683+ "responses":{
684+ "400":{
685+ "description":"Invalid ID supplied"
686+ },
687+ "404":{
688+ "description":"Pet not found"
689+ },
690+ "405":{
691+ "description":"Validation exception"
692+ }
693+ },
694+ "security":[
695+ {
696+ "petstore_auth":[
697+ "write:pets",
698+ "read:pets"
699+ ]
700+ }
701+ ]
702+ }
703+ },
704+ "/pet/findByStatus":{
705+ "get":{
706+ "tags":[
707+ "pet"
708+ ],
709+ "summary":"Finds Pets by status",
710+ "description":"Multiple status values can be provided with comma seperated strings",
711+ "operationId":"findPetsByStatus",
712+ "produces":[
713+ "application/xml",
714+ "application/json"
715+ ],
716+ "parameters":[
717+ {
718+ "name":"status",
719+ "in":"query",
720+ "description":"Status values that need to be considered for filter",
721+ "required":true,
722+ "type":"array",
723+ "items":{
724+ "type":"string",
725+ "enum":[
726+ "available",
727+ "pending",
728+ "sold"
729+ ],
730+ "default":"available"
731+ },
732+ "collectionFormat":"csv"
733+ }
734+ ],
735+ "responses":{
736+ "200":{
737+ "description":"successful operation",
738+ "schema":{
739+ "type":"array",
740+ "items":{
741+ "$ref":"#/definitions/Pet"
742+ }
743+ }
744+ },
745+ "400":{
746+ "description":"Invalid status value"
747+ }
748+ },
749+ "security":[
750+ {
751+ "petstore_auth":[
752+ "write:pets",
753+ "read:pets"
754+ ]
755+ }
756+ ]
757+ }
758+ },
759+ "/pet/findByTags":{
760+ "get":{
761+ "tags":[
762+ "pet"
763+ ],
764+ "summary":"Finds Pets by tags",
765+ "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",
766+ "operationId":"findPetsByTags",
767+ "produces":[
768+ "application/xml",
769+ "application/json"
770+ ],
771+ "parameters":[
772+ {
773+ "name":"tags",
774+ "in":"query",
775+ "description":"Tags to filter by",
776+ "required":true,
777+ "type":"array",
778+ "items":{
779+ "type":"string"
780+ },
781+ "collectionFormat":"csv"
782+ }
783+ ],
784+ "responses":{
785+ "200":{
786+ "description":"successful operation",
787+ "schema":{
788+ "type":"array",
789+ "items":{
790+ "$ref":"#/definitions/Pet"
791+ }
792+ }
793+ },
794+ "400":{
795+ "description":"Invalid tag value"
796+ }
797+ },
798+ "security":[
799+ {
800+ "petstore_auth":[
801+ "write:pets",
802+ "read:pets"
803+ ]
804+ }
805+ ]
806+ }
807+ },
808+ "/pet/{petId}":{
809+ "get":{
810+ "tags":[
811+ "pet"
812+ ],
813+ "summary":"Find pet by ID",
814+ "description":"Returns a single pet",
815+ "operationId":"getPetById",
816+ "produces":[
817+ "application/xml",
818+ "application/json"
819+ ],
820+ "parameters":[
821+ {
822+ "name":"petId",
823+ "in":"path",
824+ "description":"ID of pet to return",
825+ "required":true,
826+ "type":"integer",
827+ "format":"int64"
828+ }
829+ ],
830+ "responses":{
831+ "200":{
832+ "description":"successful operation",
833+ "schema":{
834+ "$ref":"#/definitions/Pet"
835+ }
836+ },
837+ "400":{
838+ "description":"Invalid ID supplied"
839+ },
840+ "404":{
841+ "description":"Pet not found"
842+ }
843+ },
844+ "security":[
845+ {
846+ "api_key":[
847+ ]
848+ }
849+ ]
850+ },
851+ "post":{
852+ "tags":[
853+ "pet"
854+ ],
855+ "summary":"Updates a pet in the store with form data",
856+ "description":"",
857+ "operationId":"updatePetWithForm",
858+ "consumes":[
859+ "application/x-www-form-urlencoded"
860+ ],
861+ "produces":[
862+ "application/xml",
863+ "application/json"
864+ ],
865+ "parameters":[
866+ {
867+ "name":"petId",
868+ "in":"path",
869+ "description":"ID of pet that needs to be updated",
870+ "required":true,
871+ "type":"integer",
872+ "format":"int64"
873+ },
874+ {
875+ "name":"name",
876+ "in":"formData",
877+ "description":"Updated name of the pet",
878+ "required":false,
879+ "type":"string"
880+ },
881+ {
882+ "name":"status",
883+ "in":"formData",
884+ "description":"Updated status of the pet",
885+ "required":false,
886+ "type":"string"
887+ }
888+ ],
889+ "responses":{
890+ "405":{
891+ "description":"Invalid input"
892+ }
893+ },
894+ "security":[
895+ {
896+ "petstore_auth":[
897+ "write:pets",
898+ "read:pets"
899+ ]
900+ }
901+ ]
902+ },
903+ "delete":{
904+ "tags":[
905+ "pet"
906+ ],
907+ "summary":"Deletes a pet",
908+ "description":"",
909+ "operationId":"deletePet",
910+ "produces":[
911+ "application/xml",
912+ "application/json"
913+ ],
914+ "parameters":[
915+ {
916+ "name":"api_key",
917+ "in":"header",
918+ "required":false,
919+ "type":"string"
920+ },
921+ {
922+ "name":"petId",
923+ "in":"path",
924+ "description":"Pet id to delete",
925+ "required":true,
926+ "type":"integer",
927+ "format":"int64"
928+ }
929+ ],
930+ "responses":{
931+ "400":{
932+ "description":"Invalid pet value"
933+ }
934+ },
935+ "security":[
936+ {
937+ "petstore_auth":[
938+ "write:pets",
939+ "read:pets"
940+ ]
941+ }
942+ ]
943+ }
944+ },
945+ "/pet/{petId}/uploadImage":{
946+ "post":{
947+ "tags":[
948+ "pet"
949+ ],
950+ "summary":"uploads an image",
951+ "description":"",
952+ "operationId":"uploadFile",
953+ "consumes":[
954+ "multipart/form-data"
955+ ],
956+ "produces":[
957+ "application/json"
958+ ],
959+ "parameters":[
960+ {
961+ "name":"petId",
962+ "in":"path",
963+ "description":"ID of pet to update",
964+ "required":true,
965+ "type":"integer",
966+ "format":"int64"
967+ },
968+ {
969+ "name":"additionalMetadata",
970+ "in":"formData",
971+ "description":"Additional data to pass to server",
972+ "required":false,
973+ "type":"string"
974+ },
975+ {
976+ "name":"file",
977+ "in":"formData",
978+ "description":"file to upload",
979+ "required":false,
980+ "type":"file"
981+ }
982+ ],
983+ "responses":{
984+ "200":{
985+ "description":"successful operation",
986+ "schema":{
987+ "$ref":"#/definitions/ApiResponse"
988+ }
989+ }
990+ },
991+ "security":[
992+ {
993+ "petstore_auth":[
994+ "write:pets",
995+ "read:pets"
996+ ]
997+ }
998+ ]
999+ }
1000+ },
1001+ "/store/inventory":{
1002+ "get":{
1003+ "tags":[
1004+ "store"
1005+ ],
1006+ "summary":"Returns pet inventories by status",
1007+ "description":"Returns a map of status codes to quantities",
1008+ "operationId":"getInventory",
1009+ "produces":[
1010+ "application/json"
1011+ ],
1012+ "parameters":[
1013+ ],
1014+ "responses":{
1015+ "200":{
1016+ "description":"successful operation",
1017+ "schema":{
1018+ "type":"object",
1019+ "additionalProperties":{
1020+ "type":"integer",
1021+ "format":"int32"
1022+ }
1023+ }
1024+ }
1025+ },
1026+ "security":[
1027+ {
1028+ "api_key":[
1029+ ]
1030+ }
1031+ ]
1032+ }
1033+ },
1034+ "/store/order":{
1035+ "post":{
1036+ "tags":[
1037+ "store"
1038+ ],
1039+ "summary":"Place an order for a pet",
1040+ "description":"",
1041+ "operationId":"placeOrder",
1042+ "produces":[
1043+ "application/xml",
1044+ "application/json"
1045+ ],
1046+ "parameters":[
1047+ {
1048+ "in":"body",
1049+ "name":"body",
1050+ "description":"order placed for purchasing the pet",
1051+ "required":true,
1052+ "schema":{
1053+ "$ref":"#/definitions/Order"
1054+ }
1055+ }
1056+ ],
1057+ "responses":{
1058+ "200":{
1059+ "description":"successful operation",
1060+ "schema":{
1061+ "$ref":"#/definitions/Order"
1062+ }
1063+ },
1064+ "400":{
1065+ "description":"Invalid Order"
1066+ }
1067+ }
1068+ }
1069+ },
1070+ "/store/order/{orderId}":{
1071+ "get":{
1072+ "tags":[
1073+ "store"
1074+ ],
1075+ "summary":"Find purchase order by ID",
1076+ "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",
1077+ "operationId":"getOrderById",
1078+ "produces":[
1079+ "application/xml",
1080+ "application/json"
1081+ ],
1082+ "parameters":[
1083+ {
1084+ "name":"orderId",
1085+ "in":"path",
1086+ "description":"ID of pet that needs to be fetched",
1087+ "required":true,
1088+ "type":"integer",
1089+ "maximum":5.0,
1090+ "minimum":1.0,
1091+ "format":"int64"
1092+ }
1093+ ],
1094+ "responses":{
1095+ "200":{
1096+ "description":"successful operation",
1097+ "schema":{
1098+ "$ref":"#/definitions/Order"
1099+ }
1100+ },
1101+ "400":{
1102+ "description":"Invalid ID supplied"
1103+ },
1104+ "404":{
1105+ "description":"Order not found"
1106+ }
1107+ }
1108+ },
1109+ "delete":{
1110+ "tags":[
1111+ "store"
1112+ ],
1113+ "summary":"Delete purchase order by ID",
1114+ "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",
1115+ "operationId":"deleteOrder",
1116+ "produces":[
1117+ "application/xml",
1118+ "application/json"
1119+ ],
1120+ "parameters":[
1121+ {
1122+ "name":"orderId",
1123+ "in":"path",
1124+ "description":"ID of the order that needs to be deleted",
1125+ "required":true,
1126+ "type":"string",
1127+ "minimum":1.0
1128+ }
1129+ ],
1130+ "responses":{
1131+ "400":{
1132+ "description":"Invalid ID supplied"
1133+ },
1134+ "404":{
1135+ "description":"Order not found"
1136+ }
1137+ }
1138+ }
1139+ },
1140+ "/user":{
1141+ "post":{
1142+ "tags":[
1143+ "user"
1144+ ],
1145+ "summary":"Create user",
1146+ "description":"This can only be done by the logged in user.",
1147+ "operationId":"createUser",
1148+ "produces":[
1149+ "application/xml",
1150+ "application/json"
1151+ ],
1152+ "parameters":[
1153+ {
1154+ "in":"body",
1155+ "name":"body",
1156+ "description":"Created user object",
1157+ "required":true,
1158+ "schema":{
1159+ "$ref":"#/definitions/User"
1160+ }
1161+ }
1162+ ],
1163+ "responses":{
1164+ "default":{
1165+ "description":"successful operation"
1166+ }
1167+ }
1168+ }
1169+ },
1170+ "/user/createWithArray":{
1171+ "post":{
1172+ "tags":[
1173+ "user"
1174+ ],
1175+ "summary":"Creates list of users with given input array",
1176+ "description":"",
1177+ "operationId":"createUsersWithArrayInput",
1178+ "produces":[
1179+ "application/xml",
1180+ "application/json"
1181+ ],
1182+ "parameters":[
1183+ {
1184+ "in":"body",
1185+ "name":"body",
1186+ "description":"List of user object",
1187+ "required":true,
1188+ "schema":{
1189+ "type":"array",
1190+ "items":{
1191+ "$ref":"#/definitions/User"
1192+ }
1193+ }
1194+ }
1195+ ],
1196+ "responses":{
1197+ "default":{
1198+ "description":"successful operation"
1199+ }
1200+ }
1201+ }
1202+ },
1203+ "/user/createWithList":{
1204+ "post":{
1205+ "tags":[
1206+ "user"
1207+ ],
1208+ "summary":"Creates list of users with given input array",
1209+ "description":"",
1210+ "operationId":"createUsersWithListInput",
1211+ "produces":[
1212+ "application/xml",
1213+ "application/json"
1214+ ],
1215+ "parameters":[
1216+ {
1217+ "in":"body",
1218+ "name":"body",
1219+ "description":"List of user object",
1220+ "required":true,
1221+ "schema":{
1222+ "type":"array",
1223+ "items":{
1224+ "$ref":"#/definitions/User"
1225+ }
1226+ }
1227+ }
1228+ ],
1229+ "responses":{
1230+ "default":{
1231+ "description":"successful operation"
1232+ }
1233+ }
1234+ }
1235+ },
1236+ "/user/login":{
1237+ "get":{
1238+ "tags":[
1239+ "user"
1240+ ],
1241+ "summary":"Logs user into the system",
1242+ "description":"",
1243+ "operationId":"loginUser",
1244+ "produces":[
1245+ "application/xml",
1246+ "application/json"
1247+ ],
1248+ "parameters":[
1249+ {
1250+ "name":"username",
1251+ "in":"query",
1252+ "description":"The user name for login",
1253+ "required":true,
1254+ "type":"string"
1255+ },
1256+ {
1257+ "name":"password",
1258+ "in":"query",
1259+ "description":"The password for login in clear text",
1260+ "required":true,
1261+ "type":"string"
1262+ }
1263+ ],
1264+ "responses":{
1265+ "200":{
1266+ "description":"successful operation",
1267+ "schema":{
1268+ "type":"string"
1269+ },
1270+ "headers":{
1271+ "X-Rate-Limit":{
1272+ "type":"integer",
1273+ "format":"int32",
1274+ "description":"calls per hour allowed by the user"
1275+ },
1276+ "X-Expires-After":{
1277+ "type":"string",
1278+ "format":"date-time",
1279+ "description":"date in UTC when toekn expires"
1280+ }
1281+ }
1282+ },
1283+ "400":{
1284+ "description":"Invalid username/password supplied"
1285+ }
1286+ }
1287+ }
1288+ },
1289+ "/user/logout":{
1290+ "get":{
1291+ "tags":[
1292+ "user"
1293+ ],
1294+ "summary":"Logs out current logged in user session",
1295+ "description":"",
1296+ "operationId":"logoutUser",
1297+ "produces":[
1298+ "application/xml",
1299+ "application/json"
1300+ ],
1301+ "parameters":[
1302+ ],
1303+ "responses":{
1304+ "default":{
1305+ "description":"successful operation"
1306+ }
1307+ }
1308+ }
1309+ },
1310+ "/user/{username}":{
1311+ "get":{
1312+ "tags":[
1313+ "user"
1314+ ],
1315+ "summary":"Get user by user name",
1316+ "description":"",
1317+ "operationId":"getUserByName",
1318+ "produces":[
1319+ "application/xml",
1320+ "application/json"
1321+ ],
1322+ "parameters":[
1323+ {
1324+ "name":"username",
1325+ "in":"path",
1326+ "description":"The name that needs to be fetched. Use user1 for testing. ",
1327+ "required":true,
1328+ "type":"string"
1329+ }
1330+ ],
1331+ "responses":{
1332+ "200":{
1333+ "description":"successful operation",
1334+ "schema":{
1335+ "$ref":"#/definitions/User"
1336+ }
1337+ },
1338+ "400":{
1339+ "description":"Invalid username supplied"
1340+ },
1341+ "404":{
1342+ "description":"User not found"
1343+ }
1344+ }
1345+ },
1346+ "put":{
1347+ "tags":[
1348+ "user"
1349+ ],
1350+ "summary":"Updated user",
1351+ "description":"This can only be done by the logged in user.",
1352+ "operationId":"updateUser",
1353+ "produces":[
1354+ "application/xml",
1355+ "application/json"
1356+ ],
1357+ "parameters":[
1358+ {
1359+ "name":"username",
1360+ "in":"path",
1361+ "description":"name that need to be deleted",
1362+ "required":true,
1363+ "type":"string"
1364+ },
1365+ {
1366+ "in":"body",
1367+ "name":"body",
1368+ "description":"Updated user object",
1369+ "required":true,
1370+ "schema":{
1371+ "$ref":"#/definitions/User"
1372+ }
1373+ }
1374+ ],
1375+ "responses":{
1376+ "400":{
1377+ "description":"Invalid user supplied"
1378+ },
1379+ "404":{
1380+ "description":"User not found"
1381+ }
1382+ }
1383+ },
1384+ "delete":{
1385+ "tags":[
1386+ "user"
1387+ ],
1388+ "summary":"Delete user",
1389+ "description":"This can only be done by the logged in user.",
1390+ "operationId":"deleteUser",
1391+ "produces":[
1392+ "application/xml",
1393+ "application/json"
1394+ ],
1395+ "parameters":[
1396+ {
1397+ "name":"username",
1398+ "in":"path",
1399+ "description":"The name that needs to be deleted",
1400+ "required":true,
1401+ "type":"string"
1402+ }
1403+ ],
1404+ "responses":{
1405+ "400":{
1406+ "description":"Invalid username supplied"
1407+ },
1408+ "404":{
1409+ "description":"User not found"
1410+ }
1411+ }
1412+ }
1413+ }
1414+ },
1415+ "securityDefinitions":{
1416+ "petstore_auth":{
1417+ "type":"oauth2",
1418+ "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",
1419+ "flow":"implicit",
1420+ "scopes":{
1421+ "write:pets":"modify pets in your account",
1422+ "read:pets":"read your pets"
1423+ }
1424+ },
1425+ "api_key":{
1426+ "type":"apiKey",
1427+ "name":"api_key",
1428+ "in":"header"
1429+ }
1430+ },
1431+ "definitions":{
1432+ "Order":{
1433+ "type":"object",
1434+ "properties":{
1435+ "id":{
1436+ "type":"integer",
1437+ "format":"int64"
1438+ },
1439+ "petId":{
1440+ "type":"integer",
1441+ "format":"int64"
1442+ },
1443+ "quantity":{
1444+ "type":"integer",
1445+ "format":"int32"
1446+ },
1447+ "shipDate":{
1448+ "type":"string",
1449+ "format":"date-time"
1450+ },
1451+ "status":{
1452+ "type":"string",
1453+ "description":"Order Status",
1454+ "enum":[
1455+ "placed",
1456+ "approved",
1457+ "delivered"
1458+ ]
1459+ },
1460+ "complete":{
1461+ "type":"boolean",
1462+ "default":false
1463+ }
1464+ },
1465+ "xml":{
1466+ "name":"Order"
1467+ }
1468+ },
1469+ "Category":{
1470+ "type":"object",
1471+ "properties":{
1472+ "id":{
1473+ "type":"integer",
1474+ "format":"int64"
1475+ },
1476+ "name":{
1477+ "type":"string"
1478+ }
1479+ },
1480+ "xml":{
1481+ "name":"Category"
1482+ }
1483+ },
1484+ "User":{
1485+ "type":"object",
1486+ "properties":{
1487+ "id":{
1488+ "type":"integer",
1489+ "format":"int64"
1490+ },
1491+ "username":{
1492+ "type":"string"
1493+ },
1494+ "firstName":{
1495+ "type":"string"
1496+ },
1497+ "lastName":{
1498+ "type":"string"
1499+ },
1500+ "email":{
1501+ "type":"string"
1502+ },
1503+ "password":{
1504+ "type":"string"
1505+ },
1506+ "phone":{
1507+ "type":"string"
1508+ },
1509+ "userStatus":{
1510+ "type":"integer",
1511+ "format":"int32",
1512+ "description":"User Status"
1513+ }
1514+ },
1515+ "xml":{
1516+ "name":"User"
1517+ }
1518+ },
1519+ "Tag":{
1520+ "type":"object",
1521+ "properties":{
1522+ "id":{
1523+ "type":"integer",
1524+ "format":"int64"
1525+ },
1526+ "name":{
1527+ "type":"string"
1528+ }
1529+ },
1530+ "xml":{
1531+ "name":"Tag"
1532+ }
1533+ },
1534+ "Pet":{
1535+ "type":"object",
1536+ "required":[
1537+ "name",
1538+ "photoUrls"
1539+ ],
1540+ "properties":{
1541+ "id":{
1542+ "type":"integer",
1543+ "format":"int64"
1544+ },
1545+ "category":{
1546+ "$ref":"#/definitions/Category"
1547+ },
1548+ "name":{
1549+ "type":"string",
1550+ "example":"doggie"
1551+ },
1552+ "photoUrls":{
1553+ "type":"array",
1554+ "xml":{
1555+ "name":"photoUrl",
1556+ "wrapped":true
1557+ },
1558+ "items":{
1559+ "type":"string"
1560+ }
1561+ },
1562+ "tags":{
1563+ "type":"array",
1564+ "xml":{
1565+ "name":"tag",
1566+ "wrapped":true
1567+ },
1568+ "items":{
1569+ "$ref":"#/definitions/Tag"
1570+ }
1571+ },
1572+ "status":{
1573+ "type":"string",
1574+ "description":"pet status in the store",
1575+ "enum":[
1576+ "available",
1577+ "pending",
1578+ "sold"
1579+ ]
1580+ }
1581+ },
1582+ "xml":{
1583+ "name":"Pet"
1584+ }
1585+ },
1586+ "ApiResponse":{
1587+ "type":"object",
1588+ "properties":{
1589+ "code":{
1590+ "type":"integer",
1591+ "format":"int32"
1592+ },
1593+ "type":{
1594+ "type":"string"
1595+ },
1596+ "message":{
1597+ "type":"string"
1598+ }
1599+ }
1600+ }
1601+ },
1602+ "externalDocs":{
1603+ "description":"Find out more about Swagger",
1604+ "url":"http://swagger.io"
1605+ }
1606+}
1607+|]
test/DocTest.hsnew file+7
@@ -0,0 +1,7 @@
1+module Main (main) where
2+
3+import System.FilePath.Glob (glob)
4+import Test.DocTest (doctest)
5+
6+main :: IO ()
7+main = glob "src/**/*.hs" >>= doctest
test/SpecCommon.hs+11−8
@@ -1,22 +1,25 @@
1module SpecCommon where
1module SpecCommon where
2
2
3import Data.Aeson
3import Data.Aeson
4−import Data.ByteString.Builder (toLazyByteString)
5import qualified Data.Foldable as F
4import qualified Data.Foldable as F
6import qualified Data.HashMap.Strict as HashMap
5import qualified Data.HashMap.Strict as HashMap
7import qualified Data.Vector as Vector
6import qualified Data.Vector as Vector
8
7
9import Test.Hspec
8import Test.Hspec
10
9
10+isSubJSON :: Value -> Value -> Bool
11+isSubJSON Null _ = True
12+isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i
13+ where
14+ i = HashMap.intersectionWith isSubJSON x y
15+isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys)
16+isSubJSON x y = x == y
17+
11−(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec
18+(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec
12x <=> js = do
19x <=> js = do
13 it "encodes correctly" $ do
20 it "encodes correctly" $ do
14 toJSON x `shouldBe` js
21 toJSON x `shouldBe` js
15 it "decodes correctly" $ do
22 it "decodes correctly" $ do
16 fromJSON js `shouldBe` Success x
23 fromJSON js `shouldBe` Success x
17− it "roundtrips: eitherDecode . encode" $ do
24+
18− eitherDecode (encode x) `shouldBe` Right x
25+
19− it "roundtrips with toJSON" $ do
20− eitherDecode (encode $ toJSON x) `shouldBe` Right x
21− it "roundtrips with toEncoding" $ do
22− eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x
test/doctests.hsdeleted−12
@@ -1,12 +0,0 @@
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