git.iko.soy/typeable/openapi3
on cb43d01 help sign in
53 files changed+5294−9041
since splitsnapshots
unifiedsplit
.github/workflows/haskell-ci.yml−243 .gitignore−2 .travis.yml+79 CHANGELOG.md+1−248 LICENSE+1−1 README.md+10−14 Setup.hs−31 cabal.haskell-ci−11 cabal.project−4 examples/hackage.hs+32−44 hackage-docs.sh−78 include/overlapping-compat.h+8 openapi3.cabal−160 src/Data/OpenApi.hs−428 src/Data/OpenApi/Aeson/Compat.hs−76 src/Data/OpenApi/Internal.hs−1619 src/Data/OpenApi/Internal/AesonUtils.hs−313 src/Data/OpenApi/Internal/Schema.hs−1126 src/Data/OpenApi/Internal/Schema/Validation.hs−536 src/Data/OpenApi/Internal/TypeShape.hs−56 src/Data/OpenApi/Lens.hs−166 src/Data/OpenApi/Operation.hs−305 src/Data/OpenApi/Optics.hs−328 src/Data/OpenApi/Schema/Generator.hs−117 src/Data/OpenApi/Schema/Validation.hs−90 src/Data/OpenApi/SchemaOptions.hs−76 src/Data/Swagger.hs+259 src/Data/OpenApi/Declare.hs → src/Data/Swagger/Declare.hs+9−83 src/Data/Swagger/Internal.hs+1171 src/Data/OpenApi/Internal/ParamSchema.hs → src/Data/Swagger/Internal/ParamSchema.hs+48−162 src/Data/Swagger/Internal/Schema.hs+577 src/Data/OpenApi/Internal/Utils.hs → src/Data/Swagger/Internal/Utils.hs+46−15 src/Data/Swagger/Lens.hs+165 src/Data/OpenApi/ParamSchema.hs → src/Data/Swagger/ParamSchema.hs+6−9 src/Data/OpenApi/Schema.hs → src/Data/Swagger/Schema.hs+6−19 src/Data/Swagger/Schema/Validation.hs+275 src/Data/Swagger/SchemaOptions.hs+37 stack-lts-2.yaml+5 stack.yaml+3−7 swagger2.cabal+93 test/Data/OpenApi/CommonTestTypes.hs−1042 test/Data/OpenApi/ParamSchemaSpec.hs−39 test/Data/OpenApi/Schema/GeneratorSpec.hs−168 test/Data/OpenApi/Schema/ValidationSpec.hs−324 test/Data/OpenApi/SchemaSpec.hs−119 test/Data/OpenApiSpec.hs−962 test/Data/Swagger/ParamSchemaSpec.hs+114 test/Data/Swagger/Schema/ValidationSpec.hs+122 test/Data/Swagger/SchemaSpec.hs+602 test/Data/SwaggerSpec.hs+1606 test/DocTest.hs+8 test/SpecCommon.hs+11−8 test/doctests.hs−12
.github/workflows/haskell-ci.ymldeleted−243
@@ -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 @@
11dist
2−dist-newstyle
3−.ghc.environment.*
42cabal-dev
53*.o
64*.hi
.travis.ymlnew file+79
@@ -0,0 +1,79 @@
1+# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
2+language: c
3+sudo: false
4+
5+cache:
6+ directories:
7+ - $HOME/.cabsnap
8+ - $HOME/.cabal/packages
9+
10+before_cache:
11+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
12+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
13+
14+matrix:
15+ include:
16+ - env: CABALVER=1.18 GHCVER=7.8.4
17+ compiler: ": #GHC 7.8.4"
18+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5], sources: [hvr-ghc]}}
19+ - env: CABALVER=1.22 GHCVER=7.10.3
20+ compiler: ": #GHC 7.10.3"
21+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5], sources: [hvr-ghc]}}
22+
23+before_install:
24+ - unset CC
25+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/1.19.5/bin:$PATH
26+
27+install:
28+ - cabal --version
29+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
30+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
31+ then
32+ zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
33+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
34+ fi
35+ - travis_retry cabal update -v
36+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
37+ - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
38+ - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
39+
40+# check whether current requested install-plan matches cached package-db snapshot
41+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
42+ then
43+ echo "cabal build-cache HIT";
44+ rm -rfv .ghc;
45+ cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
46+ cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
47+ else
48+ echo "cabal build-cache MISS";
49+ rm -rf $HOME/.cabsnap;
50+ mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
51+ cabal install --only-dependencies --enable-tests --enable-benchmarks;
52+ fi
53+
54+# snapshot package-db on cache miss
55+ - if [ ! -d $HOME/.cabsnap ];
56+ then
57+ echo "snapshotting package-db to build-cache";
58+ mkdir $HOME/.cabsnap;
59+ cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
60+ cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
61+ fi
62+
63+# Here starts the actual work to be performed for the package under test;
64+# any command which exits with a non-zero exit code causes the build to fail.
65+script:
66+ - if [ -f configure.ac ]; then autoreconf -i; fi
67+ - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
68+ - cabal build # this builds all libraries and executables (including tests/benchmarks)
69+ - cabal test
70+ - cabal check
71+ - cabal sdist # tests that a source-distribution can be generated
72+
73+# Check that the resulting source distribution can be built & installed.
74+# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
75+# `cabal install --force-reinstalls dist/*-*.tar.gz`
76+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
77+ (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
78+
79+# EOF
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−
24811.2.1
2492---
2503
251−* Minor changes:
4+* Minor change:
2525 * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.
2536
2547* Fixes:
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015-2017, GetShopTV
1+Copyright (c) 2015, GetShopTV
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without
README.md+10−14
@@ -1,22 +1,19 @@
1−# OpenApi 3
1+# swagger2
22
3−[![Hackage](https://img.shields.io/hackage/v/openapi3.svg)](http://hackage.haskell.org/package/openapi3)
4−[![Build Status](https://travis-ci.org/biocad/openapi3.svg?branch=master)](https://travis-ci.org/biocad/openapi3)
5−[![Stackage LTS](http://stackage.org/package/openapi3/badge/lts)](http://stackage.org/lts/package/opeopenapi3)
6−[![Stackage Nightly](http://stackage.org/package/openapi3/badge/nightly)](http://stackage.org/nightly/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/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)
5+[![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2)
6+[![Stackage Nightly](http://stackage.org/package/swagger2/badge/nightly)](http://stackage.org/nightly/package/swagger2)
77
8−OpenAPI 3.0 data model.
8+Swagger 2.0 data model.
99
10−The original OpenAPI 3.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.
10+The original Swagger 2.0 specification is available at http://swagger.io/specification/.
1411
1512## Usage
1613
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.
1815
19−Please refer to [haddock documentation](http://hackage.haskell.org/package/openapi3).
16+Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2).
2017
2118Some examples can be found in [`examples/` directory](/examples).
2219
@@ -34,8 +31,7 @@ Many Swagger tools, including server and client code generation for many languag
3431
3532We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.
3633
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).
3835
3936*GetShopTV Team*
4037
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−
281import Distribution.Simple
29−
30−main :: IO ()
312main = 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
1010import Data.Text (Text)
1111import GHC.Generics
1212
13−import Data.OpenApi
14−import Data.OpenApi.Declare
15−import Data.OpenApi.Lens
16−import Data.OpenApi.Operation
13+import Data.Swagger
14+import Data.Swagger.Declare
15+import Data.Swagger.Lens
1716
1817type Username = Text
1918
2019data UserSummary = UserSummary
2120 { summaryUsername :: Username
2221 , summaryUserid :: Int
23− } deriving (Generic)
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−
22+ } deriving (Generic, ToSchema)
3823
3924type Group = Text
4025
@@ -47,36 +32,39 @@ data UserDetailed = UserDetailed
4732newtype Package = Package { packageName :: Text }
4833 deriving (Generic, ToSchema)
4934
50−hackageOpenApi :: OpenApi
51−hackageOpenApi = spec & components.schemas .~ defs
35+hackageSwagger :: Swagger
36+hackageSwagger = spec & definitions .~ defs
5237 where
53− (defs, spec) = runDeclare declareHackageOpenApi mempty
38+ (defs, spec) = runDeclare declareHackageSwagger mempty
5439
55−declareHackageOpenApi :: Declare (Definitions Schema) OpenApi
56−declareHackageOpenApi = do
57− -- param schemas
40+declareHackageSwagger :: Declare Definitions Swagger
41+declareHackageSwagger = do
5842 let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)
59−
60− -- responses
61− userSummaryResponse <- declareResponse "application/json" (Proxy :: Proxy UserSummary)
62− userDetailedResponse <- declareResponse "application/json" (Proxy :: Proxy UserDetailed)
63− packagesResponse <- declareResponse "application/json" (Proxy :: Proxy [Package])
64−
43+ userSummarySchemaRef <- declareSchemaRef (Proxy :: Proxy UserSummary)
44+ userDetailedSchemaRef <- declareSchemaRef (Proxy :: Proxy UserDetailed)
45+ packagesSchemaRef <- declareSchemaRef (Proxy :: Proxy [Package])
6546 return $ mempty
66− & paths .~
67− [ ("/users", mempty & get ?~ (mempty
68− & at 200 ?~ Inline userSummaryResponse))
69− , ("/user/{username}", mempty & get ?~ (mempty
70− & parameters .~ [ Inline $ mempty
71− & name .~ "username"
72− & required ?~ True
73− & in_ .~ ParamPath
74− & schema ?~ Inline usernameParamSchema ]
75− & at 200 ?~ Inline userDetailedResponse))
76− , ("/packages", mempty & get ?~ (mempty
77− & at 200 ?~ Inline packagesResponse))
47+ & paths.pathsMap .~
48+ [ ("/users", mempty & pathItemGet ?~ (mempty
49+ & operationProduces ?~ MimeList ["application/json"]
50+ & operationResponses .~ (mempty
51+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ userSummarySchemaRef))))
52+ , ("/user/{username}", mempty & pathItemGet ?~ (mempty
53+ & operationProduces ?~ MimeList ["application/json"]
54+ & operationParameters .~ [ Inline $ mempty
55+ & paramName .~ "username"
56+ & paramRequired ?~ True
57+ & paramSchema .~ ParamOther (mempty
58+ & paramOtherSchemaIn .~ ParamPath
59+ & paramOtherSchemaParamSchema .~ usernameParamSchema) ]
60+ & operationResponses .~ (mempty
61+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ userDetailedSchemaRef))))
62+ , ("/packages", mempty & pathItemGet ?~ (mempty
63+ & operationProduces ?~ MimeList ["application/json"]
64+ & operationResponses .~ (mempty
65+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ packagesSchemaRef))))
7866 ]
7967
8068main :: IO ()
81−main = putStrLn . read . show . encode $ hackageOpenApi
69+main = putStrLn . read . show . encode $ hackageSwagger
8270
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"
include/overlapping-compat.hnew file+8
@@ -0,0 +1,8 @@
1+#if __GLASGOW_HASKELL__ >= 710
2+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
3+#define OVERLAPPING_ {-# OVERLAPPING #-}
4+#else
5+{-# LANGUAGE OverlappingInstances #-}
6+#define OVERLAPPABLE_
7+#define OVERLAPPING_
8+#endif
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+9−83
@@ -2,33 +2,15 @@
22{-# LANGUAGE FlexibleInstances #-}
33{-# LANGUAGE FunctionalDependencies #-}
44{-# 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
136
147import Prelude ()
158import Prelude.Compat
169
1710import Control.Monad
18−import Control.Monad.Cont (ContT)
19−import Control.Monad.List (ListT)
20−import Control.Monad.Reader (ReaderT)
2111import 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
3112import Data.Functor.Identity
13+import Data.Monoid
3214
3315-- | A declare monad transformer parametrized by:
3416--
@@ -49,18 +31,18 @@ instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
4931 pure x = DeclareT (\_ -> pure (mempty, x))
5032 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
5133 ~(d', f) <- df d
52− ~(d'', x) <- dx (mappend d d')
53− return (mappend d' d'', f x)
34+ ~(d'', x) <- dx (d <> d')
35+ return (d' <> d'', f x)
5436
5537instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
5638 return x = DeclareT (\_ -> pure (mempty, x))
5739 DeclareT dx >>= f = DeclareT $ \d -> do
5840 ~(d', x) <- dx d
59− ~(d'', y) <- runDeclareT (f x) (mappend d d')
60− return (mappend d' d'', y)
41+ ~(d'', y) <- runDeclareT (f x) (d <> d')
42+ return (d' <> d'', y)
6143
6244instance Monoid d => MonadTrans (DeclareT d) where
63− lift m = DeclareT (\_ -> (,) mempty <$> m)
45+ lift m = DeclareT (\_ -> (,) mempty `liftM` m)
6446
6547-- |
6648-- Definitions of @declare@ and @look@ must satisfy the following laws:
@@ -89,13 +71,6 @@ instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) whe
8971 declare d = DeclareT (\_ -> return (d, ()))
9072 look = DeclareT (\d -> return (mempty, d))
9173
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−
9974-- | Retrieve a function of all the output so far.
10075looks :: MonadDeclare d m => (d -> a) -> m a
10176looks f = f <$> look
@@ -103,12 +78,12 @@ looks f = f <$> look
10378-- | Evaluate @'DeclareT' d m a@ computation,
10479-- ignoring new output @d@.
10580evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
106−evalDeclareT (DeclareT f) d = snd <$> f d
81+evalDeclareT (DeclareT f) d = snd `liftM` f d
10782
10883-- | Execute @'DeclateT' d m a@ computation,
10984-- ignoring result and only producing new output @d@.
11085execDeclareT :: Monad m => DeclareT d m a -> d -> m d
111−execDeclareT (DeclareT f) d = fst <$> f d
86+execDeclareT (DeclareT f) d = fst `liftM` f d
11287
11388-- | Evaluate @'DeclareT' d m a@ computation,
11489-- starting with empty output history.
@@ -144,52 +119,3 @@ execDeclare m = runIdentity . execDeclareT m
144119undeclare :: Monoid d => Declare d a -> a
145120undeclare = runIdentity . undeclareT
146121
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+1171
@@ -0,0 +1,1171 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE DeriveTraversable #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE RecordWildCards #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE StandaloneDeriving #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+#include "overlapping-compat.h"
15+module Data.Swagger.Internal where
16+
17+import Prelude ()
18+import Prelude.Compat
19+
20+import Control.Applicative
21+import Control.Monad
22+import Data.Aeson
23+import qualified Data.Aeson.Types as JSON
24+import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
25+import Data.HashMap.Strict (HashMap)
26+import qualified Data.HashMap.Strict as HashMap
27+import Data.Map (Map)
28+import qualified Data.Map as Map
29+import Data.Monoid
30+import Data.Scientific (Scientific)
31+import Data.String (fromString)
32+import Data.Text (Text)
33+import qualified Data.Text as Text
34+import GHC.Generics (Generic)
35+import Network (HostName, PortNumber)
36+import Network.HTTP.Media (MediaType)
37+import Text.Read (readMaybe)
38+
39+import Data.Swagger.Internal.Utils
40+
41+-- | A list of definitions that can be used in references.
42+type Definitions = HashMap Text
43+
44+-- | This is the root document object for the API specification.
45+data Swagger = Swagger
46+ { -- | Provides metadata about the API.
47+ -- The metadata can be used by the clients if needed.
48+ _swaggerInfo :: Info
49+
50+ -- | The host (name or ip) serving the API. It MAY include a port.
51+ -- If the host is not included, the host serving the documentation is to be used (including the port).
52+ , _swaggerHost :: Maybe Host
53+
54+ -- | The base path on which the API is served, which is relative to the host.
55+ -- If it is not included, the API is served directly under the host.
56+ -- The value MUST start with a leading slash (/).
57+ , _swaggerBasePath :: Maybe FilePath
58+
59+ -- | The transfer protocol of the API.
60+ -- If the schemes is not included, the default scheme to be used is the one used to access the Swagger definition itself.
61+ , _swaggerSchemes :: Maybe [Scheme]
62+
63+ -- | A list of MIME types the APIs can consume.
64+ -- This is global to all APIs but can be overridden on specific API calls.
65+ , _swaggerConsumes :: MimeList
66+
67+ -- | A list of MIME types the APIs can produce.
68+ -- This is global to all APIs but can be overridden on specific API calls.
69+ , _swaggerProduces :: MimeList
70+
71+ -- | The available paths and operations for the API.
72+ -- Holds the relative paths to the individual endpoints.
73+ -- The path is appended to the @'basePath'@ in order to construct the full URL.
74+ , _swaggerPaths :: HashMap FilePath PathItem
75+
76+ -- | An object to hold data types produced and consumed by operations.
77+ , _swaggerDefinitions :: Definitions Schema
78+
79+ -- | An object to hold parameters that can be used across operations.
80+ -- This property does not define global parameters for all operations.
81+ , _swaggerParameters :: Definitions Param
82+
83+ -- | An object to hold responses that can be used across operations.
84+ -- This property does not define global responses for all operations.
85+ , _swaggerResponses :: Definitions Response
86+
87+ -- | Security scheme definitions that can be used across the specification.
88+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme
89+
90+ -- | A declaration of which security schemes are applied for the API as a whole.
91+ -- The list of values describes alternative security schemes that can be used
92+ -- (that is, there is a logical OR between the security requirements).
93+ -- Individual operations can override this definition.
94+ , _swaggerSecurity :: [SecurityRequirement]
95+
96+ -- | A list of tags used by the specification with additional metadata.
97+ -- The order of the tags can be used to reflect on their order by the parsing tools.
98+ -- Not all tags that are used by the Operation Object must be declared.
99+ -- The tags that are not declared may be organized randomly or based on the tools' logic.
100+ -- Each tag name in the list MUST be unique.
101+ , _swaggerTags :: [Tag]
102+
103+ -- | Additional external documentation.
104+ , _swaggerExternalDocs :: Maybe ExternalDocs
105+ } deriving (Eq, Show, Generic, Data, Typeable)
106+
107+-- | The object provides metadata about the API.
108+-- The metadata can be used by the clients if needed,
109+-- and can be presented in the Swagger-UI for convenience.
110+data Info = Info
111+ { -- | The title of the application.
112+ _infoTitle :: Text
113+
114+ -- | A short description of the application.
115+ -- GFM syntax can be used for rich text representation.
116+ , _infoDescription :: Maybe Text
117+
118+ -- | The Terms of Service for the API.
119+ , _infoTermsOfService :: Maybe Text
120+
121+ -- | The contact information for the exposed API.
122+ , _infoContact :: Maybe Contact
123+
124+ -- | The license information for the exposed API.
125+ , _infoLicense :: Maybe License
126+
127+ -- | Provides the version of the application API
128+ -- (not to be confused with the specification version).
129+ , _infoVersion :: Text
130+ } deriving (Eq, Show, Generic, Data, Typeable)
131+
132+-- | Contact information for the exposed API.
133+data Contact = Contact
134+ { -- | The identifying name of the contact person/organization.
135+ _contactName :: Maybe Text
136+
137+ -- | The URL pointing to the contact information.
138+ , _contactUrl :: Maybe URL
139+
140+ -- | The email address of the contact person/organization.
141+ , _contactEmail :: Maybe Text
142+ } deriving (Eq, Show, Generic, Data, Typeable)
143+
144+-- | License information for the exposed API.
145+data License = License
146+ { -- | The license name used for the API.
147+ _licenseName :: Text
148+
149+ -- | A URL to the license used for the API.
150+ , _licenseUrl :: Maybe URL
151+ } deriving (Eq, Show, Generic, Data, Typeable)
152+
153+-- | The host (name or ip) serving the API. It MAY include a port.
154+data Host = Host
155+ { _hostName :: HostName -- ^ Host name.
156+ , _hostPort :: Maybe PortNumber -- ^ Optional port.
157+ } deriving (Eq, Show, Generic, Typeable)
158+
159+hostConstr :: Constr
160+hostConstr = mkConstr hostDataType "Host" [] Prefix
161+
162+hostDataType :: DataType
163+hostDataType = mkDataType "Data.Swagger.Host" [hostConstr]
164+
165+instance Data Host where
166+ gunfold k z c = case constrIndex c of
167+ 1 -> k (k (z (\name mport -> Host name (fromInteger <$> mport))))
168+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Host."
169+ toConstr (Host _ _) = hostConstr
170+ dataTypeOf _ = hostDataType
171+
172+-- | The transfer protocol of the API.
173+data Scheme
174+ = Http
175+ | Https
176+ | Ws
177+ | Wss
178+ deriving (Eq, Show, Generic, Data, Typeable)
179+
180+-- | Describes the operations available on a single path.
181+-- A @'PathItem'@ may be empty, due to ACL constraints.
182+-- The path itself is still exposed to the documentation viewer
183+-- but they will not know which operations and parameters are available.
184+data PathItem = PathItem
185+ { -- | A definition of a GET operation on this path.
186+ _pathItemGet :: Maybe Operation
187+
188+ -- | A definition of a PUT operation on this path.
189+ , _pathItemPut :: Maybe Operation
190+
191+ -- | A definition of a POST operation on this path.
192+ , _pathItemPost :: Maybe Operation
193+
194+ -- | A definition of a DELETE operation on this path.
195+ , _pathItemDelete :: Maybe Operation
196+
197+ -- | A definition of a OPTIONS operation on this path.
198+ , _pathItemOptions :: Maybe Operation
199+
200+ -- | A definition of a HEAD operation on this path.
201+ , _pathItemHead :: Maybe Operation
202+
203+ -- | A definition of a PATCH operation on this path.
204+ , _pathItemPatch :: Maybe Operation
205+
206+ -- | A list of parameters that are applicable for all the operations described under this path.
207+ -- These parameters can be overridden at the operation level, but cannot be removed there.
208+ -- The list MUST NOT include duplicated parameters.
209+ -- A unique parameter is defined by a combination of a name and location.
210+ , _pathItemParameters :: [Referenced Param]
211+ } deriving (Eq, Show, Generic, Data, Typeable)
212+
213+-- | Describes a single API operation on a path.
214+data Operation = Operation
215+ { -- | A list of tags for API documentation control.
216+ -- Tags can be used for logical grouping of operations by resources or any other qualifier.
217+ _operationTags :: [TagName]
218+
219+ -- | A short summary of what the operation does.
220+ -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
221+ , _operationSummary :: Maybe Text
222+
223+ -- | A verbose explanation of the operation behavior.
224+ -- GFM syntax can be used for rich text representation.
225+ , _operationDescription :: Maybe Text
226+
227+ -- | Additional external documentation for this operation.
228+ , _operationExternalDocs :: Maybe ExternalDocs
229+
230+ -- | Unique string used to identify the operation.
231+ -- The id MUST be unique among all operations described in the API.
232+ -- Tools and libraries MAY use the it to uniquely identify an operation,
233+ -- therefore, it is recommended to follow common programming naming conventions.
234+ , _operationOperationId :: Maybe Text
235+
236+ -- | A list of MIME types the operation can consume.
237+ -- This overrides the @'consumes'@.
238+ -- @Just []@ MAY be used to clear the global definition.
239+ , _operationConsumes :: Maybe MimeList
240+
241+ -- | A list of MIME types the operation can produce.
242+ -- This overrides the @'produces'@.
243+ -- @Just []@ MAY be used to clear the global definition.
244+ , _operationProduces :: Maybe MimeList
245+
246+ -- | A list of parameters that are applicable for this operation.
247+ -- If a parameter is already defined at the @'PathItem'@,
248+ -- the new definition will override it, but can never remove it.
249+ -- The list MUST NOT include duplicated parameters.
250+ -- A unique parameter is defined by a combination of a name and location.
251+ , _operationParameters :: [Referenced Param]
252+
253+ -- | The list of possible responses as they are returned from executing this operation.
254+ , _operationResponses :: Responses
255+
256+ -- | The transfer protocol for the operation.
257+ -- The value overrides @'schemes'@.
258+ , _operationSchemes :: Maybe [Scheme]
259+
260+ -- | Declares this operation to be deprecated.
261+ -- Usage of the declared operation should be refrained.
262+ -- Default value is @False@.
263+ , _operationDeprecated :: Maybe Bool
264+
265+ -- | A declaration of which security schemes are applied for this operation.
266+ -- The list of values describes alternative security schemes that can be used
267+ -- (that is, there is a logical OR between the security requirements).
268+ -- This definition overrides any declared top-level security.
269+ -- To remove a top-level security declaration, @Just []@ can be used.
270+ , _operationSecurity :: [SecurityRequirement]
271+ } deriving (Eq, Show, Generic, Data, Typeable)
272+
273+newtype MimeList = MimeList { getMimeList :: [MediaType] }
274+ deriving (Eq, Show, Monoid, Typeable)
275+
276+mimeListConstr :: Constr
277+mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
278+
279+mimeListDataType :: DataType
280+mimeListDataType = mkDataType "Data.Swagger.MimeList" [mimeListConstr]
281+
282+instance Data MimeList where
283+ gunfold k z c = case constrIndex c of
284+ 1 -> k (z (\xs -> MimeList (map fromString xs)))
285+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MimeList."
286+ toConstr (MimeList _) = mimeListConstr
287+ dataTypeOf _ = mimeListDataType
288+
289+-- | Describes a single operation parameter.
290+-- A unique parameter is defined by a combination of a name and location.
291+data Param = Param
292+ { -- | The name of the parameter.
293+ -- Parameter names are case sensitive.
294+ _paramName :: Text
295+
296+ -- | A brief description of the parameter.
297+ -- This could contain examples of use.
298+ -- GFM syntax can be used for rich text representation.
299+ , _paramDescription :: Maybe Text
300+
301+ -- | Determines whether this parameter is mandatory.
302+ -- If the parameter is in "path", this property is required and its value MUST be true.
303+ -- Otherwise, the property MAY be included and its default value is @False@.
304+ , _paramRequired :: Maybe Bool
305+
306+ -- | Parameter schema.
307+ , _paramSchema :: ParamAnySchema
308+ } deriving (Eq, Show, Generic, Data, Typeable)
309+
310+data ParamAnySchema
311+ = ParamBody (Referenced Schema)
312+ | ParamOther ParamOtherSchema
313+ deriving (Eq, Show, Generic, Data, Typeable)
314+
315+data ParamOtherSchema = ParamOtherSchema
316+ { -- | The location of the parameter.
317+ _paramOtherSchemaIn :: ParamLocation
318+
319+ -- | Sets the ability to pass empty-valued parameters.
320+ -- This is valid only for either @'ParamQuery'@ or @'ParamFormData'@
321+ -- and allows you to send a parameter with a name only or an empty value.
322+ -- Default value is @False@.
323+ , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
324+
325+ , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
326+ } deriving (Eq, Show, Generic, Data, Typeable)
327+
328+-- | Items for @'SwaggerArray'@ schemas.
329+--
330+-- @'SwaggerItemsPrimitive'@ should be used only for query params, headers and path pieces.
331+-- The @'CollectionFormat' t@ parameter specifies how elements of an array should be displayed.
332+-- Note that @fmt@ in @'SwaggerItemsPrimitive' fmt schema@ specifies format for elements of type @schema@.
333+-- This is different from the original Swagger's <http://swagger.io/specification/#itemsObject Items Object>.
334+--
335+-- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s.
336+--
337+-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
338+data SwaggerItems t where
339+ SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t
340+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema
341+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema
342+ deriving (Typeable)
343+
344+deriving instance Eq (SwaggerItems t)
345+deriving instance Show (SwaggerItems t)
346+--deriving instance Typeable (SwaggerItems t)
347+
348+swaggerItemsPrimitiveConstr :: Constr
349+swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
350+
351+swaggerItemsDataType :: DataType
352+swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
353+
354+instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where
355+ gunfold k z c = case constrIndex c of
356+ 1 -> k (k (z SwaggerItemsPrimitive))
357+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
358+ toConstr _ = swaggerItemsPrimitiveConstr
359+ dataTypeOf _ = swaggerItemsDataType
360+
361+deriving instance Data (SwaggerItems Schema)
362+
363+data SwaggerType t where
364+ SwaggerString :: SwaggerType t
365+ SwaggerNumber :: SwaggerType t
366+ SwaggerInteger :: SwaggerType t
367+ SwaggerBoolean :: SwaggerType t
368+ SwaggerArray :: SwaggerType t
369+ SwaggerFile :: SwaggerType ParamOtherSchema
370+ SwaggerNull :: SwaggerType Schema
371+ SwaggerObject :: SwaggerType Schema
372+ deriving (Typeable)
373+
374+deriving instance Eq (SwaggerType t)
375+deriving instance Show (SwaggerType t)
376+
377+swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
378+swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
379+
380+swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
381+swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
382+
383+swaggerCommonTypes :: [SwaggerType t]
384+swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
385+
386+swaggerParamTypes :: [SwaggerType ParamOtherSchema]
387+swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
388+
389+swaggerSchemaTypes :: [SwaggerType Schema]
390+swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
391+
392+swaggerTypeConstrs :: [Constr]
393+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])
394+ ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
395+
396+instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where
397+ gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
398+ toConstr = swaggerTypeConstr
399+ dataTypeOf = swaggerTypeDataType
400+
401+instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where
402+ gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
403+ toConstr = swaggerTypeConstr
404+ dataTypeOf = swaggerTypeDataType
405+
406+instance OVERLAPPABLE_ Data (SwaggerType Schema) where
407+ gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
408+ toConstr = swaggerTypeConstr
409+ dataTypeOf = swaggerTypeDataType
410+
411+data ParamLocation
412+ = -- | Parameters that are appended to the URL.
413+ -- For example, in @/items?id=###@, the query parameter is @id@.
414+ ParamQuery
415+ -- | Custom headers that are expected as part of the request.
416+ | ParamHeader
417+ -- | Used together with Path Templating, where the parameter value is actually part of the operation's URL.
418+ -- This does not include the host or base path of the API.
419+ -- For example, in @/items/{itemId}@, the path parameter is @itemId@.
420+ | ParamPath
421+ -- | Used to describe the payload of an HTTP request when either @application/x-www-form-urlencoded@
422+ -- or @multipart/form-data@ are used as the content type of the request
423+ -- (in Swagger's definition, the @consumes@ property of an operation).
424+ -- This is the only parameter type that can be used to send files, thus supporting the @'ParamFile'@ type.
425+ -- Since form parameters are sent in the payload, they cannot be declared together with a body parameter for the same operation.
426+ -- Form parameters have a different format based on the content-type used
427+ -- (for further details, consult <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).
428+ | ParamFormData
429+ deriving (Eq, Show, Generic, Data, Typeable)
430+
431+type Format = Text
432+
433+-- | Determines the format of the array.
434+data CollectionFormat t where
435+ -- Comma separated values: @foo,bar@.
436+ CollectionCSV :: CollectionFormat t
437+ -- Space separated values: @foo bar@.
438+ CollectionSSV :: CollectionFormat t
439+ -- Tab separated values: @foo\\tbar@.
440+ CollectionTSV :: CollectionFormat t
441+ -- Pipe separated values: @foo|bar@.
442+ CollectionPipes :: CollectionFormat t
443+ -- Corresponds to multiple parameter instances
444+ -- instead of multiple values for a single instance @foo=bar&foo=baz@.
445+ -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
446+ CollectionMulti :: CollectionFormat ParamOtherSchema
447+ deriving (Typeable)
448+
449+deriving instance Eq (CollectionFormat t)
450+deriving instance Show (CollectionFormat t)
451+
452+collectionFormatConstr :: CollectionFormat t -> Constr
453+collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix
454+
455+collectionFormatDataType :: DataType
456+collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
457+ map collectionFormatConstr collectionCommonFormats
458+
459+collectionCommonFormats :: [CollectionFormat t]
460+collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
461+
462+instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where
463+ gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
464+ toConstr = collectionFormatConstr
465+ dataTypeOf _ = collectionFormatDataType
466+
467+deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)
468+
469+type ParamName = Text
470+
471+data Schema = Schema
472+ { _schemaTitle :: Maybe Text
473+ , _schemaDescription :: Maybe Text
474+ , _schemaRequired :: [ParamName]
475+
476+ , _schemaAllOf :: Maybe [Schema]
477+ , _schemaProperties :: HashMap Text (Referenced Schema)
478+ , _schemaAdditionalProperties :: Maybe Schema
479+
480+ , _schemaDiscriminator :: Maybe Text
481+ , _schemaReadOnly :: Maybe Bool
482+ , _schemaXml :: Maybe Xml
483+ , _schemaExternalDocs :: Maybe ExternalDocs
484+ , _schemaExample :: Maybe Value
485+
486+ , _schemaMaxProperties :: Maybe Integer
487+ , _schemaMinProperties :: Maybe Integer
488+
489+ , _schemaParamSchema :: ParamSchema Schema
490+ } deriving (Eq, Show, Generic, Data, Typeable)
491+
492+-- | A @'Schema'@ with an optional name.
493+-- This name can be used in references.
494+data NamedSchema = NamedSchema
495+ { _namedSchemaName :: Maybe Text
496+ , _namedSchemaSchema :: Schema
497+ } deriving (Eq, Show, Generic, Data, Typeable)
498+
499+-- | Regex pattern for @string@ type.
500+type Pattern = Text
501+
502+data ParamSchema t = ParamSchema
503+ { -- | Declares the value of the parameter that the server will use if none is provided,
504+ -- for example a @"count"@ to control the number of results per page might default to @100@
505+ -- if not supplied by the client in the request.
506+ -- (Note: "default" has no meaning for required parameters.)
507+ -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
508+ _paramSchemaDefault :: Maybe Value
509+
510+ , _paramSchemaType :: SwaggerType t
511+ , _paramSchemaFormat :: Maybe Format
512+ , _paramSchemaItems :: Maybe (SwaggerItems t)
513+ , _paramSchemaMaximum :: Maybe Scientific
514+ , _paramSchemaExclusiveMaximum :: Maybe Bool
515+ , _paramSchemaMinimum :: Maybe Scientific
516+ , _paramSchemaExclusiveMinimum :: Maybe Bool
517+ , _paramSchemaMaxLength :: Maybe Integer
518+ , _paramSchemaMinLength :: Maybe Integer
519+ , _paramSchemaPattern :: Maybe Pattern
520+ , _paramSchemaMaxItems :: Maybe Integer
521+ , _paramSchemaMinItems :: Maybe Integer
522+ , _paramSchemaUniqueItems :: Maybe Bool
523+ , _paramSchemaEnum :: Maybe [Value]
524+ , _paramSchemaMultipleOf :: Maybe Scientific
525+ } deriving (Eq, Show, Generic, Typeable)
526+
527+deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)
528+
529+data Xml = Xml
530+ { -- | Replaces the name of the element/attribute used for the described schema property.
531+ -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list.
532+ -- When defined alongside type being array (outside the items),
533+ -- it will affect the wrapping element and only if wrapped is true.
534+ -- If wrapped is false, it will be ignored.
535+ _xmlName :: Maybe Text
536+
537+ -- | The URL of the namespace definition.
538+ -- Value SHOULD be in the form of a URL.
539+ , _xmlNamespace :: Maybe Text
540+
541+ -- | The prefix to be used for the name.
542+ , _xmlPrefix :: Maybe Text
543+
544+ -- | Declares whether the property definition translates to an attribute instead of an element.
545+ -- Default value is @False@.
546+ , _xmlAttribute :: Maybe Bool
547+
548+ -- | MAY be used only for an array definition.
549+ -- Signifies whether the array is wrapped
550+ -- (for example, @\<books\>\<book/\>\<book/\>\</books\>@)
551+ -- or unwrapped (@\<book/\>\<book/\>@).
552+ -- Default value is @False@.
553+ -- The definition takes effect only when defined alongside type being array (outside the items).
554+ , _xmlWrapped :: Maybe Bool
555+ } deriving (Eq, Show, Generic, Data, Typeable)
556+
557+-- | A container for the expected responses of an operation.
558+-- The container maps a HTTP response code to the expected response.
559+-- It is not expected from the documentation to necessarily cover all possible HTTP response codes,
560+-- since they may not be known in advance.
561+-- However, it is expected from the documentation to cover a successful operation response and any known errors.
562+data Responses = Responses
563+ { -- | The documentation of responses other than the ones declared for specific HTTP response codes.
564+ -- It can be used to cover undeclared responses.
565+ _responsesDefault :: Maybe (Referenced Response)
566+
567+ -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
568+ -- Describes the expected response for those HTTP status codes.
569+ , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
570+ } deriving (Eq, Show, Generic, Data, Typeable)
571+
572+type HttpStatusCode = Int
573+
574+-- | Describes a single response from an API Operation.
575+data Response = Response
576+ { -- | A short description of the response.
577+ -- GFM syntax can be used for rich text representation.
578+ _responseDescription :: Text
579+
580+ -- | A definition of the response structure.
581+ -- It can be a primitive, an array or an object.
582+ -- If this field does not exist, it means no content is returned as part of the response.
583+ -- As an extension to the Schema Object, its root type value may also be "file".
584+ -- This SHOULD be accompanied by a relevant produces mime-type.
585+ , _responseSchema :: Maybe (Referenced Schema)
586+
587+ -- | A list of headers that are sent with the response.
588+ , _responseHeaders :: HashMap HeaderName Header
589+
590+ -- | An example of the response message.
591+ , _responseExamples :: Maybe Example
592+ } deriving (Eq, Show, Generic, Data, Typeable)
593+
594+type HeaderName = Text
595+
596+data Header = Header
597+ { -- | A short description of the header.
598+ _headerDescription :: Maybe Text
599+
600+ , _headerParamSchema :: ParamSchema Header
601+ } deriving (Eq, Show, Generic, Data, Typeable)
602+
603+data Example = Example { getExample :: Map MediaType Value }
604+ deriving (Eq, Show, Generic, Typeable)
605+
606+exampleConstr :: Constr
607+exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix
608+
609+exampleDataType :: DataType
610+exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr]
611+
612+instance Data Example where
613+ gunfold k z c = case constrIndex c of
614+ 1 -> k (z (\m -> Example (Map.mapKeys fromString m)))
615+ _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Example."
616+ toConstr (Example _) = exampleConstr
617+ dataTypeOf _ = exampleDataType
618+
619+-- | The location of the API key.
620+data ApiKeyLocation
621+ = ApiKeyQuery
622+ | ApiKeyHeader
623+ deriving (Eq, Show, Generic, Data, Typeable)
624+
625+data ApiKeyParams = ApiKeyParams
626+ { -- | The name of the header or query parameter to be used.
627+ _apiKeyName :: Text
628+
629+ -- | The location of the API key.
630+ , _apiKeyIn :: ApiKeyLocation
631+ } deriving (Eq, Show, Generic, Data, Typeable)
632+
633+-- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
634+type AuthorizationURL = Text
635+
636+-- | The token URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
637+type TokenURL = Text
638+
639+data OAuth2Flow
640+ = OAuth2Implicit AuthorizationURL
641+ | OAuth2Password TokenURL
642+ | OAuth2Application TokenURL
643+ | OAuth2AccessCode AuthorizationURL TokenURL
644+ deriving (Eq, Show, Generic, Data, Typeable)
645+
646+data OAuth2Params = OAuth2Params
647+ { -- | The flow used by the OAuth2 security scheme.
648+ _oauth2Flow :: OAuth2Flow
649+
650+ -- | The available scopes for the OAuth2 security scheme.
651+ , _oauth2Scopes :: HashMap Text Text
652+ } deriving (Eq, Show, Generic, Data, Typeable)
653+
654+data SecuritySchemeType
655+ = SecuritySchemeBasic
656+ | SecuritySchemeApiKey ApiKeyParams
657+ | SecuritySchemeOAuth2 OAuth2Params
658+ deriving (Eq, Show, Generic, Data, Typeable)
659+
660+data SecurityScheme = SecurityScheme
661+ { -- | The type of the security scheme.
662+ _securitySchemeType :: SecuritySchemeType
663+
664+ -- | A short description for security scheme.
665+ , _securitySchemeDescription :: Maybe Text
666+ } deriving (Eq, Show, Generic, Data, Typeable)
667+
668+-- | Lists the required security schemes to execute this operation.
669+-- The object can have multiple security schemes declared in it which are all required
670+-- (that is, there is a logical AND between the schemes).
671+newtype SecurityRequirement = SecurityRequirement
672+ { getSecurityRequirement :: HashMap Text [Text]
673+ } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
674+
675+-- | Tag name.
676+type TagName = Text
677+
678+-- | Allows adding meta data to a single tag that is used by @Operation@.
679+-- It is not mandatory to have a @Tag@ per tag used there.
680+data Tag = Tag
681+ { -- | The name of the tag.
682+ _tagName :: TagName
683+
684+ -- | A short description for the tag.
685+ -- GFM syntax can be used for rich text representation.
686+ , _tagDescription :: Maybe Text
687+
688+ -- | Additional external documentation for this tag.
689+ , _tagExternalDocs :: Maybe ExternalDocs
690+ } deriving (Eq, Show, Generic, Data, Typeable)
691+
692+-- | Allows referencing an external resource for extended documentation.
693+data ExternalDocs = ExternalDocs
694+ { -- | A short description of the target documentation.
695+ -- GFM syntax can be used for rich text representation.
696+ _externalDocsDescription :: Maybe Text
697+
698+ -- | The URL for the target documentation.
699+ , _externalDocsUrl :: URL
700+ } deriving (Eq, Show, Generic, Data, Typeable)
701+
702+-- | A simple object to allow referencing other definitions in the specification.
703+-- It can be used to reference parameters and responses that are defined at the top level for reuse.
704+newtype Reference = Reference { getReference :: Text }
705+ deriving (Eq, Show, Data, Typeable)
706+
707+data Referenced a
708+ = Ref Reference
709+ | Inline a
710+ deriving (Eq, Show, Data, Typeable)
711+
712+newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON, Data, Typeable)
713+
714+-- =======================================================================
715+-- Monoid instances
716+-- =======================================================================
717+
718+instance Monoid Swagger where
719+ mempty = genericMempty
720+ mappend = genericMappend
721+
722+instance Monoid Info where
723+ mempty = genericMempty
724+ mappend = genericMappend
725+
726+instance Monoid Contact where
727+ mempty = genericMempty
728+ mappend = genericMappend
729+
730+instance Monoid PathItem where
731+ mempty = genericMempty
732+ mappend = genericMappend
733+
734+instance Monoid Schema where
735+ mempty = genericMempty
736+ mappend = genericMappend
737+
738+instance Monoid (ParamSchema t) where
739+ mempty = genericMempty
740+ mappend = genericMappend
741+
742+instance Monoid Param where
743+ mempty = genericMempty
744+ mappend = genericMappend
745+
746+instance Monoid ParamOtherSchema where
747+ mempty = genericMempty
748+ mappend = genericMappend
749+
750+instance Monoid Header where
751+ mempty = genericMempty
752+ mappend = genericMappend
753+
754+instance Monoid Responses where
755+ mempty = genericMempty
756+ mappend = genericMappend
757+
758+instance Monoid Response where
759+ mempty = genericMempty
760+ mappend = genericMappend
761+
762+instance Monoid ExternalDocs where
763+ mempty = genericMempty
764+ mappend = genericMappend
765+
766+instance Monoid Operation where
767+ mempty = genericMempty
768+ mappend = genericMappend
769+
770+instance Monoid Example where
771+ mempty = genericMempty
772+ mappend = genericMappend
773+
774+-- =======================================================================
775+-- SwaggerMonoid helper instances
776+-- =======================================================================
777+
778+instance SwaggerMonoid Info
779+instance SwaggerMonoid PathItem
780+instance SwaggerMonoid Schema
781+instance SwaggerMonoid (ParamSchema t)
782+instance SwaggerMonoid Param
783+instance SwaggerMonoid ParamOtherSchema
784+instance SwaggerMonoid Responses
785+instance SwaggerMonoid Response
786+instance SwaggerMonoid ExternalDocs
787+instance SwaggerMonoid Operation
788+
789+instance SwaggerMonoid MimeList
790+deriving instance SwaggerMonoid URL
791+
792+instance SwaggerMonoid (SwaggerType t) where
793+ swaggerMempty = SwaggerString
794+ swaggerMappend _ y = y
795+
796+instance SwaggerMonoid ParamLocation where
797+ swaggerMempty = ParamQuery
798+ swaggerMappend _ y = y
799+
800+instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where
801+ swaggerMempty = HashMap.empty
802+ swaggerMappend = HashMap.unionWith mappend
803+
804+instance Monoid a => SwaggerMonoid (Referenced a) where
805+ swaggerMempty = Inline mempty
806+ swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
807+ swaggerMappend _ y = y
808+
809+instance SwaggerMonoid ParamAnySchema where
810+ swaggerMempty = ParamOther swaggerMempty
811+ swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y)
812+ swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y)
813+ swaggerMappend _ y = y
814+
815+-- =======================================================================
816+-- Simple Generic-based ToJSON instances
817+-- =======================================================================
818+
819+instance ToJSON ParamLocation where
820+ toJSON = genericToJSON (jsonPrefix "Param")
821+
822+instance ToJSON Info where
823+ toJSON = genericToJSON (jsonPrefix "Info")
824+
825+instance ToJSON Contact where
826+ toJSON = genericToJSON (jsonPrefix "Contact")
827+
828+instance ToJSON License where
829+ toJSON = genericToJSON (jsonPrefix "License")
830+
831+instance ToJSON ApiKeyLocation where
832+ toJSON = genericToJSON (jsonPrefix "ApiKey")
833+
834+instance ToJSON ApiKeyParams where
835+ toJSON = genericToJSON (jsonPrefix "apiKey")
836+
837+instance ToJSON Scheme where
838+ toJSON = genericToJSON (jsonPrefix "")
839+
840+instance ToJSON Tag where
841+ toJSON = genericToJSON (jsonPrefix "Tag")
842+
843+instance ToJSON ExternalDocs where
844+ toJSON = genericToJSON (jsonPrefix "ExternalDocs")
845+
846+instance ToJSON Xml where
847+ toJSON = genericToJSON (jsonPrefix "Xml")
848+
849+-- =======================================================================
850+-- Simple Generic-based FromJSON instances
851+-- =======================================================================
852+
853+instance FromJSON ParamLocation where
854+ parseJSON = genericParseJSON (jsonPrefix "Param")
855+
856+instance FromJSON Info where
857+ parseJSON = genericParseJSON (jsonPrefix "Info")
858+
859+instance FromJSON Contact where
860+ parseJSON = genericParseJSON (jsonPrefix "Contact")
861+
862+instance FromJSON License where
863+ parseJSON = genericParseJSON (jsonPrefix "License")
864+
865+instance FromJSON ApiKeyLocation where
866+ parseJSON = genericParseJSON (jsonPrefix "ApiKey")
867+
868+instance FromJSON ApiKeyParams where
869+ parseJSON = genericParseJSON (jsonPrefix "apiKey")
870+
871+instance FromJSON Scheme where
872+ parseJSON = genericParseJSON (jsonPrefix "")
873+
874+instance FromJSON Tag where
875+ parseJSON = genericParseJSON (jsonPrefix "Tag")
876+
877+instance FromJSON ExternalDocs where
878+ parseJSON = genericParseJSON (jsonPrefix "ExternalDocs")
879+
880+-- =======================================================================
881+-- Manual ToJSON instances
882+-- =======================================================================
883+
884+instance ToJSON OAuth2Flow where
885+ toJSON (OAuth2Implicit authUrl) = object
886+ [ "flow" .= ("implicit" :: Text)
887+ , "authorizationUrl" .= authUrl ]
888+ toJSON (OAuth2Password tokenUrl) = object
889+ [ "flow" .= ("password" :: Text)
890+ , "tokenUrl" .= tokenUrl ]
891+ toJSON (OAuth2Application tokenUrl) = object
892+ [ "flow" .= ("application" :: Text)
893+ , "tokenUrl" .= tokenUrl ]
894+ toJSON (OAuth2AccessCode authUrl tokenUrl) = object
895+ [ "flow" .= ("accessCode" :: Text)
896+ , "authorizationUrl" .= authUrl
897+ , "tokenUrl" .= tokenUrl ]
898+
899+instance ToJSON OAuth2Params where
900+ toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")
901+
902+instance ToJSON SecuritySchemeType where
903+ toJSON SecuritySchemeBasic
904+ = object [ "type" .= ("basic" :: Text) ]
905+ toJSON (SecuritySchemeApiKey params)
906+ = toJSON params
907+ <+> object [ "type" .= ("apiKey" :: Text) ]
908+ toJSON (SecuritySchemeOAuth2 params)
909+ = toJSON params
910+ <+> object [ "type" .= ("oauth2" :: Text) ]
911+
912+instance ToJSON Swagger where
913+ toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")
914+ where
915+ addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
916+ addVersion _ = error "impossible"
917+
918+instance ToJSON SecurityScheme where
919+ toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
920+
921+instance ToJSON Schema where
922+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
923+ where
924+ f "items" (Array _) = True
925+ f _ _ = False
926+
927+instance ToJSON Header where
928+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
929+
930+instance ToJSON (SwaggerItems t) where
931+ toJSON (SwaggerItemsPrimitive fmt schema) = object
932+ [ "collectionFormat" .= fmt
933+ , "items" .= schema ]
934+ toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
935+ toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
936+
937+instance ToJSON Host where
938+ toJSON (Host host mport) = toJSON $
939+ case mport of
940+ Nothing -> host
941+ Just port -> host ++ ":" ++ show port
942+
943+instance ToJSON MimeList where
944+ toJSON (MimeList xs) = toJSON (map show xs)
945+
946+instance ToJSON Param where
947+ toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
948+
949+instance ToJSON ParamAnySchema where
950+ toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
951+ toJSON (ParamOther s) = toJSON s
952+
953+instance ToJSON ParamOtherSchema where
954+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
955+
956+instance ToJSON Responses where
957+ toJSON (Responses def rs) = omitEmpties $
958+ toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
959+
960+instance ToJSON Response where
961+ toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
962+
963+instance ToJSON Operation where
964+ toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")
965+
966+instance ToJSON PathItem where
967+ toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")
968+
969+instance ToJSON Example where
970+ toJSON = toJSON . Map.mapKeys show . getExample
971+
972+instance ToJSON Reference where
973+ toJSON (Reference ref) = object [ "$ref" .= ref ]
974+
975+referencedToJSON :: ToJSON a => Text -> Referenced a -> Value
976+referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ]
977+referencedToJSON _ (Inline x) = toJSON x
978+
979+instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/definitions/"
980+instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/parameters/"
981+instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/responses/"
982+
983+instance ToJSON (SwaggerType t) where
984+ toJSON SwaggerArray = "array"
985+ toJSON SwaggerString = "string"
986+ toJSON SwaggerInteger = "integer"
987+ toJSON SwaggerNumber = "number"
988+ toJSON SwaggerBoolean = "boolean"
989+ toJSON SwaggerFile = "file"
990+ toJSON SwaggerNull = "null"
991+ toJSON SwaggerObject = "object"
992+
993+instance ToJSON (CollectionFormat t) where
994+ toJSON CollectionCSV = "csv"
995+ toJSON CollectionSSV = "ssv"
996+ toJSON CollectionTSV = "tsv"
997+ toJSON CollectionPipes = "pipes"
998+ toJSON CollectionMulti = "multi"
999+
1000+instance ToJSON (ParamSchema t) where
1001+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
1002+ where
1003+ f "items" (Array _) = True
1004+ f _ _ = False
1005+
1006+-- =======================================================================
1007+-- Manual FromJSON instances
1008+-- =======================================================================
1009+
1010+instance FromJSON OAuth2Flow where
1011+ parseJSON (Object o) = do
1012+ (flow :: Text) <- o .: "flow"
1013+ case flow of
1014+ "implicit" -> OAuth2Implicit <$> o .: "authorizationUrl"
1015+ "password" -> OAuth2Password <$> o .: "tokenUrl"
1016+ "application" -> OAuth2Application <$> o .: "tokenUrl"
1017+ "accessCode" -> OAuth2AccessCode
1018+ <$> o .: "authorizationUrl"
1019+ <*> o .: "tokenUrl"
1020+ _ -> empty
1021+ parseJSON _ = empty
1022+
1023+instance FromJSON OAuth2Params where
1024+ parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
1025+
1026+instance FromJSON SecuritySchemeType where
1027+ parseJSON js@(Object o) = do
1028+ (t :: Text) <- o .: "type"
1029+ case t of
1030+ "basic" -> pure SecuritySchemeBasic
1031+ "apiKey" -> SecuritySchemeApiKey <$> parseJSON js
1032+ "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js
1033+ _ -> empty
1034+ parseJSON _ = empty
1035+
1036+instance FromJSON Swagger where
1037+ parseJSON js@(Object o) = do
1038+ (version :: Text) <- o .: "swagger"
1039+ when (version /= "2.0") empty
1040+ (genericParseJSON (jsonPrefix "swagger")
1041+ `withDefaults` [ "consumes" .= (mempty :: MimeList)
1042+ , "produces" .= (mempty :: MimeList)
1043+ , "security" .= ([] :: [SecurityRequirement])
1044+ , "tags" .= ([] :: [Tag])
1045+ , "definitions" .= (mempty :: Definitions Schema)
1046+ , "parameters" .= (mempty :: Definitions Param)
1047+ , "responses" .= (mempty :: Definitions Response)
1048+ , "securityDefinitions" .= (mempty :: Definitions SecurityScheme)
1049+ ] ) js
1050+ parseJSON _ = empty
1051+
1052+instance FromJSON SecurityScheme where
1053+ parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
1054+
1055+instance FromJSON Schema where
1056+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
1057+ `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
1058+ , "required" .= ([] :: [ParamName]) ]
1059+
1060+instance FromJSON Header where
1061+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
1062+
1063+instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where
1064+ parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1065+ <$> o .:? "collectionFormat"
1066+ <*> (o .: "items" >>= parseJSON)
1067+
1068+instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where
1069+ parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
1070+ parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1071+ parseJSON _ = empty
1072+
1073+instance FromJSON Host where
1074+ parseJSON (String s) =
1075+ case fromInteger <$> readMaybe portStr of
1076+ Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'"
1077+ mport -> pure $ Host host mport
1078+ where
1079+ (hostText, portText) = Text.breakOn ":" s
1080+ [host, portStr] = map Text.unpack [hostText, portText]
1081+ parseJSON _ = empty
1082+
1083+instance FromJSON MimeList where
1084+ parseJSON js = (MimeList . map fromString) <$> parseJSON js
1085+
1086+instance FromJSON Param where
1087+ parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
1088+
1089+instance FromJSON ParamAnySchema where
1090+ parseJSON js@(Object o) = do
1091+ (i :: Text) <- o .: "in"
1092+ case i of
1093+ "body" -> do
1094+ schema <- o .: "schema"
1095+ ParamBody <$> parseJSON schema
1096+ _ -> ParamOther <$> parseJSON js
1097+ parseJSON _ = empty
1098+
1099+instance FromJSON ParamOtherSchema where
1100+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1101+
1102+instance FromJSON Responses where
1103+ parseJSON (Object o) = Responses
1104+ <$> o .:? "default"
1105+ <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
1106+ parseJSON _ = empty
1107+
1108+instance FromJSON Example where
1109+ parseJSON js = do
1110+ m <- parseJSON js
1111+ pure $ Example (Map.mapKeys fromString m)
1112+
1113+instance FromJSON Response where
1114+ parseJSON = genericParseJSON (jsonPrefix "response")
1115+ `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
1116+
1117+instance FromJSON Operation where
1118+ parseJSON = genericParseJSON (jsonPrefix "operation")
1119+ `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) ]
1120+
1121+instance FromJSON PathItem where
1122+ parseJSON = genericParseJSON (jsonPrefix "pathItem")
1123+ `withDefaults` [ "parameters" .= ([] :: [Param]) ]
1124+
1125+instance FromJSON Reference where
1126+ parseJSON (Object o) = Reference <$> o .: "$ref"
1127+ parseJSON _ = empty
1128+
1129+referencedParseJSON :: FromJSON a => Text -> Value -> JSON.Parser (Referenced a)
1130+referencedParseJSON prefix js@(Object o) = do
1131+ ms <- o .:? "$ref"
1132+ case ms of
1133+ Nothing -> Inline <$> parseJSON js
1134+ Just s -> Ref <$> parseRef s
1135+ where
1136+ parseRef s = do
1137+ case Text.stripPrefix prefix s of
1138+ Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s
1139+ Just suffix -> pure (Reference suffix)
1140+referencedParseJSON _ _ = fail "referenceParseJSON: not an object"
1141+
1142+instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/definitions/"
1143+instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/parameters/"
1144+instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/responses/"
1145+
1146+instance FromJSON Xml where
1147+ parseJSON = genericParseJSON (jsonPrefix "xml")
1148+
1149+instance FromJSON (SwaggerType Schema) where
1150+ parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1151+
1152+instance FromJSON (SwaggerType ParamOtherSchema) where
1153+ parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1154+
1155+instance OVERLAPPABLE_ FromJSON (SwaggerType t) where
1156+ parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1157+
1158+instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where
1159+ parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1160+
1161+instance FromJSON (CollectionFormat ParamOtherSchema) where
1162+ parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1163+
1164+-- NOTE: The constraints @FromJSON (SwaggerType t)@ and
1165+-- @FromJSON (SwaggerItems t)@ are necessary here!
1166+-- Without the constraint the general instance will be used
1167+-- that only accepts common types (i.e. NOT object, null or file)
1168+-- and primitive array items.
1169+instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
1170+ parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
1171+
src/Data/OpenApi/Internal/ParamSchema.hs → src/Data/Swagger/Internal/ParamSchema.hsrenamed+48−162
@@ -1,4 +1,4 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE CPP #-}
22{-# LANGUAGE DefaultSignatures #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
@@ -7,18 +7,13 @@
77{-# LANGUAGE PackageImports #-}
88{-# LANGUAGE PolyKinds #-}
99{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeFamilies #-}
1110{-# LANGUAGE TypeOperators #-}
1211{-# 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
12+#include "overlapping-compat.h"
13+module Data.Swagger.Internal.ParamSchema where
1914
2015import Control.Lens
21−import Data.Aeson (ToJSON (..))
16+import Data.Aeson
2217import Data.Proxy
2318import GHC.Generics
2419
@@ -27,54 +22,16 @@ import "unordered-containers" Data.HashSet (HashSet)
2722import Data.Monoid
2823import Data.Set (Set)
2924import Data.Scientific
30−import Data.Fixed (HasResolution(..), Fixed, Pico)
3125import qualified Data.Text as T
3226import qualified Data.Text.Lazy as TL
3327import 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)
4028import Data.Word
41−import Data.UUID.Types (UUID)
42−import Web.Cookie (SetCookie)
43−
44−import Data.OpenApi.Internal
45−import Data.OpenApi.Lens
46−import Data.OpenApi.SchemaOptions
47−
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'@.
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.
29+
30+import Data.Swagger.Internal
31+import Data.Swagger.Lens
32+import Data.Swagger.SchemaOptions
33+
34+-- | Convert a type into a plain @'ParamSchema'@.
7835--
7936-- An example type and instance:
8037--
@@ -86,9 +43,9 @@ passwordSchema = mempty
8643-- data Direction = Up | Down
8744--
8845-- instance ToParamSchema Direction where
89−-- toParamSchema _ = mempty
90−-- & type_ ?~ OpenApiString
91−-- & enum_ ?~ [ \"Up\", \"Down\" ]
46+-- toParamSchema = mempty
47+-- & type_ .~ SwaggerString
48+-- & enum_ .~ [ \"Up\", \"Down\" ]
9249-- @
9350--
9451-- Instead of manually writing your @'ToParamSchema'@ instance you can
@@ -112,28 +69,20 @@ passwordSchema = mempty
11269class ToParamSchema a where
11370 -- | Convert a type into a plain parameter schema.
11471 --
115− -- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy Integer)
116− -- {
117− -- "type": "integer"
118− -- }
119− toParamSchema :: Proxy a -> Schema
120− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> Schema
72+ -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
73+ -- "{\"type\":\"integer\"}"
74+ toParamSchema :: proxy a -> ParamSchema t
75+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t
12176 toParamSchema = genericToParamSchema defaultSchemaOptions
12277
123−instance {-# OVERLAPPING #-} ToParamSchema String where
124− toParamSchema _ = mempty & type_ ?~ OpenApiString
78+instance OVERLAPPING_ ToParamSchema String where
79+ toParamSchema _ = mempty & type_ .~ SwaggerString
12580
12681instance ToParamSchema Bool where
127− toParamSchema _ = mempty & type_ ?~ OpenApiBoolean
82+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean
12883
12984instance ToParamSchema Integer where
130− toParamSchema _ = mempty & type_ ?~ OpenApiInteger
131−
132−instance ToParamSchema Natural where
133− toParamSchema _ = mempty
134− & type_ ?~ OpenApiInteger
135− & minimum_ ?~ 0
136− & exclusiveMinimum ?~ False
85+ toParamSchema _ = mempty & type_ .~ SwaggerInteger
13786
13887instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
13988instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
@@ -148,66 +97,47 @@ instance ToParamSchema Int64 where
14897instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral
14998instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral
15099instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral
151−
152−instance ToParamSchema Word32 where
153− toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int32"
154−
155−instance ToParamSchema Word64 where
156− toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64"
100+instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral
101+instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
157102
158103-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
159104--
160−-- >>> BSL.putStrLn $ encodePretty $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
161−-- {
162−-- "maximum": 127,
163−-- "minimum": -128,
164−-- "type": "integer"
165−-- }
166−toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema
105+-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
106+-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
107+toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t
167108toParamSchemaBoundedIntegral _ = mempty
168− & type_ ?~ OpenApiInteger
109+ & type_ .~ SwaggerInteger
169110 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
170111 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
171112
172113instance ToParamSchema Char where
173114 toParamSchema _ = mempty
174− & type_ ?~ OpenApiString
115+ & type_ .~ SwaggerString
175116 & maxLength ?~ 1
176117 & minLength ?~ 1
177118
178119instance ToParamSchema Scientific where
179− toParamSchema _ = mempty & type_ ?~ OpenApiNumber
180−
181−instance HasResolution a => ToParamSchema (Fixed a) where
182− toParamSchema _ = mempty
183− & type_ ?~ OpenApiNumber
184− & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
120+ toParamSchema _ = mempty & type_ .~ SwaggerNumber
185121
186122instance ToParamSchema Double where
187123 toParamSchema _ = mempty
188− & type_ ?~ OpenApiNumber
124+ & type_ .~ SwaggerNumber
189125 & format ?~ "double"
190126
191127instance ToParamSchema Float where
192128 toParamSchema _ = mempty
193− & type_ ?~ OpenApiNumber
129+ & type_ .~ SwaggerNumber
194130 & format ?~ "float"
195131
196−timeParamSchema :: String -> Schema
132+timeParamSchema :: String -> ParamSchema t
197133timeParamSchema fmt = mempty
198− & type_ ?~ OpenApiString
134+ & type_ .~ SwaggerString
199135 & format ?~ T.pack fmt
200136
201137-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
202138instance ToParamSchema Day where
203139 toParamSchema _ = timeParamSchema "date"
204140
205−-- |
206−-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
207−-- Just "hh:MM:ss"
208−instance ToParamSchema TimeOfDay where
209− toParamSchema _ = timeParamSchema "hh:MM:ss"
210−
211141-- |
212142-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
213143-- Just "yyyy-mm-ddThh:MM:ss"
@@ -216,9 +146,9 @@ instance ToParamSchema LocalTime where
216146
217147-- |
218148-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format
219−-- Just "date-time"
149+-- Just "yyyy-mm-ddThh:MM:ss+hhMM"
220150instance ToParamSchema ZonedTime where
221− toParamSchema _ = timeParamSchema "date-time"
151+ toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"
222152
223153-- |
224154-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format
@@ -227,7 +157,7 @@ instance ToParamSchema UTCTime where
227157 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
228158
229159instance ToParamSchema NominalDiffTime where
230− toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
160+ toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)
231161
232162instance ToParamSchema T.Text where
233163 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
@@ -235,24 +165,6 @@ instance ToParamSchema T.Text where
235165instance ToParamSchema TL.Text where
236166 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
237167
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−
256168instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
257169instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
258170instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
@@ -261,17 +173,10 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to
261173instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
262174instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
263175
264−instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
265−
266176instance ToParamSchema a => ToParamSchema [a] where
267177 toParamSchema _ = mempty
268− & type_ ?~ OpenApiArray
269− & items ?~ OpenApiItemsObject (Inline $ 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])
178+ & type_ .~ SwaggerArray
179+ & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
275180
276181instance ToParamSchema a => ToParamSchema (Set a) where
277182 toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
@@ -281,40 +186,24 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
281186 toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a))
282187
283188-- |
284−-- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy ())
285−-- {
286−-- "enum": [
287−-- "_"
288−-- ],
289−-- "type": "string"
290−-- }
189+-- >>> encode $ toParamSchema (Proxy :: Proxy ())
190+-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
291191instance ToParamSchema () where
292192 toParamSchema _ = mempty
293− & type_ ?~ OpenApiString
193+ & type_ .~ SwaggerString
294194 & enum_ ?~ ["_"]
295195
296−instance ToParamSchema UUID where
297− toParamSchema _ = mempty
298− & type_ ?~ OpenApiString
299− & format ?~ "uuid"
300−
301−-- | A configurable generic @'Schema'@ creator.
196+-- | A configurable generic @'ParamSchema'@ creator.
302197--
303198-- >>> :set -XDeriveGeneric
304199-- >>> data Color = Red | Blue deriving Generic
305−-- >>> BSL.putStrLn $ encodePretty $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
306−-- {
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+-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
201+-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
202+genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t
314203genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
315204
316205class GToParamSchema (f :: * -> *) where
317− gtoParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema
206+ gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
318207
319208instance GToParamSchema f => GToParamSchema (D1 d f) where
320209 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
@@ -332,14 +221,14 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
332221 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
333222
334223class GEnumParamSchema (f :: * -> *) where
335− genumParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema
224+ genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
336225
337226instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
338227 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
339228
340229instance Constructor c => GEnumParamSchema (C1 c U1) where
341230 genumParamSchema opts _ s = s
342− & type_ ?~ OpenApiString
231+ & type_ .~ SwaggerString
343232 & enum_ %~ addEnumValue tag
344233 where
345234 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
@@ -349,6 +238,3 @@ instance Constructor c => GEnumParamSchema (C1 c U1) where
349238
350239data Proxy3 a b c = Proxy3
351240
352−-- $setup
353−-- >>> import Data.Aeson (encode)
354−-- >>> import Data.OpenApi.Internal.Utils
src/Data/Swagger/Internal/Schema.hsnew file+577
@@ -0,0 +1,577 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE OverloadedLists #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PackageImports #-}
9+{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TupleSections #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE TypeSynonymInstances #-}
15+#include "overlapping-compat.h"
16+module Data.Swagger.Internal.Schema where
17+
18+import Prelude ()
19+import Prelude.Compat
20+
21+import Control.Lens
22+import Data.Data.Lens (template)
23+
24+import Control.Monad
25+import Control.Monad.Writer
26+import Data.Aeson
27+import Data.Char
28+import Data.Data (Data)
29+import Data.Foldable (traverse_)
30+import Data.HashMap.Strict (HashMap)
31+import qualified Data.HashMap.Strict as HashMap
32+import "unordered-containers" Data.HashSet (HashSet)
33+import Data.Int
34+import Data.IntSet (IntSet)
35+import Data.IntMap (IntMap)
36+import Data.Map (Map)
37+import Data.Proxy
38+import Data.Scientific (Scientific)
39+import Data.Set (Set)
40+import qualified Data.Text as T
41+import qualified Data.Text.Lazy as TL
42+import Data.Time
43+import Data.Word
44+import GHC.Generics
45+
46+import Data.Swagger.Declare
47+import Data.Swagger.Internal
48+import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
49+import Data.Swagger.Lens hiding (name, schema)
50+import Data.Swagger.SchemaOptions
51+
52+#ifdef __DOCTEST__
53+import Data.Swagger.Lens (name, schema)
54+#endif
55+
56+unnamed :: Schema -> NamedSchema
57+unnamed schema = NamedSchema Nothing schema
58+
59+named :: T.Text -> Schema -> NamedSchema
60+named name schema = NamedSchema (Just name) schema
61+
62+plain :: Schema -> Declare (Definitions Schema) NamedSchema
63+plain = pure . unnamed
64+
65+unname :: NamedSchema -> NamedSchema
66+unname (NamedSchema _ schema) = unnamed schema
67+
68+rename :: Maybe T.Text -> NamedSchema -> NamedSchema
69+rename name (NamedSchema _ schema) = NamedSchema name schema
70+
71+-- | Convert a type into @'Schema'@.
72+--
73+-- An example type and instance:
74+--
75+-- @
76+-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
77+-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
78+--
79+-- import Control.Lens
80+--
81+-- data Coord = Coord { x :: Double, y :: Double }
82+--
83+-- instance ToSchema Coord where
84+-- declareNamedSchema = pure (Just \"Coord\", schema)
85+-- where
86+-- schema = mempty
87+-- & type_ .~ SwaggerObject
88+-- & properties .~
89+-- [ (\"x\", toSchemaRef (Proxy :: Proxy Double))
90+-- , (\"y\", toSchemaRef (Proxy :: Proxy Double))
91+-- ]
92+-- & required .~ [ \"x\", \"y\" ]
93+-- @
94+--
95+-- Instead of manually writing your @'ToSchema'@ instance you can
96+-- use a default generic implementation of @'declareNamedSchema'@.
97+--
98+-- To do that, simply add @deriving 'Generic'@ clause to your datatype
99+-- and declare a @'ToSchema'@ instance for your datatype without
100+-- giving definition for @'declareNamedSchema'@.
101+--
102+-- For instance, the previous example can be simplified into this:
103+--
104+-- @
105+-- {-\# LANGUAGE DeriveGeneric \#-}
106+--
107+-- import GHC.Generics (Generic)
108+--
109+-- data Coord = Coord { x :: Double, y :: Double } deriving Generic
110+--
111+-- instance ToSchema Coord
112+-- @
113+class ToSchema a where
114+ -- | Convert a type into an optionally named schema
115+ -- together with all used definitions.
116+ -- Note that the schema itself is included in definitions
117+ -- only if it is recursive (and thus needs its definition in scope).
118+ declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
119+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
120+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
121+
122+-- | Convert a type into a schema and declare all used schema definitions.
123+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
124+declareSchema = fmap _namedSchemaSchema . declareNamedSchema
125+
126+-- | Convert a type into an optionally named schema.
127+--
128+-- >>> toNamedSchema (Proxy :: Proxy String) ^. name
129+-- Nothing
130+-- >>> encode (toNamedSchema (Proxy :: Proxy String) ^. schema)
131+-- "{\"type\":\"string\"}"
132+--
133+-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
134+-- Just "Day"
135+-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
136+-- "{\"format\":\"date\",\"type\":\"string\"}"
137+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
138+toNamedSchema = undeclare . declareNamedSchema
139+
140+-- | Get type's schema name according to its @'ToSchema'@ instance.
141+--
142+-- >>> schemaName (Proxy :: Proxy Int)
143+-- Nothing
144+--
145+-- >>> schemaName (Proxy :: Proxy UTCTime)
146+-- Just "UTCTime"
147+schemaName :: ToSchema a => proxy a -> Maybe T.Text
148+schemaName = _namedSchemaName . toNamedSchema
149+
150+-- | Convert a type into a schema.
151+--
152+-- >>> encode $ toSchema (Proxy :: Proxy Int8)
153+-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
154+--
155+-- >>> encode $ toSchema (Proxy :: Proxy [Day])
156+-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
157+toSchema :: ToSchema a => proxy a -> Schema
158+toSchema = _namedSchemaSchema . toNamedSchema
159+
160+-- | Convert a type into a referenced schema if possible.
161+-- Only named schemas can be referenced, nameless schemas are inlined.
162+--
163+-- >>> encode $ toSchemaRef (Proxy :: Proxy Integer)
164+-- "{\"type\":\"integer\"}"
165+--
166+-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
167+-- "{\"$ref\":\"#/definitions/Day\"}"
168+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
169+toSchemaRef = undeclare . declareSchemaRef
170+
171+-- | Convert a type into a referenced schema if possible
172+-- and declare all used schema definitions.
173+-- Only named schemas can be referenced, nameless schemas are inlined.
174+--
175+-- Schema definitions are typically declared for every referenced schema.
176+-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
177+-- will be declared (regardless of whether it is recusive or not).
178+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
179+declareSchemaRef proxy = do
180+ case toNamedSchema proxy of
181+ NamedSchema (Just name) schema -> do
182+ -- This check is very important as it allows generically
183+ -- derive used definitions for recursive schemas.
184+ -- Lazy Declare monad allows toNamedSchema to ignore
185+ -- any declarations (which would otherwise loop) and
186+ -- retrieve the schema and its name to check if we
187+ -- have already declared it.
188+ -- If we have, we don't need to declare anything for
189+ -- this schema this time and thus simply return the reference.
190+ known <- looks (HashMap.member name)
191+ when (not known) $ do
192+ declare [(name, schema)]
193+ void $ declareNamedSchema proxy
194+ return $ Ref (Reference name)
195+ _ -> Inline <$> declareSchema proxy
196+
197+-- | Inline any referenced schema if its name satisfies given predicate.
198+--
199+-- /NOTE:/ if a referenced schema is not found in definitions the predicate is ignored
200+-- and schema stays referenced.
201+--
202+-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas
203+-- when inlining recursive schemas.
204+inlineSchemasWhen :: Data s => (T.Text -> Bool) -> (Definitions Schema) -> s -> s
205+inlineSchemasWhen p defs = template %~ deref
206+ where
207+ deref r@(Ref (Reference name))
208+ | p name =
209+ case HashMap.lookup name defs of
210+ Just schema -> Inline (inlineSchemasWhen p defs schema)
211+ Nothing -> r
212+ | otherwise = r
213+ deref (Inline schema) = Inline (inlineSchemasWhen p defs schema)
214+
215+-- | Inline any referenced schema if its name is in the given list.
216+--
217+-- /NOTE:/ if a referenced schema is not found in definitions
218+-- it stays referenced even if it appears in the list of names.
219+--
220+-- __WARNING:__ @'inlineSchemas'@ will produce infinite schemas
221+-- when inlining recursive schemas.
222+inlineSchemas :: Data s => [T.Text] -> (Definitions Schema) -> s -> s
223+inlineSchemas names = inlineSchemasWhen (`elem` names)
224+
225+-- | Inline all schema references for which the definition
226+-- can be found in @'Definitions'@.
227+--
228+-- __WARNING:__ @'inlineAllSchemas'@ will produce infinite schemas
229+-- when inlining recursive schemas.
230+inlineAllSchemas :: Data s => (Definitions Schema) -> s -> s
231+inlineAllSchemas = inlineSchemasWhen (const True)
232+
233+-- | Convert a type into a schema without references.
234+--
235+-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
236+-- "{\"items\":{\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
237+--
238+-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
239+-- when inlining recursive schemas.
240+toInlinedSchema :: ToSchema a => proxy a -> Schema
241+toInlinedSchema proxy = inlineAllSchemas defs schema
242+ where
243+ (defs, schema) = runDeclare (declareSchema proxy) mempty
244+
245+-- | Inline all /non-recursive/ schemas for which the definition
246+-- can be found in @'Definitions'@.
247+inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
248+inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
249+ where
250+ nonRecursive name =
251+ case HashMap.lookup name defs of
252+ Just schema -> name `notElem` execDeclare (usedNames schema) mempty
253+ Nothing -> False
254+
255+ usedNames schema = traverse_ schemaRefNames (schema ^.. template)
256+
257+ schemaRefNames :: Referenced Schema -> Declare [T.Text] ()
258+ schemaRefNames ref = case ref of
259+ Ref (Reference name) -> do
260+ seen <- looks (name `elem`)
261+ when (not seen) $ do
262+ declare [name]
263+ traverse_ usedNames (HashMap.lookup name defs)
264+ Inline subschema -> usedNames subschema
265+
266+class GToSchema (f :: * -> *) where
267+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
268+
269+instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
270+ declareNamedSchema _ = do
271+ ref <- declareSchemaRef (Proxy :: Proxy a)
272+ return $ unnamed $ mempty
273+ & type_ .~ SwaggerArray
274+ & items ?~ SwaggerItemsObject ref
275+
276+instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
277+instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
278+instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
279+instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
280+instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
281+instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
282+instance ToSchema Int32 where declareNamedSchema = plain . paramSchemaToSchema
283+instance ToSchema Int64 where declareNamedSchema = plain . paramSchemaToSchema
284+instance ToSchema Word where declareNamedSchema = plain . paramSchemaToSchema
285+instance ToSchema Word8 where declareNamedSchema = plain . paramSchemaToSchema
286+instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
287+instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
288+instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
289+
290+instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema
291+instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
292+instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
293+instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
294+
295+instance ToSchema a => ToSchema (Maybe a) where
296+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
297+
298+instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
299+
300+instance ToSchema () where
301+ declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
302+
303+instance (ToSchema a, ToSchema b) => ToSchema (a, b)
304+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
305+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
306+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
307+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
308+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
309+
310+timeSchema :: T.Text -> Schema
311+timeSchema fmt = mempty
312+ & type_ .~ SwaggerString
313+ & format ?~ fmt
314+
315+-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
316+instance ToSchema Day where
317+ declareNamedSchema _ = pure $ named "Day" (timeSchema "date")
318+
319+-- |
320+-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
321+-- Just "yyyy-mm-ddThh:MM:ss"
322+instance ToSchema LocalTime where
323+ declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")
324+
325+-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
326+instance ToSchema ZonedTime where
327+ declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
328+
329+instance ToSchema NominalDiffTime where
330+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
331+
332+-- |
333+-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
334+-- Just "yyyy-mm-ddThh:MM:ssZ"
335+instance ToSchema UTCTime where
336+ declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")
337+
338+instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
339+instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
340+
341+instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
342+
343+-- | NOTE: This schema does not account for the uniqueness of keys.
344+instance ToSchema a => ToSchema (IntMap a) where
345+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
346+
347+instance ToSchema a => ToSchema (Map String a) where
348+ declareNamedSchema _ = do
349+ schema <- declareSchema (Proxy :: Proxy a)
350+ return $ unnamed $ mempty
351+ & type_ .~ SwaggerObject
352+ & additionalProperties ?~ schema
353+
354+instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
355+instance ToSchema a => ToSchema (Map TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
356+
357+instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
358+instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
359+instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
360+
361+instance ToSchema a => ToSchema (Set a) where
362+ declareNamedSchema _ = do
363+ schema <- declareSchema (Proxy :: Proxy [a])
364+ return $ unnamed $ schema
365+ & uniqueItems ?~ True
366+
367+instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
368+
369+instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
370+instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
371+
372+instance ToSchema a => ToSchema (Sum a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
373+instance ToSchema a => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
374+instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
375+instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
376+instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
377+
378+-- | Default schema for @'Bounded'@, @'Integral'@ types.
379+--
380+-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
381+-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
382+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
383+toSchemaBoundedIntegral _ = mempty
384+ & type_ .~ SwaggerInteger
385+ & minimum_ ?~ fromInteger (toInteger (minBound :: a))
386+ & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
387+
388+-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
389+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
390+ ( Bounded a, Integral a
391+ , Generic a, Rep a ~ D1 d f, Datatype d)
392+ => SchemaOptions -> proxy a -> NamedSchema
393+genericToNamedSchemaBoundedIntegral opts proxy
394+ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
395+
396+-- | A configurable generic @'Schema'@ creator.
397+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
398+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
399+
400+-- | A configurable generic @'NamedSchema'@ creator.
401+-- This function applied to @'defaultSchemaOptions'@
402+-- is used as the default for @'declareNamedSchema'@
403+-- when the type is an instance of @'Generic'@.
404+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
405+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
406+
407+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
408+gdatatypeSchemaName opts _ = case name of
409+ (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
410+ _ -> Nothing
411+ where
412+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
413+
414+-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
415+paramSchemaToNamedSchema :: forall a d f proxy.
416+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
417+ => SchemaOptions -> proxy a -> NamedSchema
418+paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
419+
420+-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
421+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
422+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
423+
424+nullarySchema :: Schema
425+nullarySchema = mempty
426+ & type_ .~ SwaggerArray
427+ & items ?~ SwaggerItemsArray []
428+
429+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
430+gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
431+
432+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
433+gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
434+
435+instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
436+ gdeclareNamedSchema opts _ schema = do
437+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema
438+ gdeclareNamedSchema opts (Proxy :: Proxy f) gschema
439+
440+instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
441+ gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
442+ where
443+ name = gdatatypeSchemaName opts (Proxy :: Proxy d)
444+
445+instance OVERLAPPABLE_ GToSchema f => GToSchema (C1 c f) where
446+ gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)
447+
448+instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
449+ gdeclareNamedSchema = gdeclareNamedSumSchema
450+
451+-- | Single field constructor.
452+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
453+ gdeclareNamedSchema opts _ s
454+ | unwrapUnaryRecords opts = fieldSchema
455+ | otherwise =
456+ case schema ^. items of
457+ Just (SwaggerItemsArray [_]) -> fieldSchema
458+ _ -> do
459+ declare defs
460+ return (unnamed schema)
461+ where
462+ (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
463+ recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
464+ fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
465+
466+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
467+gdeclareSchemaRef opts proxy = do
468+ case gtoNamedSchema opts proxy of
469+ NamedSchema (Just name) schema -> do
470+ -- This check is very important as it allows generically
471+ -- derive used definitions for recursive schemas.
472+ -- Lazy Declare monad allows toNamedSchema to ignore
473+ -- any declarations (which would otherwise loop) and
474+ -- retrieve the schema and its name to check if we
475+ -- have already declared it.
476+ -- If we have, we don't need to declare anything for
477+ -- this schema this time and thus simply return the reference.
478+ known <- looks (HashMap.member name)
479+ when (not known) $ do
480+ declare [(name, schema)]
481+ void $ gdeclareNamedSchema opts proxy mempty
482+ return $ Ref (Reference name)
483+ _ -> Inline <$> gdeclareSchema opts proxy
484+
485+appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)
486+appendItem x Nothing = Just (SwaggerItemsArray [x])
487+appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs))
488+appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
489+
490+withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
491+ SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
492+withFieldSchema opts _ isRequiredField schema = do
493+ ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
494+ return $
495+ if T.null fname
496+ then schema
497+ & type_ .~ SwaggerArray
498+ & items %~ appendItem ref
499+ else schema
500+ & type_ .~ SwaggerObject
501+ & properties . at fname ?~ ref
502+ & if isRequiredField
503+ then required %~ (fname :)
504+ else id
505+ where
506+ fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
507+
508+-- | Optional record fields.
509+instance OVERLAPPING_ (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
510+ gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
511+
512+-- | Record fields.
513+instance OVERLAPPABLE_ (Selector s, GToSchema f) => GToSchema (S1 s f) where
514+ gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
515+
516+instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
517+ gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
518+
519+instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
520+ gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
521+
522+instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
523+ gdeclareNamedSchema = gdeclareNamedSumSchema
524+
525+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
526+gdeclareNamedSumSchema opts proxy s
527+ | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
528+ | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
529+ where
530+ declareSumSchema = gsumToSchema opts proxy s
531+ (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
532+
533+ toStringTag schema = mempty
534+ & type_ .~ SwaggerString
535+ & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
536+
537+type AllNullary = All
538+
539+class GSumToSchema f where
540+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
541+
542+instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
543+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)
544+
545+gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
546+ Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
547+gsumConToSchemaWith ref opts _ schema = schema
548+ & type_ .~ SwaggerObject
549+ & properties . at tag ?~ ref
550+ & maxProperties ?~ 1
551+ & minProperties ?~ 1
552+ where
553+ tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
554+
555+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
556+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
557+gsumConToSchema opts proxy schema = do
558+ ref <- gdeclareSchemaRef opts proxy
559+ return $ gsumConToSchemaWith ref opts proxy schema
560+
561+instance OVERLAPPABLE_ (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
562+ gsumToSchema opts proxy schema = do
563+ tell (All False)
564+ lift $ gsumConToSchema opts proxy schema
565+
566+instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
567+ gsumToSchema opts proxy schema = do
568+ tell (All False)
569+ lift $ gsumConToSchema opts proxy schema
570+
571+instance Constructor c => GSumToSchema (C1 c U1) where
572+ gsumToSchema opts proxy = pure . gsumConToSchemaWith (Inline nullarySchema) opts proxy
573+
574+data Proxy2 a b = Proxy2
575+
576+data Proxy3 a b c = Proxy3
577+
src/Data/OpenApi/Internal/Utils.hs → src/Data/Swagger/Internal/Utils.hsrenamed+46−15
@@ -4,29 +4,28 @@
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE RankNTypes #-}
66{-# LANGUAGE TypeOperators #-}
7−module Data.OpenApi.Internal.Utils where
7+module Data.Swagger.Internal.Utils where
88
99import Prelude ()
1010import Prelude.Compat
1111
12+import Control.Arrow (first)
13+import Control.Applicative
1214import Control.Lens ((&), (%~))
1315import Control.Lens.TH
1416import Data.Aeson
1517import Data.Aeson.Types
16−import qualified Data.Aeson.Encode.Pretty as P
17−import qualified Data.ByteString.Lazy as BSL
1818import Data.Char
1919import Data.Data
2020import Data.Hashable (Hashable)
2121import Data.HashMap.Strict (HashMap)
2222import qualified Data.HashMap.Strict as HashMap
23−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
24−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
2523import Data.Map (Map)
26−import Data.Set (Set)
24+import Data.Monoid
2725import Data.Text (Text)
2826import GHC.Generics
2927import Language.Haskell.TH (mkName)
28+import Text.Read (readMaybe)
3029
3130swaggerFieldRules :: LensRules
3231swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
@@ -45,8 +44,6 @@ swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
4544 fixName' "minimum" = "minimum_" -- Prelude conflict
4645 fixName' "maximum" = "maximum_" -- Prelude conflict
4746 fixName' "enum" = "enum_" -- Control.Lens conflict
48− fixName' "head" = "head_" -- Prelude conflict
49− fixName' "not" = "not_" -- Prelude conflict
5047 fixName' n = n
5148
5249gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
@@ -54,6 +51,17 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of
5451 Just x -> z x
5552 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
5653
54+hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v
55+hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList
56+
57+hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)
58+hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList
59+ where
60+ g (x, y) = (\a -> (a, y)) <$> f x
61+
62+hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)
63+hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)
64+
5765jsonPrefix :: String -> Options
5866jsonPrefix prefix = defaultOptions
5967 { fieldLabelModifier = modifier . drop 1
@@ -75,10 +83,40 @@ parseOneOf xs js =
7583 where
7684 ys = zip (map toJSON xs) xs
7785
86+omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value
87+omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o)
88+ where
89+ nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
90+omitEmptiesExcept _ js = js
91+
92+omitEmpties :: Value -> Value
93+omitEmpties = omitEmptiesExcept (\_ _ -> False)
94+
95+genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
96+genericToJSONWithSub sub opts x =
97+ case genericToJSON opts x of
98+ Object o ->
99+ case HashMap.lookup sub o of
100+ Just so -> Object (HashMap.delete sub o) <+> so
101+ Nothing -> Object o -- no subjson, leaving object as is
102+ _ -> error "genericToJSONWithSub: subjson is not an object"
103+
104+genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
105+genericParseJSONWithSub sub opts js@(Object o)
106+ = genericParseJSON opts js -- try without subjson
107+ <|> genericParseJSON opts js' -- try with subjson
108+ where
109+ js' = Object (HashMap.insert sub (Object o) o)
110+genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"
111+
78112(<+>) :: Value -> Value -> Value
79113Object x <+> Object y = Object (x <> y)
80114_ <+> _ = error "<+>: merging non-objects"
81115
116+withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
117+withDefaults parser defs js@(Object _) = parser (js <+> object defs)
118+withDefaults _ _ _ = empty
119+
82120genericMempty :: (Generic a, GMonoid (Rep a)) => a
83121genericMempty = to gmempty
84122
@@ -114,17 +152,12 @@ class SwaggerMonoid m where
114152 swaggerMappend = mappend
115153
116154instance SwaggerMonoid [a]
117−instance Ord a => SwaggerMonoid (Set a)
118155instance Ord k => SwaggerMonoid (Map k v)
119156
120157instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
121158 swaggerMempty = mempty
122159 swaggerMappend = HashMap.unionWith (\_old new -> new)
123160
124−instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where
125− swaggerMempty = mempty
126− swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)
127−
128161instance SwaggerMonoid Text where
129162 swaggerMempty = mempty
130163 swaggerMappend x "" = x
@@ -135,5 +168,3 @@ instance SwaggerMonoid (Maybe a) where
135168 swaggerMappend x Nothing = x
136169 swaggerMappend _ y = y
137170
138−encodePretty :: ToJSON a => a -> BSL.ByteString
139−encodePretty = P.encodePretty' $ P.defConfig { P.confCompare = P.compare }
src/Data/Swagger/Lens.hsnew file+165
@@ -0,0 +1,165 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE TemplateHaskell #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+{-# OPTIONS_GHC -fno-warn-orphans #-}
12+#include "overlapping-compat.h"
13+module Data.Swagger.Lens where
14+
15+import Control.Lens
16+import Data.Aeson (Value)
17+import Data.Scientific (Scientific)
18+import Data.Swagger.Internal
19+import Data.Swagger.Internal.Utils
20+import Data.Text (Text)
21+
22+-- * Classy lenses
23+
24+makeFields ''Swagger
25+makeFields ''Host
26+makeFields ''Info
27+makeFields ''Contact
28+makeFields ''License
29+makeFields ''PathItem
30+makeFields ''Tag
31+makeFields ''Operation
32+makeFields ''Param
33+makeLensesWith swaggerFieldRules ''ParamOtherSchema
34+makeFields ''Header
35+makeFields ''Schema
36+makeFields ''NamedSchema
37+makeLensesWith swaggerFieldRules ''ParamSchema
38+makeFields ''Xml
39+makeLensesWith swaggerFieldRules ''Responses
40+makeFields ''Response
41+makeLensesWith swaggerFieldRules ''SecurityScheme
42+makeFields ''ApiKeyParams
43+makeFields ''OAuth2Params
44+makeFields ''ExternalDocs
45+
46+-- * Prisms
47+-- ** 'ParamAnySchema' prisms
48+makePrisms ''ParamAnySchema
49+-- ** 'SecuritySchemeType' prisms
50+makePrisms ''SecuritySchemeType
51+
52+-- ** 'SwaggerItems' prisms
53+
54+_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema]
55+_SwaggerItemsArray
56+ = prism (\x -> SwaggerItemsArray x) $ \x -> case x of
57+ SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
58+ SwaggerItemsObject o -> Left (SwaggerItemsObject o)
59+ SwaggerItemsArray a -> Right a
60+
61+_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema)
62+_SwaggerItemsObject
63+ = prism (\x -> SwaggerItemsObject x) $ \x -> case x of
64+ SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
65+ SwaggerItemsObject o -> Right o
66+ SwaggerItemsArray a -> Left (SwaggerItemsArray a)
67+
68+_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)
69+_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)
70+
71+-- =============================================================
72+-- More helpful instances for easier access to schema properties
73+
74+type instance Index Responses = HttpStatusCode
75+type instance Index Operation = HttpStatusCode
76+
77+type instance IxValue Responses = Referenced Response
78+type instance IxValue Operation = Referenced Response
79+
80+instance Ixed Responses where ix n = responses . ix n
81+instance At Responses where at n = responses . at n
82+
83+instance Ixed Operation where ix n = responses . ix n
84+instance At Operation where at n = responses . at n
85+
86+-- HasType instances
87+instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_
88+instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_
89+instance HasType NamedSchema (SwaggerType Schema) where type_ = schema.paramSchema.type_
90+instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_
91+
92+-- HasDefault instances
93+instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
94+instance HasDefault Schema (Maybe Value) where default_ = paramSchema.default_
95+instance HasDefault ParamOtherSchema (Maybe Value) where default_ = paramSchema.default_
96+
97+-- OVERLAPPABLE instances
98+
99+instance
100+#if __GLASGOW_HASKELL__ >= 710
101+ OVERLAPPABLE_
102+#endif
103+ HasParamSchema s (ParamSchema t)
104+ => HasFormat s (Maybe Format) where
105+ format = paramSchema.format
106+
107+instance
108+#if __GLASGOW_HASKELL__ >= 710
109+ OVERLAPPABLE_
110+#endif
111+ HasParamSchema s (ParamSchema t)
112+ => HasItems s (Maybe (SwaggerItems t)) where
113+ items = paramSchema.items
114+
115+instance
116+#if __GLASGOW_HASKELL__ >= 710
117+ OVERLAPPABLE_
118+#endif
119+ HasParamSchema s (ParamSchema t)
120+ => HasMaximum s (Maybe Scientific) where
121+ maximum_ = paramSchema.maximum_
122+
123+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
124+ => HasExclusiveMaximum s (Maybe Bool) where
125+ exclusiveMaximum = paramSchema.exclusiveMaximum
126+
127+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
128+ => HasMinimum s (Maybe Scientific) where
129+ minimum_ = paramSchema.minimum_
130+
131+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
132+ => HasExclusiveMinimum s (Maybe Bool) where
133+ exclusiveMinimum = paramSchema.exclusiveMinimum
134+
135+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
136+ => HasMaxLength s (Maybe Integer) where
137+ maxLength = paramSchema.maxLength
138+
139+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
140+ => HasMinLength s (Maybe Integer) where
141+ minLength = paramSchema.minLength
142+
143+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
144+ => HasPattern s (Maybe Text) where
145+ pattern = paramSchema.pattern
146+
147+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
148+ => HasMaxItems s (Maybe Integer) where
149+ maxItems = paramSchema.maxItems
150+
151+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
152+ => HasMinItems s (Maybe Integer) where
153+ minItems = paramSchema.minItems
154+
155+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
156+ => HasUniqueItems s (Maybe Bool) where
157+ uniqueItems = paramSchema.uniqueItems
158+
159+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
160+ => HasEnum s (Maybe [Value]) where
161+ enum_ = paramSchema.enum_
162+
163+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
164+ => HasMultipleOf s (Maybe Scientific) where
165+ multipleOf = paramSchema.multipleOf
src/Data/OpenApi/ParamSchema.hs → src/Data/Swagger/ParamSchema.hsrenamed+6−9
@@ -1,10 +1,12 @@
11-- |
2−-- Module: Data.OpenApi.ParamSchema
2+-- Module: Data.Swagger.ParamSchema
3+-- Copyright: (c) 2015 GetShopTV
4+-- License: BSD3
35-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
46-- Stability: experimental
57--
68-- Types and functions for working with Swagger parameter schema.
7−module Data.OpenApi.ParamSchema (
9+module Data.Swagger.ParamSchema (
810 -- * Encoding
911 ToParamSchema(..),
1012
@@ -12,15 +14,10 @@ module Data.OpenApi.ParamSchema (
1214 genericToParamSchema,
1315 toParamSchemaBoundedIntegral,
1416
15− -- * Schema templates
16− passwordSchema,
17− binarySchema,
18− byteSchema,
19−
2017 -- * Generic encoding configuration
2118 SchemaOptions(..),
2219 defaultSchemaOptions,
2320) where
2421
25−import Data.OpenApi.Internal.ParamSchema
26−import Data.OpenApi.SchemaOptions
22+import Data.Swagger.Internal.ParamSchema
23+import Data.Swagger.SchemaOptions
src/Data/OpenApi/Schema.hs → src/Data/Swagger/Schema.hsrenamed+6−19
@@ -1,10 +1,12 @@
11-- |
2−-- Module: Data.OpenApi.Schema
2+-- Module: Data.Swagger.Schema
3+-- Copyright: (c) 2015 GetShopTV
4+-- License: BSD3
35-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
46-- Stability: experimental
57--
68-- Types and functions for working with Swagger schema.
7−module Data.OpenApi.Schema (
9+module Data.Swagger.Schema (
810 -- * Encoding
911 ToSchema(..),
1012 declareSchema,
@@ -17,25 +19,11 @@ module Data.OpenApi.Schema (
1719 -- * Generic schema encoding
1820 genericDeclareNamedSchema,
1921 genericDeclareSchema,
20− genericDeclareNamedSchemaNewtype,
21− genericNameSchema,
22−
23− -- ** 'Bounded' 'Integral'
2422 genericToNamedSchemaBoundedIntegral,
2523 toSchemaBoundedIntegral,
26−
27− -- ** 'Bounded' 'Enum' key mappings
28− declareSchemaBoundedEnumKeyMapping,
29− toSchemaBoundedEnumKeyMapping,
30−
31− -- ** Reusing 'ToParamSchema'
3224 paramSchemaToNamedSchema,
3325 paramSchemaToSchema,
3426
35− -- * Sketching @'Schema'@s using @'ToJSON'@
36− sketchSchema,
37− sketchStrictSchema,
38−
3927 -- * Inlining @'Schema'@s
4028 inlineNonRecursiveSchemas,
4129 inlineAllSchemas,
@@ -45,8 +33,7 @@ module Data.OpenApi.Schema (
4533 -- * Generic encoding configuration
4634 SchemaOptions(..),
4735 defaultSchemaOptions,
48− fromAesonOptions,
4936) where
5037
51−import Data.OpenApi.Internal.Schema
52−import Data.OpenApi.SchemaOptions
38+import Data.Swagger.Internal.Schema
39+import Data.Swagger.SchemaOptions
src/Data/Swagger/Schema/Validation.hsnew file+275
@@ -0,0 +1,275 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE PackageImports #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE TemplateHaskell #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+-- |
13+-- Module: Data.Swagger.Schema.Validate
14+-- Copyright: (c) 2015 GetShopTV
15+-- License: BSD3
16+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
17+-- Stability: experimental
18+--
19+-- Validate JSON values with Swagger Schema.
20+module Data.Swagger.Schema.Validation where
21+
22+import Control.Applicative
23+import Control.Lens
24+import Control.Lens.TH
25+import Control.Monad (when)
26+
27+import Data.Aeson hiding (Result)
28+import Data.Foldable (traverse_, for_, sequenceA_)
29+import Data.HashMap.Strict (HashMap)
30+import qualified Data.HashMap.Strict as HashMap
31+import qualified "unordered-containers" Data.HashSet as HashSet
32+import Data.Monoid
33+import Data.Scientific (Scientific, isInteger)
34+import Data.Text (Text)
35+import qualified Data.Text as Text
36+import Data.Vector (Vector)
37+import qualified Data.Vector as Vector
38+
39+import Data.Swagger.Internal
40+import Data.Swagger.Lens
41+
42+
43+data Result a
44+ = Failed [String]
45+ | Passed a
46+ deriving (Eq, Show, Functor)
47+
48+instance Applicative Result where
49+ pure = Passed
50+ Passed f <*> Passed x = Passed (f x)
51+ Failed xs <*> Failed ys = Failed (xs <> ys)
52+ Failed xs <*> _ = Failed xs
53+ _ <*> Failed ys = Failed ys
54+
55+instance Alternative Result where
56+ empty = Failed mempty
57+ Passed x <|> _ = Passed x
58+ _ <|> y = y
59+
60+instance Monad Result where
61+ return = pure
62+ Passed x >>= f = f x
63+ Failed xs >>= f = Failed xs
64+
65+data Config = Config
66+ { configPatternChecker :: Pattern -> Text -> Bool
67+ , configDefinitions :: Definitions Schema
68+ }
69+
70+-- | Default @'Config'@:
71+--
72+-- @
73+-- defaultConfig = 'Config'
74+-- { 'configPatternChecker' = \_pattern _str -> True
75+-- , 'configDefinitions' = mempty
76+-- }
77+-- @
78+defaultConfig :: Config
79+defaultConfig = Config
80+ { configPatternChecker = \_pattern _str -> True
81+ , configDefinitions = mempty
82+ }
83+
84+newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }
85+ deriving (Functor)
86+
87+instance Applicative (Validation schema) where
88+ pure x = Validation (\_ _ -> pure x)
89+ Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)
90+
91+instance Alternative (Validation schema) where
92+ empty = Validation (\_ _ -> empty)
93+ Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)
94+
95+instance Profunctor Validation where
96+ dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))
97+
98+instance Choice Validation where
99+ left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))
100+ right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))
101+
102+instance Monad (Validation s) where
103+ return = pure
104+ Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)
105+ (>>) = (*>)
106+
107+withConfig :: (Config -> Validation s a) -> Validation s a
108+withConfig f = Validation (\c -> runValidation (f c) c)
109+
110+withSchema :: (s -> Validation s a) -> Validation s a
111+withSchema f = Validation (\c s -> runValidation (f s) c s)
112+
113+invalid :: String -> Validation schema a
114+invalid msg = Validation (\_ _ -> Failed [msg])
115+
116+valid :: Validation schema ()
117+valid = pure ()
118+
119+check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
120+check l g = withSchema $ \schema ->
121+ case schema ^. l of
122+ Nothing -> valid
123+ Just x -> g x
124+
125+sub :: t -> Validation t a -> Validation s a
126+sub = lmap . const
127+
128+sub_ :: Getting a s a -> Validation a r -> Validation s r
129+sub_ = lmap . view
130+
131+withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
132+withRef (Reference ref) f = withConfig $ \cfg ->
133+ case HashMap.lookup ref (configDefinitions cfg) of
134+ Nothing -> invalid $ "unknown schema " ++ show ref
135+ Just s -> f s
136+
137+validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
138+validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)
139+validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
140+
141+validateWithSchema :: Value -> Validation Schema ()
142+validateWithSchema value = do
143+ validateSchemaType value
144+ sub_ paramSchema $ validateEnum value
145+
146+validateWithParamSchema :: Value -> Validation (ParamSchema t) ()
147+validateWithParamSchema value = do
148+ validateParamSchemaType value
149+ validateEnum value
150+
151+validateInteger :: Scientific -> Validation (ParamSchema t) ()
152+validateInteger n = do
153+ when (not (isInteger n)) $
154+ invalid ("not an integer: " ++ show n)
155+ validateNumber n
156+
157+validateNumber :: Scientific -> Validation (ParamSchema t) ()
158+validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do
159+ let exMax = Just True == schema ^. exclusiveMaximum
160+ exMin = Just True == schema ^. exclusiveMinimum
161+
162+ check maximum_ $ \m ->
163+ when (if exMax then (n >= m) else (n > m)) $
164+ invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")
165+
166+ check minimum_ $ \m ->
167+ when (if exMin then (n <= m) else (n < m)) $
168+ invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")")
169+
170+ check multipleOf $ \k ->
171+ when (not (isInteger (n / k))) $
172+ invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)
173+
174+validateString :: Text -> Validation (ParamSchema t) ()
175+validateString s = do
176+ check maxLength $ \n ->
177+ when (len > fromInteger n) $
178+ invalid ("string is too long (length should be <=" ++ show n ++ "): " ++ show s)
179+
180+ check minLength $ \n ->
181+ when (len < fromInteger n) $
182+ invalid ("string is too short (length should be >=" ++ show n ++ "): " ++ show s)
183+
184+ check pattern $ \regex -> do
185+ withConfig $ \cfg -> do
186+ when (not (configPatternChecker cfg regex s)) $
187+ invalid ("string does not match pattern " ++ show regex ++ ": " ++ show s)
188+ where
189+ len = Text.length s
190+
191+validateArray :: Vector Value -> Validation (ParamSchema t) ()
192+validateArray xs = do
193+ check maxItems $ \n ->
194+ when (len > fromInteger n) $
195+ invalid ("array exceeds maximum size (should be <=" ++ show n ++ "): " ++ show (encode xs))
196+
197+ check minItems $ \n ->
198+ when (len < fromInteger n) $
199+ invalid ("array is too short (size should be >=" ++ show n ++ "): " ++ show (encode xs))
200+
201+ check items $ \case
202+ SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs
203+ SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs
204+ SwaggerItemsArray itemSchemas -> do
205+ when (len /= length itemSchemas) $
206+ invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ "): " ++ show (encode xs))
207+ sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
208+
209+ check uniqueItems $ \unique ->
210+ when (unique && not allUnique) $
211+ invalid ("array is expected to contain unique items, but it does not: " ++ show (encode xs))
212+ where
213+ len = Vector.length xs
214+ allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
215+
216+validateObject :: HashMap Text Value -> Validation Schema ()
217+validateObject o = withSchema $ \schema ->
218+ case schema ^. discriminator of
219+ Just pname -> case fromJSON <$> HashMap.lookup pname o of
220+ Just (Success ref) -> validateWithSchemaRef ref (Object o)
221+ Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)
222+ Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing: " ++ show (encode o))
223+ Nothing -> do
224+ check maxProperties $ \n ->
225+ when (size > n) $
226+ invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ "): " ++ show (encode o))
227+
228+ check minProperties $ \n ->
229+ when (size < n) $
230+ invalid ("object size is too small (total number of properties should be >=" ++ show n ++ "): " ++ show (encode o))
231+
232+ validateRequired
233+ validateProps
234+ where
235+ size = fromIntegral (HashMap.size o)
236+
237+ validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)
238+ validateReq name =
239+ when (not (HashMap.member name o)) $
240+ invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))
241+
242+ validateProps = withSchema $ \schema -> do
243+ for_ (HashMap.toList o) $ \(k, v) ->
244+ case HashMap.lookup k (schema ^. properties) of
245+ Nothing -> check additionalProperties $ \s -> sub s $ validateWithSchema v
246+ Just s -> validateWithSchemaRef s v
247+
248+validateEnum :: Value -> Validation (ParamSchema t) ()
249+validateEnum value = do
250+ check enum_ $ \xs ->
251+ when (value `notElem` xs) $
252+ invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
253+
254+validateSchemaType :: Value -> Validation Schema ()
255+validateSchemaType value = withSchema $ \schema ->
256+ case (schema ^. type_, value) of
257+ (SwaggerNull, Null) -> valid
258+ (SwaggerBoolean, Bool _) -> valid
259+ (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
260+ (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
261+ (SwaggerString, String s) -> sub_ paramSchema (validateString s)
262+ (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
263+ (SwaggerObject, Object o) -> validateObject o
264+ (t, _) -> invalid $ "expected JSON value of type " ++ show t ++ ": " ++ show (encode value)
265+
266+validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
267+validateParamSchemaType value = withSchema $ \schema ->
268+ case (schema ^. type_, value) of
269+ (SwaggerBoolean, Bool _) -> valid
270+ (SwaggerInteger, Number n) -> validateInteger n
271+ (SwaggerNumber, Number n) -> validateNumber n
272+ (SwaggerString, String s) -> validateString s
273+ (SwaggerArray, Array xs) -> validateArray xs
274+ (t, _) -> invalid $ "expected JSON value of type " ++ show t ++ ": " ++ show (encode value)
275+
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-lts-2.yamlnew file+5
@@ -0,0 +1,5 @@
1+flags: {}
2+packages:
3+- '.'
4+extra-deps: []
5+resolver: lts-2.22
stack.yaml+3−7
@@ -1,9 +1,5 @@
1−resolver: lts-16.31
1+flags: {}
22packages:
33- '.'
4−extra-deps:
5−- optics-core-0.3
6−- optics-th-0.3
7−- optics-extra-0.3
8−- indexed-profunctors-0.1
9−- insert-ordered-containers-0.2.3.1
4+extra-deps: []
5+resolver: nightly-2016-01-26
swagger2.cabalnew file+93
@@ -0,0 +1,93 @@
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+ , include/overlapping-compat.h
19+cabal-version: >=1.10
20+tested-with: GHC==7.8.4, GHC==7.10.3
21+
22+library
23+ hs-source-dirs: src
24+ include-dirs: include
25+ exposed-modules:
26+ Data.Swagger
27+ Data.Swagger.Declare
28+ Data.Swagger.Lens
29+ Data.Swagger.ParamSchema
30+ Data.Swagger.Schema
31+ Data.Swagger.Schema.Validation
32+ Data.Swagger.SchemaOptions
33+
34+ -- internal modules
35+ Data.Swagger.Internal
36+ Data.Swagger.Internal.Schema
37+ Data.Swagger.Internal.ParamSchema
38+ Data.Swagger.Internal.Utils
39+ build-depends: base >=4.7 && <4.10
40+ , base-compat >=0.6.0 && <0.10
41+ , aeson
42+ , containers
43+ , hashable
44+ , http-media
45+ , lens
46+ , mtl
47+ , network
48+ , scientific
49+ , text
50+ , template-haskell
51+ , time
52+ , transformers
53+ , unordered-containers
54+ , vector
55+ default-language: Haskell2010
56+
57+test-suite spec
58+ type: exitcode-stdio-1.0
59+ hs-source-dirs: test
60+ main-is: Spec.hs
61+ build-depends: base
62+ , base-compat
63+ , aeson
64+ , aeson-qq
65+ , containers
66+ , hashable
67+ , hspec
68+ , HUnit
69+ , mtl
70+ , QuickCheck
71+ , swagger2
72+ , text
73+ , time
74+ , unordered-containers
75+ , vector
76+ , lens
77+ other-modules:
78+ SpecCommon
79+ Data.SwaggerSpec
80+ Data.Swagger.SchemaSpec
81+ Data.Swagger.Schema.ValidationSpec
82+ default-language: Haskell2010
83+
84+test-suite doctest
85+ build-depends: base, doctest, Glob
86+ default-language: Haskell2010
87+ hs-source-dirs: test
88+ main-is: DocTest.hs
89+ type: exitcode-stdio-1.0
90+
91+source-repository head
92+ type: git
93+ 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+114
@@ -0,0 +1,114 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE QuasiQuotes #-}
5+module Data.Swagger.ParamSchemaSpec where
6+
7+import Data.Aeson
8+import Data.Aeson.QQ
9+import Data.Char
10+import Data.Proxy
11+import GHC.Generics
12+
13+import Data.Swagger
14+
15+import SpecCommon
16+import Test.Hspec
17+
18+checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
19+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js
20+
21+spec :: Spec
22+spec = do
23+ describe "Generic ToParamSchema" $ do
24+ context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON
25+ context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON
26+ context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON
27+ context "Unary records" $ do
28+ context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
29+ context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
30+
31+main :: IO ()
32+main = hspec spec
33+
34+-- ========================================================================
35+-- Unit type
36+-- ========================================================================
37+
38+data Unit = Unit deriving (Generic)
39+instance ToParamSchema Unit
40+
41+unitSchemaJSON :: Value
42+unitSchemaJSON = [aesonQQ|
43+{
44+ "type": "string",
45+ "enum": ["Unit"]
46+}
47+|]
48+
49+-- ========================================================================
50+-- Color (enum)
51+-- ========================================================================
52+data Color
53+ = Red
54+ | Green
55+ | Blue
56+ deriving (Generic)
57+instance ToParamSchema Color
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)
91+instance ToParamSchema Email
92+
93+emailSchemaJSON :: Value
94+emailSchemaJSON = [aesonQQ|
95+{
96+ "type": "string"
97+}
98+|]
99+
100+-- ========================================================================
101+-- UserId (non-record newtype)
102+-- ========================================================================
103+
104+newtype UserId = UserId Integer
105+ deriving (Generic)
106+instance ToParamSchema UserId
107+
108+userIdSchemaJSON :: Value
109+userIdSchemaJSON = [aesonQQ|
110+{
111+ "type": "integer"
112+}
113+|]
114+
test/Data/Swagger/Schema/ValidationSpec.hsnew file+122
@@ -0,0 +1,122 @@
1+{-# LANGUAGE PackageImports #-}
2+module Data.Swagger.Schema.ValidationSpec where
3+
4+import Control.Applicative
5+import Data.Aeson
6+import Data.Int
7+import Data.IntMap (IntMap)
8+import qualified Data.IntMap as IntMap
9+import Data.IntSet (IntSet)
10+import Data.Hashable (Hashable)
11+import "unordered-containers" Data.HashSet (HashSet)
12+import qualified "unordered-containers" Data.HashSet as HashSet
13+import Data.HashMap.Strict (HashMap)
14+import qualified Data.HashMap.Strict as HashMap
15+import Data.Map (Map)
16+import qualified Data.Map as Map
17+import Data.Proxy
18+import Data.Time
19+import qualified Data.Text as T
20+import qualified Data.Text.Lazy as TL
21+import Data.Set (Set)
22+import qualified Data.Set as Set
23+import Data.Word
24+
25+import Data.Swagger
26+import Data.Swagger.Schema.Validation
27+
28+import SpecCommon
29+import Test.Hspec
30+import Test.Hspec.QuickCheck
31+import Test.QuickCheck
32+
33+shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
34+shouldValidate proxy x = res == Passed ()
35+ where
36+ res = runValidation (validateWithSchema (toJSON x)) defaultConfig (toSchema proxy)
37+
38+spec :: Spec
39+spec = do
40+ describe "Validation" $ do
41+ prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
42+ prop "Char" $ shouldValidate (Proxy :: Proxy Char)
43+ prop "Double" $ shouldValidate (Proxy :: Proxy Double)
44+ prop "Float" $ shouldValidate (Proxy :: Proxy Float)
45+ prop "Int" $ shouldValidate (Proxy :: Proxy Int)
46+ prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
47+ prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
48+ prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
49+ prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
50+ prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
51+ prop "Word" $ shouldValidate (Proxy :: Proxy Word)
52+ prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
53+ prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
54+ prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
55+ prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
56+ prop "String" $ shouldValidate (Proxy :: Proxy String)
57+ prop "()" $ shouldValidate (Proxy :: Proxy ())
58+ prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
59+ prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
60+ prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
61+ prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
62+ prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
63+ -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
64+ prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
65+ prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
66+ prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
67+ prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
68+ prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
69+ prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
70+ prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
71+ prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
72+ prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
73+ prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
74+ prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
75+ prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
76+ prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
77+ prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
78+
79+main :: IO ()
80+main = hspec spec
81+
82+
83+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where
84+ arbitrary = Map.fromList <$> arbitrary
85+
86+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
87+ arbitrary = HashMap.fromList <$> arbitrary
88+
89+instance Arbitrary a => Arbitrary (IntMap a) where
90+ arbitrary = IntMap.fromList <$> arbitrary
91+
92+instance (Ord a, Arbitrary a) => Arbitrary (Set a) where
93+ arbitrary = Set.fromList <$> arbitrary
94+
95+instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where
96+ arbitrary = HashSet.fromList <$> arbitrary
97+
98+instance Arbitrary T.Text where
99+ arbitrary = T.pack <$> arbitrary
100+
101+instance Arbitrary TL.Text where
102+ arbitrary = TL.pack <$> arbitrary
103+
104+instance Arbitrary Day where
105+ arbitrary = liftA3 fromGregorian (fmap abs arbitrary) arbitrary arbitrary
106+
107+instance Arbitrary LocalTime where
108+ arbitrary = LocalTime
109+ <$> arbitrary
110+ <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))
111+
112+instance Eq ZonedTime where
113+ ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
114+
115+instance Arbitrary ZonedTime where
116+ arbitrary = ZonedTime
117+ <$> arbitrary
118+ <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))
119+
120+instance Arbitrary UTCTime where
121+ arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))
122+
test/Data/Swagger/SchemaSpec.hsnew file+602
@@ -0,0 +1,602 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE QuasiQuotes #-}
5+module Data.Swagger.SchemaSpec where
6+
7+import Prelude ()
8+import Prelude.Compat
9+
10+import Data.Aeson
11+import Data.Aeson.QQ
12+import Data.Char
13+import qualified Data.HashMap.Strict as HashMap
14+import Data.Proxy
15+import Data.Set (Set)
16+import qualified Data.Set as Set
17+import qualified Data.Text as Text
18+import GHC.Generics
19+
20+import Data.Swagger
21+import Data.Swagger.Declare
22+
23+import SpecCommon
24+import Test.Hspec
25+
26+checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
27+checkToSchema proxy js = toSchema proxy <=> js
28+
29+checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec
30+checkSchemaName sname proxy =
31+ it ("schema name is " ++ show sname) $
32+ schemaName proxy `shouldBe` fmap Text.pack sname
33+
34+checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
35+checkDefs proxy names =
36+ it ("uses these definitions " ++ show names) $
37+ Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)
38+ where
39+ defs = execDeclare (declareNamedSchema proxy) mempty
40+
41+checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
42+checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
43+
44+checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec
45+checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js
46+ where
47+ (defs, s) = runDeclare (declareSchema proxy) mempty
48+
49+checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec
50+checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js
51+ where
52+ (defs, s) = runDeclare (declareSchema proxy) mempty
53+
54+spec :: Spec
55+spec = do
56+ describe "Generic ToSchema" $ do
57+ context "Unit" $ checkToSchema (Proxy :: Proxy Unit) unitSchemaJSON
58+ context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
59+ context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
60+ context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
61+ context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
62+ context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
63+ context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
64+ context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON
65+ context "Unary records" $ do
66+ context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
67+ context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
68+ context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
69+ context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
70+ context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
71+ context "Sum types" $ do
72+ context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
73+ context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
74+ context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON
75+ context "Schema name" $ do
76+ context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)
77+ context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
78+ context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
79+ context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
80+ describe "Generic Definitions" $ do
81+ context "Unit" $ checkDefs (Proxy :: Proxy Unit) []
82+ context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]
83+ context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
84+ context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
85+ context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
86+ context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
87+ context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
88+ describe "Inlining Schemas" $ do
89+ context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON
90+ context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON
91+ context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
92+ context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
93+ context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
94+
95+main :: IO ()
96+main = hspec spec
97+
98+-- ========================================================================
99+-- Person (simple record with optional fields)
100+-- ========================================================================
101+data Person = Person
102+ { name :: String
103+ , phone :: Integer
104+ , email :: Maybe String
105+ } deriving (Generic)
106+
107+instance ToSchema Person
108+
109+personSchemaJSON :: Value
110+personSchemaJSON = [aesonQQ|
111+{
112+ "type": "object",
113+ "properties":
114+ {
115+ "name": { "type": "string" },
116+ "phone": { "type": "integer" },
117+ "email": { "type": "string" }
118+ },
119+ "required": ["name", "phone"]
120+}
121+|]
122+
123+-- ========================================================================
124+-- ISPair (non-record product data type)
125+-- ========================================================================
126+data ISPair = ISPair Integer String
127+ deriving (Generic)
128+
129+instance ToSchema ISPair
130+
131+ispairSchemaJSON :: Value
132+ispairSchemaJSON = [aesonQQ|
133+{
134+ "type": "array",
135+ "items":
136+ [
137+ { "type": "integer" },
138+ { "type": "string" }
139+ ]
140+}
141+|]
142+
143+-- ========================================================================
144+-- Point (record data type with custom fieldLabelModifier)
145+-- ========================================================================
146+data Point = Point
147+ { pointX :: Double
148+ , pointY :: Double
149+ } deriving (Generic)
150+
151+instance ToSchema Point where
152+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
153+ { fieldLabelModifier = map toLower . drop (length "point") }
154+
155+pointSchemaJSON :: Value
156+pointSchemaJSON = [aesonQQ|
157+{
158+ "type": "object",
159+ "properties":
160+ {
161+ "x": { "type": "number", "format": "double" },
162+ "y": { "type": "number", "format": "double" }
163+ },
164+ "required": ["x", "y"]
165+}
166+|]
167+
168+
169+-- ========================================================================
170+-- Color (enum)
171+-- ========================================================================
172+data Color
173+ = Red
174+ | Green
175+ | Blue
176+ deriving (Generic)
177+instance ToSchema Color
178+
179+colorSchemaJSON :: Value
180+colorSchemaJSON = [aesonQQ|
181+{
182+ "type": "string",
183+ "enum": ["Red", "Green", "Blue"]
184+}
185+|]
186+
187+-- ========================================================================
188+-- Shade (paramSchemaToNamedSchema)
189+-- ========================================================================
190+
191+data Shade = Dim | Bright deriving (Generic)
192+instance ToParamSchema Shade
193+
194+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
195+
196+shadeSchemaJSON :: Value
197+shadeSchemaJSON = [aesonQQ|
198+{
199+ "type": "string",
200+ "enum": ["Dim", "Bright"]
201+}
202+|]
203+
204+-- ========================================================================
205+-- Paint (record with bounded enum property)
206+-- ========================================================================
207+
208+newtype Paint = Paint { color :: Color }
209+ deriving (Generic)
210+instance ToSchema Paint
211+
212+paintSchemaJSON :: Value
213+paintSchemaJSON = [aesonQQ|
214+{
215+ "type": "object",
216+ "properties":
217+ {
218+ "color":
219+ {
220+ "$ref": "#/definitions/Color"
221+ }
222+ },
223+ "required": ["color"]
224+}
225+|]
226+
227+paintInlinedSchemaJSON :: Value
228+paintInlinedSchemaJSON = [aesonQQ|
229+{
230+ "type": "object",
231+ "properties":
232+ {
233+ "color":
234+ {
235+ "type": "string",
236+ "enum": ["Red", "Green", "Blue"]
237+ }
238+ },
239+ "required": ["color"]
240+}
241+|]
242+
243+-- ========================================================================
244+-- Email (newtype with unwrapUnaryRecords set to True)
245+-- ========================================================================
246+
247+newtype Email = Email { getEmail :: String }
248+ deriving (Generic)
249+
250+instance ToSchema Email where
251+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
252+ { unwrapUnaryRecords = True }
253+
254+emailSchemaJSON :: Value
255+emailSchemaJSON = [aesonQQ|
256+{
257+ "type": "string"
258+}
259+|]
260+
261+-- ========================================================================
262+-- UserId (non-record newtype)
263+-- ========================================================================
264+
265+newtype UserId = UserId Integer
266+ deriving (Eq, Ord, Generic)
267+instance ToSchema UserId
268+
269+userIdSchemaJSON :: Value
270+userIdSchemaJSON = [aesonQQ|
271+{
272+ "type": "integer"
273+}
274+|]
275+
276+-- ========================================================================
277+-- UserGroup (set newtype)
278+-- ========================================================================
279+
280+newtype UserGroup = UserGroup (Set UserId)
281+ deriving (Generic)
282+instance ToSchema UserGroup
283+
284+userGroupSchemaJSON :: Value
285+userGroupSchemaJSON = [aesonQQ|
286+{
287+ "type": "array",
288+ "items": { "$ref": "#/definitions/UserId" },
289+ "uniqueItems": true
290+}
291+|]
292+
293+-- ========================================================================
294+-- Player (record newtype)
295+-- ========================================================================
296+
297+newtype Player = Player
298+ { position :: Point
299+ } deriving (Generic)
300+instance ToSchema Player
301+
302+playerSchemaJSON :: Value
303+playerSchemaJSON = [aesonQQ|
304+{
305+ "type": "object",
306+ "properties":
307+ {
308+ "position":
309+ {
310+ "$ref": "#/definitions/Point"
311+ }
312+ },
313+ "required": ["position"]
314+}
315+|]
316+
317+-- ========================================================================
318+-- MyRoseTree (custom datatypeNameModifier)
319+-- ========================================================================
320+
321+data MyRoseTree = MyRoseTree
322+ { root :: String
323+ , trees :: [MyRoseTree]
324+ } deriving (Generic)
325+
326+instance ToSchema MyRoseTree where
327+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
328+ { datatypeNameModifier = drop (length "My") }
329+
330+myRoseTreeSchemaJSON :: Value
331+myRoseTreeSchemaJSON = [aesonQQ|
332+{
333+ "type": "object",
334+ "properties":
335+ {
336+ "root": { "type": "string" },
337+ "trees":
338+ {
339+ "type": "array",
340+ "items":
341+ {
342+ "$ref": "#/definitions/RoseTree"
343+ }
344+ }
345+ },
346+ "required": ["root", "trees"]
347+}
348+|]
349+
350+-- ========================================================================
351+-- Inlined (newtype for inlining schemas)
352+-- ========================================================================
353+
354+newtype Inlined a = Inlined { getInlined :: a }
355+
356+instance ToSchema a => ToSchema (Inlined a) where
357+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
358+ where
359+ unname (NamedSchema _ s) = NamedSchema Nothing s
360+
361+newtype Players = Players [Inlined Player]
362+ deriving (Generic)
363+instance ToSchema Players
364+
365+playersSchemaJSON :: Value
366+playersSchemaJSON = [aesonQQ|
367+{
368+ "type": "array",
369+ "items":
370+ {
371+ "type": "object",
372+ "properties":
373+ {
374+ "position":
375+ {
376+ "$ref": "#/definitions/Point"
377+ }
378+ },
379+ "required": ["position"]
380+ }
381+}
382+|]
383+
384+-- ========================================================================
385+-- Status (sum type with unary constructors)
386+-- ========================================================================
387+
388+data Status
389+ = StatusOk String
390+ | StatusError String
391+ deriving (Generic)
392+
393+instance ToSchema Status where
394+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
395+ { constructorTagModifier = map toLower . drop (length "Status") }
396+
397+statusSchemaJSON :: Value
398+statusSchemaJSON = [aesonQQ|
399+{
400+ "type": "object",
401+ "properties":
402+ {
403+ "ok": { "type": "string" },
404+ "error": { "type": "string" }
405+ },
406+ "maxProperties": 1,
407+ "minProperties": 1
408+}
409+|]
410+
411+-- ========================================================================
412+-- Unit type
413+-- ========================================================================
414+
415+data Unit = Unit deriving (Generic)
416+instance ToSchema Unit
417+
418+unitSchemaJSON :: Value
419+unitSchemaJSON = [aesonQQ|
420+{
421+ "type": "string",
422+ "enum": ["Unit"]
423+}
424+|]
425+
426+
427+-- ========================================================================
428+-- Character (sum type with ref and record in alternative)
429+-- ========================================================================
430+
431+data Character
432+ = PC Player
433+ | NPC { npcName :: String, npcPosition :: Point }
434+ deriving (Generic)
435+instance ToSchema Character
436+
437+characterSchemaJSON :: Value
438+characterSchemaJSON = [aesonQQ|
439+{
440+ "type": "object",
441+ "properties":
442+ {
443+ "PC": { "$ref": "#/definitions/Player" },
444+ "NPC":
445+ {
446+ "type": "object",
447+ "properties":
448+ {
449+ "npcName": { "type": "string" },
450+ "npcPosition": { "$ref": "#/definitions/Point" }
451+ },
452+ "required": ["npcName", "npcPosition"]
453+ }
454+ },
455+ "maxProperties": 1,
456+ "minProperties": 1
457+}
458+|]
459+
460+characterInlinedSchemaJSON :: Value
461+characterInlinedSchemaJSON = [aesonQQ|
462+{
463+ "type": "object",
464+ "properties":
465+ {
466+ "PC":
467+ {
468+ "type": "object",
469+ "properties":
470+ {
471+ "position":
472+ {
473+ "type": "object",
474+ "properties":
475+ {
476+ "x": { "type": "number", "format": "double" },
477+ "y": { "type": "number", "format": "double" }
478+ },
479+ "required": ["x", "y"]
480+ }
481+ },
482+ "required": ["position"]
483+ },
484+ "NPC":
485+ {
486+ "type": "object",
487+ "properties":
488+ {
489+ "npcName": { "type": "string" },
490+ "npcPosition":
491+ {
492+ "type": "object",
493+ "properties":
494+ {
495+ "x": { "type": "number", "format": "double" },
496+ "y": { "type": "number", "format": "double" }
497+ },
498+ "required": ["x", "y"]
499+ }
500+ },
501+ "required": ["npcName", "npcPosition"]
502+ }
503+ },
504+ "maxProperties": 1,
505+ "minProperties": 1
506+}
507+|]
508+
509+characterInlinedPlayerSchemaJSON :: Value
510+characterInlinedPlayerSchemaJSON = [aesonQQ|
511+{
512+ "type": "object",
513+ "properties":
514+ {
515+ "PC":
516+ {
517+ "type": "object",
518+ "properties":
519+ {
520+ "position":
521+ {
522+ "$ref": "#/definitions/Point"
523+ }
524+ },
525+ "required": ["position"]
526+ },
527+ "NPC":
528+ {
529+ "type": "object",
530+ "properties":
531+ {
532+ "npcName": { "type": "string" },
533+ "npcPosition": { "$ref": "#/definitions/Point" }
534+ },
535+ "required": ["npcName", "npcPosition"]
536+ }
537+ },
538+ "maxProperties": 1,
539+ "minProperties": 1
540+}
541+|]
542+
543+-- ========================================================================
544+-- Light (sum type with unwrapUnaryRecords)
545+-- ========================================================================
546+
547+data Light
548+ = NoLight
549+ | LightFreq Double
550+ | LightColor Color
551+ | LightWaveLength { waveLength :: Double }
552+ deriving (Generic)
553+
554+instance ToSchema Light where
555+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
556+ { unwrapUnaryRecords = True }
557+
558+lightSchemaJSON :: Value
559+lightSchemaJSON = [aesonQQ|
560+{
561+ "type": "object",
562+ "properties":
563+ {
564+ "NoLight": { "type": "array", "items": [] },
565+ "LightFreq": { "type": "number", "format": "double" },
566+ "LightColor": { "$ref": "#/definitions/Color" },
567+ "LightWaveLength": { "type": "number", "format": "double" }
568+ },
569+ "maxProperties": 1,
570+ "minProperties": 1
571+}
572+|]
573+
574+lightInlinedSchemaJSON :: Value
575+lightInlinedSchemaJSON = [aesonQQ|
576+{
577+ "type": "object",
578+ "properties":
579+ {
580+ "NoLight": { "type": "array", "items": [] },
581+ "LightFreq": { "type": "number", "format": "double" },
582+ "LightColor":
583+ {
584+ "type": "string",
585+ "enum": ["Red", "Green", "Blue"]
586+ },
587+ "LightWaveLength": { "type": "number", "format": "double" }
588+ },
589+ "maxProperties": 1,
590+ "minProperties": 1
591+}
592+|]
593+
594+-- ========================================================================
595+-- ResourceId (series of newtypes)
596+-- ========================================================================
597+
598+newtype Id = Id String deriving (Generic)
599+instance ToSchema Id
600+
601+newtype ResourceId = ResourceId Id deriving (Generic)
602+instance ToSchema ResourceId
test/Data/SwaggerSpec.hsnew file+1606
@@ -0,0 +1,1606 @@
1+{-# LANGUAGE OverloadedLists #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE QuasiQuotes #-}
5+module Data.SwaggerSpec where
6+
7+import Prelude ()
8+import Prelude.Compat
9+
10+import Control.Lens
11+
12+import Data.Aeson
13+import Data.Aeson.QQ
14+import Data.HashMap.Strict (HashMap)
15+import Data.Text (Text)
16+
17+import Data.Swagger
18+import SpecCommon
19+import Test.Hspec hiding (example)
20+
21+spec :: Spec
22+spec = do
23+ describe "License Object" $ licenseExample <=> licenseExampleJSON
24+ describe "Contact Object" $ contactExample <=> contactExampleJSON
25+ describe "Info Object" $ infoExample <=> infoExampleJSON
26+ describe "Operation Object" $ operationExample <=> operationExampleJSON
27+ describe "Schema Object" $ do
28+ context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
29+ context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
30+ context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
31+ context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
32+ describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
33+ describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
34+ describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
35+ describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
36+ describe "Swagger Object" $ do
37+ context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
38+ context "PetStore Example" $
39+ it "decodes successfully" $ do
40+ fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: Swagger) -> True; _ -> False)
41+
42+main :: IO ()
43+main = hspec spec
44+
45+-- =======================================================================
46+-- Info object
47+-- =======================================================================
48+
49+infoExample :: Info
50+infoExample = mempty
51+ & title .~ "Swagger Sample App"
52+ & description ?~ "This is a sample server Petstore server."
53+ & termsOfService ?~ "http://swagger.io/terms/"
54+ & contact ?~ contactExample
55+ & license ?~ licenseExample
56+ & version .~ "1.0.1"
57+
58+infoExampleJSON :: Value
59+infoExampleJSON = [aesonQQ|
60+{
61+ "title": "Swagger Sample App",
62+ "description": "This is a sample server Petstore server.",
63+ "termsOfService": "http://swagger.io/terms/",
64+ "contact": {
65+ "name": "API Support",
66+ "url": "http://www.swagger.io/support",
67+ "email": "support@swagger.io"
68+ },
69+ "license": {
70+ "name": "Apache 2.0",
71+ "url": "http://www.apache.org/licenses/LICENSE-2.0.html"
72+ },
73+ "version": "1.0.1"
74+}
75+|]
76+
77+-- =======================================================================
78+-- Contact object
79+-- =======================================================================
80+
81+contactExample :: Contact
82+contactExample = mempty
83+ & name ?~ "API Support"
84+ & url ?~ URL "http://www.swagger.io/support"
85+ & email ?~ "support@swagger.io"
86+
87+contactExampleJSON :: Value
88+contactExampleJSON = [aesonQQ|
89+{
90+ "name": "API Support",
91+ "url": "http://www.swagger.io/support",
92+ "email": "support@swagger.io"
93+}
94+|]
95+
96+-- =======================================================================
97+-- License object
98+-- =======================================================================
99+
100+licenseExample :: License
101+licenseExample = License "Apache 2.0" (Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html"))
102+
103+licenseExampleJSON :: Value
104+licenseExampleJSON = [aesonQQ|
105+{
106+ "name": "Apache 2.0",
107+ "url": "http://www.apache.org/licenses/LICENSE-2.0.html"
108+}
109+|]
110+
111+
112+-- =======================================================================
113+-- Operation object
114+-- =======================================================================
115+
116+operationExample :: Operation
117+operationExample = mempty
118+ & tags .~ ["pet"]
119+ & summary ?~ "Updates a pet in the store with form data"
120+ & description ?~ ""
121+ & operationId ?~ "updatePetWithForm"
122+ & consumes ?~ MimeList ["application/x-www-form-urlencoded"]
123+ & produces ?~ MimeList ["application/json", "application/xml"]
124+ & parameters .~ map Inline
125+ [ mempty
126+ & name .~ "petId"
127+ & description ?~ "ID of pet that needs to be updated"
128+ & required ?~ True
129+ & schema .~ ParamOther (stringSchema ParamPath)
130+ , mempty
131+ & name .~ "name"
132+ & description ?~ "Updated name of the pet"
133+ & required ?~ False
134+ & schema .~ ParamOther (stringSchema ParamFormData)
135+ , mempty
136+ & name .~ "status"
137+ & description ?~ "Updated status of the pet"
138+ & required ?~ False
139+ & schema .~ ParamOther (stringSchema ParamFormData)
140+ ]
141+
142+ & responses .~ (mempty & responses .~
143+ [ (200, Inline (mempty & description .~ "Pet updated."))
144+ , (405, Inline (mempty & description .~ "Invalid input")) ])
145+ & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]
146+ where
147+ stringSchema :: ParamLocation -> ParamOtherSchema
148+ stringSchema loc = mempty
149+ & in_ .~ loc
150+ & type_ .~ SwaggerString
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+ "consumes": [
162+ "application/x-www-form-urlencoded"
163+ ],
164+ "produces": [
165+ "application/json",
166+ "application/xml"
167+ ],
168+ "parameters": [
169+ {
170+ "name": "petId",
171+ "in": "path",
172+ "description": "ID of pet that needs to be updated",
173+ "required": true,
174+ "type": "string"
175+ },
176+ {
177+ "name": "name",
178+ "in": "formData",
179+ "description": "Updated name of the pet",
180+ "required": false,
181+ "type": "string"
182+ },
183+ {
184+ "name": "status",
185+ "in": "formData",
186+ "description": "Updated status of the pet",
187+ "required": false,
188+ "type": "string"
189+ }
190+ ],
191+ "responses": {
192+ "200": {
193+ "description": "Pet updated."
194+ },
195+ "405": {
196+ "description": "Invalid input"
197+ }
198+ },
199+ "security": [
200+ {
201+ "petstore_auth": [
202+ "write:pets",
203+ "read:pets"
204+ ]
205+ }
206+ ]
207+}
208+|]
209+
210+-- =======================================================================
211+-- Schema object
212+-- =======================================================================
213+
214+schemaPrimitiveExample :: Schema
215+schemaPrimitiveExample = mempty
216+ & type_ .~ SwaggerString
217+ & format ?~ "email"
218+
219+schemaPrimitiveExampleJSON :: Value
220+schemaPrimitiveExampleJSON = [aesonQQ|
221+{
222+ "type": "string",
223+ "format": "email"
224+}
225+|]
226+
227+schemaSimpleModelExample :: Schema
228+schemaSimpleModelExample = mempty
229+ & type_ .~ SwaggerObject
230+ & required .~ [ "name" ]
231+ & properties .~
232+ [ ("name", Inline (mempty & type_ .~ SwaggerString))
233+ , ("address", Ref (Reference "Address"))
234+ , ("age", Inline $ mempty
235+ & minimum_ ?~ 0
236+ & type_ .~ SwaggerInteger
237+ & format ?~ "int32" ) ]
238+
239+schemaSimpleModelExampleJSON :: Value
240+schemaSimpleModelExampleJSON = [aesonQQ|
241+{
242+ "type": "object",
243+ "required": [
244+ "name"
245+ ],
246+ "properties": {
247+ "name": {
248+ "type": "string"
249+ },
250+ "address": {
251+ "$ref": "#/definitions/Address"
252+ },
253+ "age": {
254+ "type": "integer",
255+ "format": "int32",
256+ "minimum": 0
257+ }
258+ }
259+}
260+|]
261+
262+schemaModelDictExample :: Schema
263+schemaModelDictExample = mempty
264+ & type_ .~ SwaggerObject
265+ & additionalProperties ?~ (mempty & type_ .~ SwaggerString)
266+
267+schemaModelDictExampleJSON :: Value
268+schemaModelDictExampleJSON = [aesonQQ|
269+{
270+ "type": "object",
271+ "additionalProperties": {
272+ "type": "string"
273+ }
274+}
275+|]
276+
277+schemaWithExampleExample :: Schema
278+schemaWithExampleExample = mempty
279+ & type_ .~ SwaggerObject
280+ & properties .~
281+ [ ("id", Inline $ mempty
282+ & type_ .~ SwaggerInteger
283+ & format ?~ "int64" )
284+ , ("name", Inline $ mempty
285+ & type_ .~ SwaggerString) ]
286+ & required .~ [ "name" ]
287+ & example ?~ [aesonQQ|
288+ {
289+ "name": "Puma",
290+ "id": 1
291+ }
292+ |]
293+
294+schemaWithExampleExampleJSON :: Value
295+schemaWithExampleExampleJSON = [aesonQQ|
296+{
297+ "type": "object",
298+ "properties": {
299+ "id": {
300+ "type": "integer",
301+ "format": "int64"
302+ },
303+ "name": {
304+ "type": "string"
305+ }
306+ },
307+ "required": [
308+ "name"
309+ ],
310+ "example": {
311+ "name": "Puma",
312+ "id": 1
313+ }
314+}
315+|]
316+
317+-- =======================================================================
318+-- Definitions object
319+-- =======================================================================
320+
321+definitionsExample :: HashMap Text Schema
322+definitionsExample =
323+ [ ("Category", mempty
324+ & type_ .~ SwaggerObject
325+ & properties .~
326+ [ ("id", Inline $ mempty
327+ & type_ .~ SwaggerInteger
328+ & format ?~ "int64")
329+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )
330+ , ("Tag", mempty
331+ & type_ .~ SwaggerObject
332+ & properties .~
333+ [ ("id", Inline $ mempty
334+ & type_ .~ SwaggerInteger
335+ & format ?~ "int64")
336+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]
337+
338+definitionsExampleJSON :: Value
339+definitionsExampleJSON = [aesonQQ|
340+{
341+ "Category": {
342+ "type": "object",
343+ "properties": {
344+ "id": {
345+ "type": "integer",
346+ "format": "int64"
347+ },
348+ "name": {
349+ "type": "string"
350+ }
351+ }
352+ },
353+ "Tag": {
354+ "type": "object",
355+ "properties": {
356+ "id": {
357+ "type": "integer",
358+ "format": "int64"
359+ },
360+ "name": {
361+ "type": "string"
362+ }
363+ }
364+ }
365+}
366+|]
367+
368+-- =======================================================================
369+-- Parameters Definition object
370+-- =======================================================================
371+
372+paramsDefinitionExample :: HashMap Text Param
373+paramsDefinitionExample =
374+ [ ("skipParam", mempty
375+ & name .~ "skip"
376+ & description ?~ "number of items to skip"
377+ & required ?~ True
378+ & schema .~ ParamOther (mempty
379+ & in_ .~ ParamQuery
380+ & type_ .~ SwaggerInteger
381+ & format ?~ "int32" ))
382+ , ("limitParam", mempty
383+ & name .~ "limit"
384+ & description ?~ "max records to return"
385+ & required ?~ True
386+ & schema .~ ParamOther (mempty
387+ & in_ .~ ParamQuery
388+ & type_ .~ SwaggerInteger
389+ & format ?~ "int32" )) ]
390+
391+paramsDefinitionExampleJSON :: Value
392+paramsDefinitionExampleJSON = [aesonQQ|
393+{
394+ "skipParam": {
395+ "name": "skip",
396+ "in": "query",
397+ "description": "number of items to skip",
398+ "required": true,
399+ "type": "integer",
400+ "format": "int32"
401+ },
402+ "limitParam": {
403+ "name": "limit",
404+ "in": "query",
405+ "description": "max records to return",
406+ "required": true,
407+ "type": "integer",
408+ "format": "int32"
409+ }
410+}
411+|]
412+
413+-- =======================================================================
414+-- Responses Definition object
415+-- =======================================================================
416+
417+responsesDefinitionExample :: HashMap Text Response
418+responsesDefinitionExample =
419+ [ ("NotFound", mempty & description .~ "Entity not found.")
420+ , ("IllegalInput", mempty & description .~ "Illegal input for operation.") ]
421+
422+responsesDefinitionExampleJSON :: Value
423+responsesDefinitionExampleJSON = [aesonQQ|
424+{
425+ "NotFound": {
426+ "description": "Entity not found."
427+ },
428+ "IllegalInput": {
429+ "description": "Illegal input for operation."
430+ }
431+}
432+|]
433+
434+-- =======================================================================
435+-- Responses Definition object
436+-- =======================================================================
437+
438+securityDefinitionsExample :: HashMap Text SecurityScheme
439+securityDefinitionsExample =
440+ [ ("api_key", SecurityScheme
441+ { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
442+ , _securitySchemeDescription = Nothing })
443+ , ("petstore_auth", SecurityScheme
444+ { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params
445+ { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"
446+ , _oauth2Scopes =
447+ [ ("write:pets", "modify pets in your account")
448+ , ("read:pets", "read your pets") ] } )
449+ , _securitySchemeDescription = Nothing }) ]
450+
451+securityDefinitionsExampleJSON :: Value
452+securityDefinitionsExampleJSON = [aesonQQ|
453+{
454+ "api_key": {
455+ "type": "apiKey",
456+ "name": "api_key",
457+ "in": "header"
458+ },
459+ "petstore_auth": {
460+ "type": "oauth2",
461+ "authorizationUrl": "http://swagger.io/api/oauth/dialog",
462+ "flow": "implicit",
463+ "scopes": {
464+ "write:pets": "modify pets in your account",
465+ "read:pets": "read your pets"
466+ }
467+ }
468+}
469+|]
470+
471+-- =======================================================================
472+-- Swagger object
473+-- =======================================================================
474+
475+swaggerExample :: Swagger
476+swaggerExample = mempty
477+ & basePath ?~ "/"
478+ & schemes ?~ [Http]
479+ & info .~ (mempty
480+ & version .~ "1.0"
481+ & title .~ "Todo API"
482+ & license ?~ License "MIT" (Just (URL "http://mit.com"))
483+ & description ?~ "This is a an API that tests servant-swagger support for a Todo API")
484+ & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation)
485+ & at 200 ?~ Inline (mempty
486+ & description .~ "OK"
487+ & schema ?~ Inline (mempty
488+ & type_ .~ SwaggerObject
489+ & example ?~ [aesonQQ|
490+ {
491+ "created": 100,
492+ "description": "get milk"
493+ } |]
494+ & description ?~ "This is some real Todo right here"
495+ & properties .~
496+ [ ("created", Inline $ mempty
497+ & type_ .~ SwaggerInteger
498+ & format ?~ "int32")
499+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))
500+ & produces ?~ MimeList [ "application/json" ]
501+ & parameters .~
502+ [ Inline $ mempty
503+ & required ?~ True
504+ & name .~ "id"
505+ & description ?~ "TodoId param"
506+ & schema .~ ParamOther (mempty
507+ & in_ .~ ParamPath
508+ & type_ .~ SwaggerString ) ]
509+ & tags .~ [ "todo" ] ))
510+
511+swaggerExampleJSON :: Value
512+swaggerExampleJSON = [aesonQQ|
513+{
514+ "swagger": "2.0",
515+ "basePath": "/",
516+ "schemes": [
517+ "http"
518+ ],
519+ "info": {
520+ "version": "1.0",
521+ "title": "Todo API",
522+ "license": {
523+ "url": "http://mit.com",
524+ "name": "MIT"
525+ },
526+ "description": "This is a an API that tests servant-swagger support for a Todo API"
527+ },
528+ "paths": {
529+ "/todo/{id}": {
530+ "get": {
531+ "responses": {
532+ "200": {
533+ "schema": {
534+ "example": {
535+ "created": 100,
536+ "description": "get milk"
537+ },
538+ "type": "object",
539+ "description": "This is some real Todo right here",
540+ "properties": {
541+ "created": {
542+ "format": "int32",
543+ "type": "integer"
544+ },
545+ "description": {
546+ "type": "string"
547+ }
548+ }
549+ },
550+ "description": "OK"
551+ }
552+ },
553+ "produces": [
554+ "application/json"
555+ ],
556+ "parameters": [
557+ {
558+ "required": true,
559+ "in": "path",
560+ "name": "id",
561+ "type": "string",
562+ "description": "TodoId param"
563+ }
564+ ],
565+ "tags": [
566+ "todo"
567+ ]
568+ }
569+ }
570+ }
571+}
572+|]
573+
574+petstoreExampleJSON :: Value
575+petstoreExampleJSON = [aesonQQ|
576+{
577+ "swagger":"2.0",
578+ "info":{
579+ "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.",
580+ "version":"1.0.0",
581+ "title":"Swagger Petstore",
582+ "termsOfService":"http://swagger.io/terms/",
583+ "contact":{
584+ "email":"apiteam@swagger.io"
585+ },
586+ "license":{
587+ "name":"Apache 2.0",
588+ "url":"http://www.apache.org/licenses/LICENSE-2.0.html"
589+ }
590+ },
591+ "host":"petstore.swagger.io",
592+ "basePath":"/v2",
593+ "tags":[
594+ {
595+ "name":"pet",
596+ "description":"Everything about your Pets",
597+ "externalDocs":{
598+ "description":"Find out more",
599+ "url":"http://swagger.io"
600+ }
601+ },
602+ {
603+ "name":"store",
604+ "description":"Access to Petstore orders"
605+ },
606+ {
607+ "name":"user",
608+ "description":"Operations about user",
609+ "externalDocs":{
610+ "description":"Find out more about our store",
611+ "url":"http://swagger.io"
612+ }
613+ }
614+ ],
615+ "schemes":[
616+ "http"
617+ ],
618+ "paths":{
619+ "/pet":{
620+ "post":{
621+ "tags":[
622+ "pet"
623+ ],
624+ "summary":"Add a new pet to the store",
625+ "description":"",
626+ "operationId":"addPet",
627+ "consumes":[
628+ "application/json",
629+ "application/xml"
630+ ],
631+ "produces":[
632+ "application/xml",
633+ "application/json"
634+ ],
635+ "parameters":[
636+ {
637+ "in":"body",
638+ "name":"body",
639+ "description":"Pet object that needs to be added to the store",
640+ "required":true,
641+ "schema":{
642+ "$ref":"#/definitions/Pet"
643+ }
644+ }
645+ ],
646+ "responses":{
647+ "405":{
648+ "description":"Invalid input"
649+ }
650+ },
651+ "security":[
652+ {
653+ "petstore_auth":[
654+ "write:pets",
655+ "read:pets"
656+ ]
657+ }
658+ ]
659+ },
660+ "put":{
661+ "tags":[
662+ "pet"
663+ ],
664+ "summary":"Update an existing pet",
665+ "description":"",
666+ "operationId":"updatePet",
667+ "consumes":[
668+ "application/json",
669+ "application/xml"
670+ ],
671+ "produces":[
672+ "application/xml",
673+ "application/json"
674+ ],
675+ "parameters":[
676+ {
677+ "in":"body",
678+ "name":"body",
679+ "description":"Pet object that needs to be added to the store",
680+ "required":true,
681+ "schema":{
682+ "$ref":"#/definitions/Pet"
683+ }
684+ }
685+ ],
686+ "responses":{
687+ "400":{
688+ "description":"Invalid ID supplied"
689+ },
690+ "404":{
691+ "description":"Pet not found"
692+ },
693+ "405":{
694+ "description":"Validation exception"
695+ }
696+ },
697+ "security":[
698+ {
699+ "petstore_auth":[
700+ "write:pets",
701+ "read:pets"
702+ ]
703+ }
704+ ]
705+ }
706+ },
707+ "/pet/findByStatus":{
708+ "get":{
709+ "tags":[
710+ "pet"
711+ ],
712+ "summary":"Finds Pets by status",
713+ "description":"Multiple status values can be provided with comma seperated strings",
714+ "operationId":"findPetsByStatus",
715+ "produces":[
716+ "application/xml",
717+ "application/json"
718+ ],
719+ "parameters":[
720+ {
721+ "name":"status",
722+ "in":"query",
723+ "description":"Status values that need to be considered for filter",
724+ "required":true,
725+ "type":"array",
726+ "items":{
727+ "type":"string",
728+ "enum":[
729+ "available",
730+ "pending",
731+ "sold"
732+ ],
733+ "default":"available"
734+ },
735+ "collectionFormat":"csv"
736+ }
737+ ],
738+ "responses":{
739+ "200":{
740+ "description":"successful operation",
741+ "schema":{
742+ "type":"array",
743+ "items":{
744+ "$ref":"#/definitions/Pet"
745+ }
746+ }
747+ },
748+ "400":{
749+ "description":"Invalid status value"
750+ }
751+ },
752+ "security":[
753+ {
754+ "petstore_auth":[
755+ "write:pets",
756+ "read:pets"
757+ ]
758+ }
759+ ]
760+ }
761+ },
762+ "/pet/findByTags":{
763+ "get":{
764+ "tags":[
765+ "pet"
766+ ],
767+ "summary":"Finds Pets by tags",
768+ "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",
769+ "operationId":"findPetsByTags",
770+ "produces":[
771+ "application/xml",
772+ "application/json"
773+ ],
774+ "parameters":[
775+ {
776+ "name":"tags",
777+ "in":"query",
778+ "description":"Tags to filter by",
779+ "required":true,
780+ "type":"array",
781+ "items":{
782+ "type":"string"
783+ },
784+ "collectionFormat":"csv"
785+ }
786+ ],
787+ "responses":{
788+ "200":{
789+ "description":"successful operation",
790+ "schema":{
791+ "type":"array",
792+ "items":{
793+ "$ref":"#/definitions/Pet"
794+ }
795+ }
796+ },
797+ "400":{
798+ "description":"Invalid tag value"
799+ }
800+ },
801+ "security":[
802+ {
803+ "petstore_auth":[
804+ "write:pets",
805+ "read:pets"
806+ ]
807+ }
808+ ]
809+ }
810+ },
811+ "/pet/{petId}":{
812+ "get":{
813+ "tags":[
814+ "pet"
815+ ],
816+ "summary":"Find pet by ID",
817+ "description":"Returns a single pet",
818+ "operationId":"getPetById",
819+ "produces":[
820+ "application/xml",
821+ "application/json"
822+ ],
823+ "parameters":[
824+ {
825+ "name":"petId",
826+ "in":"path",
827+ "description":"ID of pet to return",
828+ "required":true,
829+ "type":"integer",
830+ "format":"int64"
831+ }
832+ ],
833+ "responses":{
834+ "200":{
835+ "description":"successful operation",
836+ "schema":{
837+ "$ref":"#/definitions/Pet"
838+ }
839+ },
840+ "400":{
841+ "description":"Invalid ID supplied"
842+ },
843+ "404":{
844+ "description":"Pet not found"
845+ }
846+ },
847+ "security":[
848+ {
849+ "api_key": []
850+ }
851+ ]
852+ },
853+ "post":{
854+ "tags":[
855+ "pet"
856+ ],
857+ "summary":"Updates a pet in the store with form data",
858+ "description":"",
859+ "operationId":"updatePetWithForm",
860+ "consumes":[
861+ "application/x-www-form-urlencoded"
862+ ],
863+ "produces":[
864+ "application/xml",
865+ "application/json"
866+ ],
867+ "parameters":[
868+ {
869+ "name":"petId",
870+ "in":"path",
871+ "description":"ID of pet that needs to be updated",
872+ "required":true,
873+ "type":"integer",
874+ "format":"int64"
875+ },
876+ {
877+ "name":"name",
878+ "in":"formData",
879+ "description":"Updated name of the pet",
880+ "required":false,
881+ "type":"string"
882+ },
883+ {
884+ "name":"status",
885+ "in":"formData",
886+ "description":"Updated status of the pet",
887+ "required":false,
888+ "type":"string"
889+ }
890+ ],
891+ "responses":{
892+ "405":{
893+ "description":"Invalid input"
894+ }
895+ },
896+ "security":[
897+ {
898+ "petstore_auth":[
899+ "write:pets",
900+ "read:pets"
901+ ]
902+ }
903+ ]
904+ },
905+ "delete":{
906+ "tags":[
907+ "pet"
908+ ],
909+ "summary":"Deletes a pet",
910+ "description":"",
911+ "operationId":"deletePet",
912+ "produces":[
913+ "application/xml",
914+ "application/json"
915+ ],
916+ "parameters":[
917+ {
918+ "name":"api_key",
919+ "in":"header",
920+ "required":false,
921+ "type":"string"
922+ },
923+ {
924+ "name":"petId",
925+ "in":"path",
926+ "description":"Pet id to delete",
927+ "required":true,
928+ "type":"integer",
929+ "format":"int64"
930+ }
931+ ],
932+ "responses":{
933+ "400":{
934+ "description":"Invalid pet value"
935+ }
936+ },
937+ "security":[
938+ {
939+ "petstore_auth":[
940+ "write:pets",
941+ "read:pets"
942+ ]
943+ }
944+ ]
945+ }
946+ },
947+ "/pet/{petId}/uploadImage":{
948+ "post":{
949+ "tags":[
950+ "pet"
951+ ],
952+ "summary":"uploads an image",
953+ "description":"",
954+ "operationId":"uploadFile",
955+ "consumes":[
956+ "multipart/form-data"
957+ ],
958+ "produces":[
959+ "application/json"
960+ ],
961+ "parameters":[
962+ {
963+ "name":"petId",
964+ "in":"path",
965+ "description":"ID of pet to update",
966+ "required":true,
967+ "type":"integer",
968+ "format":"int64"
969+ },
970+ {
971+ "name":"additionalMetadata",
972+ "in":"formData",
973+ "description":"Additional data to pass to server",
974+ "required":false,
975+ "type":"string"
976+ },
977+ {
978+ "name":"file",
979+ "in":"formData",
980+ "description":"file to upload",
981+ "required":false,
982+ "type":"file"
983+ }
984+ ],
985+ "responses":{
986+ "200":{
987+ "description":"successful operation",
988+ "schema":{
989+ "$ref":"#/definitions/ApiResponse"
990+ }
991+ }
992+ },
993+ "security":[
994+ {
995+ "petstore_auth":[
996+ "write:pets",
997+ "read:pets"
998+ ]
999+ }
1000+ ]
1001+ }
1002+ },
1003+ "/store/inventory":{
1004+ "get":{
1005+ "tags":[
1006+ "store"
1007+ ],
1008+ "summary":"Returns pet inventories by status",
1009+ "description":"Returns a map of status codes to quantities",
1010+ "operationId":"getInventory",
1011+ "produces":[
1012+ "application/json"
1013+ ],
1014+ "parameters": [],
1015+ "responses":{
1016+ "200":{
1017+ "description":"successful operation",
1018+ "schema":{
1019+ "type":"object",
1020+ "additionalProperties":{
1021+ "type":"integer",
1022+ "format":"int32"
1023+ }
1024+ }
1025+ }
1026+ },
1027+ "security":[
1028+ {
1029+ "api_key": []
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+ "responses":{
1303+ "default":{
1304+ "description":"successful operation"
1305+ }
1306+ }
1307+ }
1308+ },
1309+ "/user/{username}":{
1310+ "get":{
1311+ "tags":[
1312+ "user"
1313+ ],
1314+ "summary":"Get user by user name",
1315+ "description":"",
1316+ "operationId":"getUserByName",
1317+ "produces":[
1318+ "application/xml",
1319+ "application/json"
1320+ ],
1321+ "parameters":[
1322+ {
1323+ "name":"username",
1324+ "in":"path",
1325+ "description":"The name that needs to be fetched. Use user1 for testing. ",
1326+ "required":true,
1327+ "type":"string"
1328+ }
1329+ ],
1330+ "responses":{
1331+ "200":{
1332+ "description":"successful operation",
1333+ "schema":{
1334+ "$ref":"#/definitions/User"
1335+ }
1336+ },
1337+ "400":{
1338+ "description":"Invalid username supplied"
1339+ },
1340+ "404":{
1341+ "description":"User not found"
1342+ }
1343+ }
1344+ },
1345+ "put":{
1346+ "tags":[
1347+ "user"
1348+ ],
1349+ "summary":"Updated user",
1350+ "description":"This can only be done by the logged in user.",
1351+ "operationId":"updateUser",
1352+ "produces":[
1353+ "application/xml",
1354+ "application/json"
1355+ ],
1356+ "parameters":[
1357+ {
1358+ "name":"username",
1359+ "in":"path",
1360+ "description":"name that need to be deleted",
1361+ "required":true,
1362+ "type":"string"
1363+ },
1364+ {
1365+ "in":"body",
1366+ "name":"body",
1367+ "description":"Updated user object",
1368+ "required":true,
1369+ "schema":{
1370+ "$ref":"#/definitions/User"
1371+ }
1372+ }
1373+ ],
1374+ "responses":{
1375+ "400":{
1376+ "description":"Invalid user supplied"
1377+ },
1378+ "404":{
1379+ "description":"User not found"
1380+ }
1381+ }
1382+ },
1383+ "delete":{
1384+ "tags":[
1385+ "user"
1386+ ],
1387+ "summary":"Delete user",
1388+ "description":"This can only be done by the logged in user.",
1389+ "operationId":"deleteUser",
1390+ "produces":[
1391+ "application/xml",
1392+ "application/json"
1393+ ],
1394+ "parameters":[
1395+ {
1396+ "name":"username",
1397+ "in":"path",
1398+ "description":"The name that needs to be deleted",
1399+ "required":true,
1400+ "type":"string"
1401+ }
1402+ ],
1403+ "responses":{
1404+ "400":{
1405+ "description":"Invalid username supplied"
1406+ },
1407+ "404":{
1408+ "description":"User not found"
1409+ }
1410+ }
1411+ }
1412+ }
1413+ },
1414+ "securityDefinitions":{
1415+ "petstore_auth":{
1416+ "type":"oauth2",
1417+ "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",
1418+ "flow":"implicit",
1419+ "scopes":{
1420+ "write:pets":"modify pets in your account",
1421+ "read:pets":"read your pets"
1422+ }
1423+ },
1424+ "api_key":{
1425+ "type":"apiKey",
1426+ "name":"api_key",
1427+ "in":"header"
1428+ }
1429+ },
1430+ "definitions":{
1431+ "Order":{
1432+ "type":"object",
1433+ "properties":{
1434+ "id":{
1435+ "type":"integer",
1436+ "format":"int64"
1437+ },
1438+ "petId":{
1439+ "type":"integer",
1440+ "format":"int64"
1441+ },
1442+ "quantity":{
1443+ "type":"integer",
1444+ "format":"int32"
1445+ },
1446+ "shipDate":{
1447+ "type":"string",
1448+ "format":"date-time"
1449+ },
1450+ "status":{
1451+ "type":"string",
1452+ "description":"Order Status",
1453+ "enum":[
1454+ "placed",
1455+ "approved",
1456+ "delivered"
1457+ ]
1458+ },
1459+ "complete":{
1460+ "type":"boolean",
1461+ "default":false
1462+ }
1463+ },
1464+ "xml":{
1465+ "name":"Order"
1466+ }
1467+ },
1468+ "Category":{
1469+ "type":"object",
1470+ "properties":{
1471+ "id":{
1472+ "type":"integer",
1473+ "format":"int64"
1474+ },
1475+ "name":{
1476+ "type":"string"
1477+ }
1478+ },
1479+ "xml":{
1480+ "name":"Category"
1481+ }
1482+ },
1483+ "User":{
1484+ "type":"object",
1485+ "properties":{
1486+ "id":{
1487+ "type":"integer",
1488+ "format":"int64"
1489+ },
1490+ "username":{
1491+ "type":"string"
1492+ },
1493+ "firstName":{
1494+ "type":"string"
1495+ },
1496+ "lastName":{
1497+ "type":"string"
1498+ },
1499+ "email":{
1500+ "type":"string"
1501+ },
1502+ "password":{
1503+ "type":"string"
1504+ },
1505+ "phone":{
1506+ "type":"string"
1507+ },
1508+ "userStatus":{
1509+ "type":"integer",
1510+ "format":"int32",
1511+ "description":"User Status"
1512+ }
1513+ },
1514+ "xml":{
1515+ "name":"User"
1516+ }
1517+ },
1518+ "Tag":{
1519+ "type":"object",
1520+ "properties":{
1521+ "id":{
1522+ "type":"integer",
1523+ "format":"int64"
1524+ },
1525+ "name":{
1526+ "type":"string"
1527+ }
1528+ },
1529+ "xml":{
1530+ "name":"Tag"
1531+ }
1532+ },
1533+ "Pet":{
1534+ "type":"object",
1535+ "required":[
1536+ "name",
1537+ "photoUrls"
1538+ ],
1539+ "properties":{
1540+ "id":{
1541+ "type":"integer",
1542+ "format":"int64"
1543+ },
1544+ "category":{
1545+ "$ref":"#/definitions/Category"
1546+ },
1547+ "name":{
1548+ "type":"string",
1549+ "example":"doggie"
1550+ },
1551+ "photoUrls":{
1552+ "type":"array",
1553+ "xml":{
1554+ "name":"photoUrl",
1555+ "wrapped":true
1556+ },
1557+ "items":{
1558+ "type":"string"
1559+ }
1560+ },
1561+ "tags":{
1562+ "type":"array",
1563+ "xml":{
1564+ "name":"tag",
1565+ "wrapped":true
1566+ },
1567+ "items":{
1568+ "$ref":"#/definitions/Tag"
1569+ }
1570+ },
1571+ "status":{
1572+ "type":"string",
1573+ "description":"pet status in the store",
1574+ "enum":[
1575+ "available",
1576+ "pending",
1577+ "sold"
1578+ ]
1579+ }
1580+ },
1581+ "xml":{
1582+ "name":"Pet"
1583+ }
1584+ },
1585+ "ApiResponse":{
1586+ "type":"object",
1587+ "properties":{
1588+ "code":{
1589+ "type":"integer",
1590+ "format":"int32"
1591+ },
1592+ "type":{
1593+ "type":"string"
1594+ },
1595+ "message":{
1596+ "type":"string"
1597+ }
1598+ }
1599+ }
1600+ },
1601+ "externalDocs":{
1602+ "description":"Find out more about Swagger",
1603+ "url":"http://swagger.io"
1604+ }
1605+}
1606+|]
test/DocTest.hsnew file+8
@@ -0,0 +1,8 @@
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'
8+ where doctest' files = doctest $ "-Iinclude/" : "-D__DOCTEST__" : files
test/SpecCommon.hs+11−8
@@ -1,22 +1,25 @@
11module SpecCommon where
22
33import Data.Aeson
4−import Data.ByteString.Builder (toLazyByteString)
54import qualified Data.Foldable as F
65import qualified Data.HashMap.Strict as HashMap
76import qualified Data.Vector as Vector
87
98import Test.Hspec
109
11−(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec
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+
18+(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec
1219x <=> js = do
1320 it "encodes correctly" $ do
1421 toJSON x `shouldBe` js
1522 it "decodes correctly" $ do
1623 fromJSON js `shouldBe` Success x
17− it "roundtrips: eitherDecode . encode" $ do
18− eitherDecode (encode x) `shouldBe` Right x
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
24+
25+
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