git.iko.soy/typeable/openapi3
on master help sign in
53 files changed+9041−5294
since splitsnapshots
unifiedsplit
.github/workflows/haskell-ci.yml+243 .gitignore+2 .travis.yml−79 CHANGELOG.md+248−1 LICENSE+1−1 README.md+14−10 Setup.hs+31 cabal.haskell-ci+11 cabal.project+4 examples/hackage.hs+44−32 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/Swagger/Declare.hs → src/Data/OpenApi/Declare.hs+83−9 src/Data/OpenApi/Internal.hs+1619 src/Data/OpenApi/Internal/AesonUtils.hs+313 src/Data/Swagger/Internal/ParamSchema.hs → src/Data/OpenApi/Internal/ParamSchema.hs+162−48 src/Data/OpenApi/Internal/Schema.hs+1126 src/Data/OpenApi/Internal/Schema/Validation.hs+536 src/Data/OpenApi/Internal/TypeShape.hs+56 src/Data/Swagger/Internal/Utils.hs → src/Data/OpenApi/Internal/Utils.hs+15−46 src/Data/OpenApi/Lens.hs+166 src/Data/OpenApi/Operation.hs+305 src/Data/OpenApi/Optics.hs+328 src/Data/Swagger/ParamSchema.hs → src/Data/OpenApi/ParamSchema.hs+9−6 src/Data/Swagger/Schema.hs → src/Data/OpenApi/Schema.hs+19−6 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/Swagger/Internal.hs−1171 src/Data/Swagger/Internal/Schema.hs−577 src/Data/Swagger/Lens.hs−165 src/Data/Swagger/Schema/Validation.hs−275 src/Data/Swagger/SchemaOptions.hs−37 stack-lts-2.yaml−5 stack.yaml+7−3 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+8−11 test/doctests.hs+12
.github/workflows/haskell-ci.ymlnew file+243
@@ -0,0 +1,243 @@
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,4 +1,6 @@
11dist
2+dist-newstyle
3+.ghc.environment.*
24cabal-dev
35*.o
46*.hi
.travis.ymldeleted−79
@@ -1,79 +0,0 @@
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+248−1
@@ -1,7 +1,254 @@
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+
12481.2.1
2249---
3250
4−* Minor change:
251+* Minor changes:
5252 * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.
6253
7254* Fixes:
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015, GetShopTV
1+Copyright (c) 2015-2017, GetShopTV
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without
README.md+14−10
@@ -1,19 +1,22 @@
1−# swagger2
1+# OpenApi 3
22
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)
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)
77
8−Swagger 2.0 data model.
8+OpenAPI 3.0 data model.
99
10−The original Swagger 2.0 specification is available at http://swagger.io/specification/.
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.
1114
1215## Usage
1316
14−This library is inteded to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them.
17+This library is intended to be used for decoding and encoding OpenApi 3.0.3 specifications as well as manipulating them.
1518
16−Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2).
19+Please refer to [haddock documentation](http://hackage.haskell.org/package/openapi3).
1720
1821Some examples can be found in [`examples/` directory](/examples).
1922
@@ -31,7 +34,8 @@ Many Swagger tools, including server and client code generation for many languag
3134
3235We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.
3336
34−Please report bugs via the [github issue tracker](https://github.com/GetShopTV/swagger2/issues).
37+Please report bugs via the [github issue tracker](https://github.com/biocad/openapi3/issues).
3538
3639*GetShopTV Team*
3740
41+*Biocad Team*
Setup.hs+31
@@ -1,2 +1,33 @@
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+
128import Distribution.Simple
29+
30+main :: IO ()
231main = defaultMain
32+
33+#endif
cabal.haskell-cinew file+11
@@ -0,0 +1,11 @@
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.projectnew file+4
@@ -0,0 +1,4 @@
1+packages: .
2+tests: true
3+
4+allow-newer: http-media:base
examples/hackage.hs+44−32
@@ -10,16 +10,31 @@ import Data.Proxy
1010import Data.Text (Text)
1111import GHC.Generics
1212
13−import Data.Swagger
14−import Data.Swagger.Declare
15−import Data.Swagger.Lens
13+import Data.OpenApi
14+import Data.OpenApi.Declare
15+import Data.OpenApi.Lens
16+import Data.OpenApi.Operation
1617
1718type Username = Text
1819
1920data UserSummary = UserSummary
2021 { summaryUsername :: Username
2122 , summaryUserid :: Int
22− } deriving (Generic, ToSchema)
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+
2338
2439type Group = Text
2540
@@ -32,39 +47,36 @@ data UserDetailed = UserDetailed
3247newtype Package = Package { packageName :: Text }
3348 deriving (Generic, ToSchema)
3449
35−hackageSwagger :: Swagger
36−hackageSwagger = spec & definitions .~ defs
50+hackageOpenApi :: OpenApi
51+hackageOpenApi = spec & components.schemas .~ defs
3752 where
38− (defs, spec) = runDeclare declareHackageSwagger mempty
53+ (defs, spec) = runDeclare declareHackageOpenApi mempty
3954
40−declareHackageSwagger :: Declare Definitions Swagger
41−declareHackageSwagger = do
55+declareHackageOpenApi :: Declare (Definitions Schema) OpenApi
56+declareHackageOpenApi = do
57+ -- param schemas
4258 let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)
43− userSummarySchemaRef <- declareSchemaRef (Proxy :: Proxy UserSummary)
44− userDetailedSchemaRef <- declareSchemaRef (Proxy :: Proxy UserDetailed)
45− packagesSchemaRef <- declareSchemaRef (Proxy :: Proxy [Package])
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+
4665 return $ mempty
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))))
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))
6678 ]
6779
6880main :: IO ()
69−main = putStrLn . read . show . encode $ hackageSwagger
81+main = putStrLn . read . show . encode $ hackageOpenApi
7082
hackage-docs.shnew file+78
@@ -0,0 +1,78 @@
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.hdeleted−8
@@ -1,8 +0,0 @@
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.cabalnew file+160
@@ -0,0 +1,160 @@
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.hsnew file+428
@@ -0,0 +1,428 @@
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.hsnew file+76
@@ -0,0 +1,76 @@
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/Swagger/Declare.hs → src/Data/OpenApi/Declare.hsrenamed+83−9
@@ -2,15 +2,33 @@
22{-# LANGUAGE FlexibleInstances #-}
33{-# LANGUAGE FunctionalDependencies #-}
44{-# LANGUAGE MultiParamTypeClasses #-}
5−module Data.Swagger.Declare where
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
613
714import Prelude ()
815import Prelude.Compat
916
1017import Control.Monad
18+import Control.Monad.Cont (ContT)
19+import Control.Monad.List (ListT)
20+import Control.Monad.Reader (ReaderT)
1121import 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
1231import Data.Functor.Identity
13−import Data.Monoid
1432
1533-- | A declare monad transformer parametrized by:
1634--
@@ -31,18 +49,18 @@ instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
3149 pure x = DeclareT (\_ -> pure (mempty, x))
3250 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
3351 ~(d', f) <- df d
34− ~(d'', x) <- dx (d <> d')
35− return (d' <> d'', f x)
52+ ~(d'', x) <- dx (mappend d d')
53+ return (mappend d' d'', f x)
3654
3755instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
3856 return x = DeclareT (\_ -> pure (mempty, x))
3957 DeclareT dx >>= f = DeclareT $ \d -> do
4058 ~(d', x) <- dx d
41− ~(d'', y) <- runDeclareT (f x) (d <> d')
42− return (d' <> d'', y)
59+ ~(d'', y) <- runDeclareT (f x) (mappend d d')
60+ return (mappend d' d'', y)
4361
4462instance Monoid d => MonadTrans (DeclareT d) where
45− lift m = DeclareT (\_ -> (,) mempty `liftM` m)
63+ lift m = DeclareT (\_ -> (,) mempty <$> m)
4664
4765-- |
4866-- Definitions of @declare@ and @look@ must satisfy the following laws:
@@ -71,6 +89,13 @@ instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) whe
7189 declare d = DeclareT (\_ -> return (d, ()))
7290 look = DeclareT (\d -> return (mempty, d))
7391
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+
7499-- | Retrieve a function of all the output so far.
75100looks :: MonadDeclare d m => (d -> a) -> m a
76101looks f = f <$> look
@@ -78,12 +103,12 @@ looks f = f <$> look
78103-- | Evaluate @'DeclareT' d m a@ computation,
79104-- ignoring new output @d@.
80105evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
81−evalDeclareT (DeclareT f) d = snd `liftM` f d
106+evalDeclareT (DeclareT f) d = snd <$> f d
82107
83108-- | Execute @'DeclateT' d m a@ computation,
84109-- ignoring result and only producing new output @d@.
85110execDeclareT :: Monad m => DeclareT d m a -> d -> m d
86−execDeclareT (DeclareT f) d = fst `liftM` f d
111+execDeclareT (DeclareT f) d = fst <$> f d
87112
88113-- | Evaluate @'DeclareT' d m a@ computation,
89114-- starting with empty output history.
@@ -119,3 +144,52 @@ execDeclare m = runIdentity . execDeclareT m
119144undeclare :: Monoid d => Declare d a -> a
120145undeclare = runIdentity . undeclareT
121146
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/OpenApi/Internal.hsnew file+1619
@@ -0,0 +1,1619 @@
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.hsnew file+313
@@ -0,0 +1,313 @@
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/Swagger/Internal/ParamSchema.hs → src/Data/OpenApi/Internal/ParamSchema.hsrenamed+162−48
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE DefaultSignatures #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
@@ -7,13 +7,18 @@
77{-# LANGUAGE PackageImports #-}
88{-# LANGUAGE PolyKinds #-}
99{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
1011{-# LANGUAGE TypeOperators #-}
1112{-# LANGUAGE TypeSynonymInstances #-}
12−#include "overlapping-compat.h"
13−module Data.Swagger.Internal.ParamSchema where
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
1419
1520import Control.Lens
16−import Data.Aeson
21+import Data.Aeson (ToJSON (..))
1722import Data.Proxy
1823import GHC.Generics
1924
@@ -22,16 +27,54 @@ import "unordered-containers" Data.HashSet (HashSet)
2227import Data.Monoid
2328import Data.Set (Set)
2429import Data.Scientific
30+import Data.Fixed (HasResolution(..), Fixed, Pico)
2531import qualified Data.Text as T
2632import qualified Data.Text.Lazy as TL
2733import 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)
2840import Data.Word
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'@.
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.
3578--
3679-- An example type and instance:
3780--
@@ -43,9 +86,9 @@ import Data.Swagger.SchemaOptions
4386-- data Direction = Up | Down
4487--
4588-- instance ToParamSchema Direction where
46−-- toParamSchema = mempty
47−-- & type_ .~ SwaggerString
48−-- & enum_ .~ [ \"Up\", \"Down\" ]
89+-- toParamSchema _ = mempty
90+-- & type_ ?~ OpenApiString
91+-- & enum_ ?~ [ \"Up\", \"Down\" ]
4992-- @
5093--
5194-- Instead of manually writing your @'ToParamSchema'@ instance you can
@@ -69,20 +112,28 @@ import Data.Swagger.SchemaOptions
69112class ToParamSchema a where
70113 -- | Convert a type into a plain parameter schema.
71114 --
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
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
76121 toParamSchema = genericToParamSchema defaultSchemaOptions
77122
78−instance OVERLAPPING_ ToParamSchema String where
79− toParamSchema _ = mempty & type_ .~ SwaggerString
123+instance {-# OVERLAPPING #-} ToParamSchema String where
124+ toParamSchema _ = mempty & type_ ?~ OpenApiString
80125
81126instance ToParamSchema Bool where
82− toParamSchema _ = mempty & type_ .~ SwaggerBoolean
127+ toParamSchema _ = mempty & type_ ?~ OpenApiBoolean
83128
84129instance ToParamSchema Integer where
85− toParamSchema _ = mempty & type_ .~ SwaggerInteger
130+ toParamSchema _ = mempty & type_ ?~ OpenApiInteger
131+
132+instance ToParamSchema Natural where
133+ toParamSchema _ = mempty
134+ & type_ ?~ OpenApiInteger
135+ & minimum_ ?~ 0
136+ & exclusiveMinimum ?~ False
86137
87138instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
88139instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
@@ -97,47 +148,66 @@ instance ToParamSchema Int64 where
97148instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral
98149instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral
99150instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral
100−instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral
101−instance ToParamSchema Word64 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"
102157
103158-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
104159--
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
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
108167toParamSchemaBoundedIntegral _ = mempty
109− & type_ .~ SwaggerInteger
168+ & type_ ?~ OpenApiInteger
110169 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
111170 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
112171
113172instance ToParamSchema Char where
114173 toParamSchema _ = mempty
115− & type_ .~ SwaggerString
174+ & type_ ?~ OpenApiString
116175 & maxLength ?~ 1
117176 & minLength ?~ 1
118177
119178instance ToParamSchema Scientific where
120− toParamSchema _ = mempty & type_ .~ SwaggerNumber
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))
121185
122186instance ToParamSchema Double where
123187 toParamSchema _ = mempty
124− & type_ .~ SwaggerNumber
188+ & type_ ?~ OpenApiNumber
125189 & format ?~ "double"
126190
127191instance ToParamSchema Float where
128192 toParamSchema _ = mempty
129− & type_ .~ SwaggerNumber
193+ & type_ ?~ OpenApiNumber
130194 & format ?~ "float"
131195
132−timeParamSchema :: String -> ParamSchema t
196+timeParamSchema :: String -> Schema
133197timeParamSchema fmt = mempty
134− & type_ .~ SwaggerString
198+ & type_ ?~ OpenApiString
135199 & format ?~ T.pack fmt
136200
137201-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
138202instance ToParamSchema Day where
139203 toParamSchema _ = timeParamSchema "date"
140204
205+-- |
206+-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
207+-- Just "hh:MM:ss"
208+instance ToParamSchema TimeOfDay where
209+ toParamSchema _ = timeParamSchema "hh:MM:ss"
210+
141211-- |
142212-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
143213-- Just "yyyy-mm-ddThh:MM:ss"
@@ -146,9 +216,9 @@ instance ToParamSchema LocalTime where
146216
147217-- |
148218-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format
149−-- Just "yyyy-mm-ddThh:MM:ss+hhMM"
219+-- Just "date-time"
150220instance ToParamSchema ZonedTime where
151− toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"
221+ toParamSchema _ = timeParamSchema "date-time"
152222
153223-- |
154224-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format
@@ -157,7 +227,7 @@ instance ToParamSchema UTCTime where
157227 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
158228
159229instance ToParamSchema NominalDiffTime where
160− toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)
230+ toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
161231
162232instance ToParamSchema T.Text where
163233 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
@@ -165,6 +235,24 @@ instance ToParamSchema T.Text where
165235instance ToParamSchema TL.Text where
166236 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
167237
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+
168256instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
169257instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
170258instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
@@ -173,10 +261,17 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to
173261instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
174262instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
175263
264+instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
265+
176266instance ToParamSchema a => ToParamSchema [a] where
177267 toParamSchema _ = mempty
178− & type_ .~ SwaggerArray
179− & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
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])
180275
181276instance ToParamSchema a => ToParamSchema (Set a) where
182277 toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
@@ -186,24 +281,40 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
186281 toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a))
187282
188283-- |
189−-- >>> encode $ toParamSchema (Proxy :: Proxy ())
190−-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
284+-- >>> BSL.putStrLn $ encodePretty $ toParamSchema (Proxy :: Proxy ())
285+-- {
286+-- "enum": [
287+-- "_"
288+-- ],
289+-- "type": "string"
290+-- }
191291instance ToParamSchema () where
192292 toParamSchema _ = mempty
193− & type_ .~ SwaggerString
293+ & type_ ?~ OpenApiString
194294 & enum_ ?~ ["_"]
195295
196−-- | A configurable generic @'ParamSchema'@ creator.
296+instance ToParamSchema UUID where
297+ toParamSchema _ = mempty
298+ & type_ ?~ OpenApiString
299+ & format ?~ "uuid"
300+
301+-- | A configurable generic @'Schema'@ creator.
197302--
198303-- >>> :set -XDeriveGeneric
199304-- >>> data Color = Red | Blue deriving Generic
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
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
203314genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
204315
205316class GToParamSchema (f :: * -> *) where
206− gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
317+ gtoParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema
207318
208319instance GToParamSchema f => GToParamSchema (D1 d f) where
209320 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
@@ -221,14 +332,14 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
221332 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
222333
223334class GEnumParamSchema (f :: * -> *) where
224− genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
335+ genumParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema
225336
226337instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
227338 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
228339
229340instance Constructor c => GEnumParamSchema (C1 c U1) where
230341 genumParamSchema opts _ s = s
231− & type_ .~ SwaggerString
342+ & type_ ?~ OpenApiString
232343 & enum_ %~ addEnumValue tag
233344 where
234345 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
@@ -238,3 +349,6 @@ instance Constructor c => GEnumParamSchema (C1 c U1) where
238349
239350data Proxy3 a b c = Proxy3
240351
352+-- $setup
353+-- >>> import Data.Aeson (encode)
354+-- >>> import Data.OpenApi.Internal.Utils
src/Data/OpenApi/Internal/Schema.hsnew file+1126
@@ -0,0 +1,1126 @@
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.hsnew file+536
@@ -0,0 +1,536 @@
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.hsnew file+56
@@ -0,0 +1,56 @@
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/Swagger/Internal/Utils.hs → src/Data/OpenApi/Internal/Utils.hsrenamed+15−46
@@ -4,28 +4,29 @@
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE RankNTypes #-}
66{-# LANGUAGE TypeOperators #-}
7−module Data.Swagger.Internal.Utils where
7+module Data.OpenApi.Internal.Utils where
88
99import Prelude ()
1010import Prelude.Compat
1111
12−import Control.Arrow (first)
13−import Control.Applicative
1412import Control.Lens ((&), (%~))
1513import Control.Lens.TH
1614import Data.Aeson
1715import 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
2325import Data.Map (Map)
24−import Data.Monoid
26+import Data.Set (Set)
2527import Data.Text (Text)
2628import GHC.Generics
2729import Language.Haskell.TH (mkName)
28−import Text.Read (readMaybe)
2930
3031swaggerFieldRules :: LensRules
3132swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
@@ -44,6 +45,8 @@ swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
4445 fixName' "minimum" = "minimum_" -- Prelude conflict
4546 fixName' "maximum" = "maximum_" -- Prelude conflict
4647 fixName' "enum" = "enum_" -- Control.Lens conflict
48+ fixName' "head" = "head_" -- Prelude conflict
49+ fixName' "not" = "not_" -- Prelude conflict
4750 fixName' n = n
4851
4952gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
@@ -51,17 +54,6 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of
5154 Just x -> z x
5255 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
5356
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−
6557jsonPrefix :: String -> Options
6658jsonPrefix prefix = defaultOptions
6759 { fieldLabelModifier = modifier . drop 1
@@ -83,40 +75,10 @@ parseOneOf xs js =
8375 where
8476 ys = zip (map toJSON xs) xs
8577
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−
11278(<+>) :: Value -> Value -> Value
11379Object x <+> Object y = Object (x <> y)
11480_ <+> _ = error "<+>: merging non-objects"
11581
116−withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
117−withDefaults parser defs js@(Object _) = parser (js <+> object defs)
118−withDefaults _ _ _ = empty
119−
12082genericMempty :: (Generic a, GMonoid (Rep a)) => a
12183genericMempty = to gmempty
12284
@@ -152,12 +114,17 @@ class SwaggerMonoid m where
152114 swaggerMappend = mappend
153115
154116instance SwaggerMonoid [a]
117+instance Ord a => SwaggerMonoid (Set a)
155118instance Ord k => SwaggerMonoid (Map k v)
156119
157120instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
158121 swaggerMempty = mempty
159122 swaggerMappend = HashMap.unionWith (\_old new -> new)
160123
124+instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where
125+ swaggerMempty = mempty
126+ swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)
127+
161128instance SwaggerMonoid Text where
162129 swaggerMempty = mempty
163130 swaggerMappend x "" = x
@@ -168,3 +135,5 @@ instance SwaggerMonoid (Maybe a) where
168135 swaggerMappend x Nothing = x
169136 swaggerMappend _ y = y
170137
138+encodePretty :: ToJSON a => a -> BSL.ByteString
139+encodePretty = P.encodePretty' $ P.defConfig { P.confCompare = P.compare }
src/Data/OpenApi/Lens.hsnew file+166
@@ -0,0 +1,166 @@
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.hsnew file+305
@@ -0,0 +1,305 @@
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.hsnew file+328
@@ -0,0 +1,328 @@
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/Swagger/ParamSchema.hs → src/Data/OpenApi/ParamSchema.hsrenamed+9−6
@@ -1,12 +1,10 @@
11-- |
2−-- Module: Data.Swagger.ParamSchema
3−-- Copyright: (c) 2015 GetShopTV
4−-- License: BSD3
2+-- Module: Data.OpenApi.ParamSchema
53-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
64-- Stability: experimental
75--
86-- Types and functions for working with Swagger parameter schema.
9−module Data.Swagger.ParamSchema (
7+module Data.OpenApi.ParamSchema (
108 -- * Encoding
119 ToParamSchema(..),
1210
@@ -14,10 +12,15 @@ module Data.Swagger.ParamSchema (
1412 genericToParamSchema,
1513 toParamSchemaBoundedIntegral,
1614
15+ -- * Schema templates
16+ passwordSchema,
17+ binarySchema,
18+ byteSchema,
19+
1720 -- * Generic encoding configuration
1821 SchemaOptions(..),
1922 defaultSchemaOptions,
2023) where
2124
22−import Data.Swagger.Internal.ParamSchema
23−import Data.Swagger.SchemaOptions
25+import Data.OpenApi.Internal.ParamSchema
26+import Data.OpenApi.SchemaOptions
src/Data/Swagger/Schema.hs → src/Data/OpenApi/Schema.hsrenamed+19−6
@@ -1,12 +1,10 @@
11-- |
2−-- Module: Data.Swagger.Schema
3−-- Copyright: (c) 2015 GetShopTV
4−-- License: BSD3
2+-- Module: Data.OpenApi.Schema
53-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
64-- Stability: experimental
75--
86-- Types and functions for working with Swagger schema.
9−module Data.Swagger.Schema (
7+module Data.OpenApi.Schema (
108 -- * Encoding
119 ToSchema(..),
1210 declareSchema,
@@ -19,11 +17,25 @@ module Data.Swagger.Schema (
1917 -- * Generic schema encoding
2018 genericDeclareNamedSchema,
2119 genericDeclareSchema,
20+ genericDeclareNamedSchemaNewtype,
21+ genericNameSchema,
22+
23+ -- ** 'Bounded' 'Integral'
2224 genericToNamedSchemaBoundedIntegral,
2325 toSchemaBoundedIntegral,
26+
27+ -- ** 'Bounded' 'Enum' key mappings
28+ declareSchemaBoundedEnumKeyMapping,
29+ toSchemaBoundedEnumKeyMapping,
30+
31+ -- ** Reusing 'ToParamSchema'
2432 paramSchemaToNamedSchema,
2533 paramSchemaToSchema,
2634
35+ -- * Sketching @'Schema'@s using @'ToJSON'@
36+ sketchSchema,
37+ sketchStrictSchema,
38+
2739 -- * Inlining @'Schema'@s
2840 inlineNonRecursiveSchemas,
2941 inlineAllSchemas,
@@ -33,7 +45,8 @@ module Data.Swagger.Schema (
3345 -- * Generic encoding configuration
3446 SchemaOptions(..),
3547 defaultSchemaOptions,
48+ fromAesonOptions,
3649) where
3750
38−import Data.Swagger.Internal.Schema
39−import Data.Swagger.SchemaOptions
51+import Data.OpenApi.Internal.Schema
52+import Data.OpenApi.SchemaOptions
src/Data/OpenApi/Schema/Generator.hsnew file+117
@@ -0,0 +1,117 @@
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.hsnew file+90
@@ -0,0 +1,90 @@
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.hsnew file+76
@@ -0,0 +1,76 @@
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.hsdeleted−259
@@ -1,259 +0,0 @@
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/Swagger/Internal.hsdeleted−1171
@@ -1,1171 +0,0 @@
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/Swagger/Internal/Schema.hsdeleted−577
@@ -1,577 +0,0 @@
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/Swagger/Lens.hsdeleted−165
@@ -1,165 +0,0 @@
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/Swagger/Schema/Validation.hsdeleted−275
@@ -1,275 +0,0 @@
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.hsdeleted−37
@@ -1,37 +0,0 @@
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.yamldeleted−5
@@ -1,5 +0,0 @@
1−flags: {}
2−packages:
3−- '.'
4−extra-deps: []
5−resolver: lts-2.22
stack.yaml+7−3
@@ -1,5 +1,9 @@
1−flags: {}
1+resolver: lts-16.31
22packages:
33- '.'
4−extra-deps: []
5−resolver: nightly-2016-01-26
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
swagger2.cabaldeleted−93
@@ -1,93 +0,0 @@
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.hsnew file+1042
@@ -0,0 +1,1042 @@
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.hsnew file+39
@@ -0,0 +1,39 @@
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.hsnew file+168
@@ -0,0 +1,168 @@
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.hsnew file+324
@@ -0,0 +1,324 @@
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.hsnew file+119
@@ -0,0 +1,119 @@
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.hsnew file+962
@@ -0,0 +1,962 @@
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.hsdeleted−114
@@ -1,114 +0,0 @@
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.hsdeleted−122
@@ -1,122 +0,0 @@
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.hsdeleted−602
@@ -1,602 +0,0 @@
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.hsdeleted−1606
@@ -1,1606 +0,0 @@
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.hsdeleted−8
@@ -1,8 +0,0 @@
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+8−11
@@ -1,25 +1,22 @@
11module SpecCommon where
22
33import Data.Aeson
4+import Data.ByteString.Builder (toLazyByteString)
45import qualified Data.Foldable as F
56import qualified Data.HashMap.Strict as HashMap
67import qualified Data.Vector as Vector
78
89import Test.Hspec
910
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
11+(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a, HasCallStack) => a -> Value -> Spec
1912x <=> js = do
2013 it "encodes correctly" $ do
2114 toJSON x `shouldBe` js
2215 it "decodes correctly" $ do
2316 fromJSON js `shouldBe` Success x
24−
25−
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
test/doctests.hsnew file+12
@@ -0,0 +1,12 @@
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