git.iko.soy/typeable/swagger2
on ee1ebb7 help sign in
5470313
swap
0 ahead, 297 behind
39 files changed+1380−5399
since splitsnapshots
unifiedsplit
.ghci−2 .gitignore−2 .travis.yml+34−155 CHANGELOG.md+1−186 LICENSE+1−1 README.md+1−3 Setup.hs−31 cabal.project−2 examples/hackage.hs+24−40 hackage-docs.sh−78 include/overlapping-compat.h−8 src/Data/Swagger.hs+11−101 src/Data/Swagger/Declare.hs+10−91 src/Data/Swagger/Internal.hs+146−396 src/Data/Swagger/Internal/AesonUtils.hs−346 src/Data/Swagger/Internal/ParamSchema.hs+24−123 src/Data/Swagger/Internal/Schema.hs+90−403 src/Data/Swagger/Internal/Schema/Validation.hs−511 src/Data/Swagger/Internal/TypeShape.hs−66 src/Data/Swagger/Internal/Utils.hs+47−13 src/Data/Swagger/Lens.hs+23−57 src/Data/Swagger/Operation.hs−193 src/Data/Swagger/Optics.hs−597 src/Data/Swagger/ParamSchema.hs+2−5 src/Data/Swagger/Schema.hs+2−24 src/Data/Swagger/Schema/Generator.hs−114 src/Data/Swagger/Schema/Validation.hs−90 src/Data/Swagger/SchemaOptions.hs−35 stack.yaml+2−6 swagger2.cabal+34−107 test/Data/Swagger/CommonTestTypes.hs−679 test/Data/Swagger/ParamSchemaSpec.hs+82−10 test/Data/Swagger/Schema/GeneratorSpec.hs−168 test/Data/Swagger/Schema/ValidationSpec.hs−278 test/Data/Swagger/SchemaSpec.hs+504−32 test/Data/SwaggerSpec.hs+333−427 test/DocTest.hs+7 test/SpecCommon.hs+2−7 test/doctests.hs−12
.ghcideleted−2
@@ -1,2 +0,0 @@
1−:set -itest -isrc -optP-include -optP.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/autogen/cabal_macros.h -optP-I -optPinclude
2−:set -hide-package base-compat-0.10.4
.gitignore−2
@@ -1,6 +1,4 @@
11dist
2−dist-newstyle
3−.ghc.environment.*
42cabal-dev
53*.o
64*.hi
.travis.yml+34−155
@@ -1,162 +1,41 @@
1−# This Travis job script has been generated by a script via
2−#
3−# haskell-ci '--branches' 'master' '--haddock-jobs=>=8.4' '--output' '.travis.yml' 'swagger2.cabal'
4−#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.5.20191020
8−#
91language: c
10−dist: xenial
11−git:
12− # whether to recursively clone submodules
13− submodules: false
14−branches:
15− only:
16− - master
17−cache:
18− directories:
19− - $HOME/.cabal/packages
20− - $HOME/.cabal/store
21−before_cache:
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
23− # remove files that are regenerated by 'cabal update'
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
27− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
28− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
29− - rm -rfv $CABALHOME/packages/head.hackage
2+
3+# explicitly request container-based infrastructure
4+sudo: false
5+
306matrix:
317 include:
32− - compiler: ghc-8.8.1
33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
34− - compiler: ghc-8.6.5
35− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
36− - compiler: ghc-8.4.4
37− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
38− - compiler: ghc-8.2.2
39− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
40− - compiler: ghc-8.0.2
41− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
8+ - env: CABALVER=1.18 GHCVER=7.8.4 HAPPYVER=1.19.4
9+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.4], sources: [hvr-ghc]}}
10+ - env: CABALVER=1.22 GHCVER=7.10.1 HAPPYVER=1.19.5
11+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5],sources: [hvr-ghc]}}
12+ - env: CABALVER=head GHCVER=head HAPPYVER=head
13+ addons: {apt: {packages: [cabal-install-head,ghc-head,happy-head], sources: [hvr-ghc]}}
14+
15+ allow_failures:
16+ - env: CABALVER=1.18 GHCVER=7.8.4 HAPPYVER=1.19.4
17+ - env: CABALVER=head GHCVER=head HAPPYVER=head
18+
4219before_install:
43− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
44− - WITHCOMPILER="-w $HC"
45− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
46− - HCPKG="$HC-pkg"
47− - unset CC
48− - CABAL=/opt/ghc/bin/cabal
49− - CABALHOME=$HOME/.cabal
50− - export PATH="$CABALHOME/bin:$PATH"
51− - TOP=$(pwd)
52− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
53− - echo $HCNUMVER
54− - CABAL="$CABAL -vnormal+nowrap+markoutput"
55− - set -o pipefail
56− - |
57− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
58− echo 'BEGIN { state = "output"; }' >> .colorful.awk
59− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
60− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
61− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
62− echo ' if (state == "cabal") {' >> .colorful.awk
63− echo ' print blue($0)' >> .colorful.awk
64− echo ' } else {' >> .colorful.awk
65− echo ' print $0' >> .colorful.awk
66− echo ' }' >> .colorful.awk
67− echo '}' >> .colorful.awk
68− - cat .colorful.awk
69− - |
70− color_cabal_output () {
71− awk -f $TOP/.colorful.awk
72− }
73− - echo text | color_cabal_output
20+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH:/opt/happy/$HAPPYVER/bin
21+
7422install:
75− - ${CABAL} --version
76− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
77− - TEST=--enable-tests
78− - BENCH=--enable-benchmarks
79− - HEADHACKAGE=false
80− - rm -f $CABALHOME/config
81− - |
82− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
83− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
84− echo "write-ghc-environment-files: always" >> $CABALHOME/config
85− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
86− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
87− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
88− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
89− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
90− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
91− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
92− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
93− echo "install-dirs user" >> $CABALHOME/config
94− echo " prefix: $CABALHOME" >> $CABALHOME/config
95− echo "repository hackage.haskell.org" >> $CABALHOME/config
96− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
97− echo " secure: True" >> $CABALHOME/config
98− echo " key-threshold: 3" >> $CABALHOME/config
99− echo " root-keys:" >> $CABALHOME/config
100− echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config
101− echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config
102− echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config
103− echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config
104− echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config
105− - |
106− echo "program-default-options" >> $CABALHOME/config
107− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
108− - cat $CABALHOME/config
109− - rm -fv cabal.project cabal.project.local cabal.project.freeze
110− - travis_retry ${CABAL} v2-update -v
111− # Generate cabal.project
112− - rm -rf cabal.project cabal.project.local cabal.project.freeze
113− - touch cabal.project
114− - |
115− echo "packages: ." >> cabal.project
116− - |
117− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
118− - cat cabal.project || true
119− - cat cabal.project.local || true
120− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
121− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
122− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
123− - rm cabal.project.freeze
124− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output
125− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
23+ - cabal --version
24+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
25+ - travis_retry cabal update
26+ - cabal install --only-dependencies --enable-tests --enable-benchmarks
27+
28+# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
12629script:
127− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
128− # Packaging...
129− - ${CABAL} v2-sdist all | color_cabal_output
130− # Unpacking...
131− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
132− - cd ${DISTDIR} || false
133− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
134− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
135− - PKGDIR_swagger2="$(find . -maxdepth 1 -type d -regex '.*/swagger2-[0-9.]*')"
136− # Generate cabal.project
137− - rm -rf cabal.project cabal.project.local cabal.project.freeze
138− - touch cabal.project
139− - |
140− echo "packages: ${PKGDIR_swagger2}" >> cabal.project
141− - |
142− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
143− - cat cabal.project || true
144− - cat cabal.project.local || true
145− # Building...
146− # this builds all libraries and executables (without tests/benchmarks)
147− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
148− # Building with tests and benchmarks...
149− # build & run tests, build benchmarks
150− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
151− # Testing...
152− - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
153− # cabal check...
154− - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check)
155− # haddock...
156− - if [ $HCNUMVER -ge 80400 ] ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi
157− # Building without installed constraints for packages in global-db...
158− - rm -f cabal.project.local
159− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
30+ - if [ -f configure.ac ]; then autoreconf -i; fi
31+ - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
32+ - cabal build --ghc-options="-O0" # this builds all libraries and executables (including tests/benchmarks)
33+ - cabal test
34+ - cabal check
35+ - cabal sdist # tests that a source-distribution can be generated
16036
161−# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])
162−# EOF
37+# Check that the resulting source distribution can be built & installed.
38+# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
39+# `cabal install --force-reinstalls dist/*-*.tar.gz`
40+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
41+ (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
CHANGELOG.md+1−186
@@ -1,192 +1,7 @@
1−2.5
2−---
3−
4−Highlights:
5−- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));
6−- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));
7−- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));
8−
9−Fixes and minor changes:
10−- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));
11−- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));
12−- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));
13−
14−2.4
15−---
16−
17−- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5
18−- Tags aren't sorted
19− (see [#165](https://github.com/GetShopTV/swagger2/issues/165))
20−- Schema type is optional
21− (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))
22−- Take concrete 'Proxy' as argument
23− (see [#180](https://github.com/GetShopTV/swagger2/pull/180))
24−- GHC-8.8 preparations
25−
26−2.3.1.1
27−-------
28−
29−- Allow `network-3.0`
30−
31−2.3.1
32−-----
33−
34−- Add a quickcheck generator for aeson Values that match a swagger schema
35− (see [#162](https://github.com/GetShopTV/swagger2/pull/162))
36−- Add `ToParamSchema` instance for `SetCookie`
37− (see [#173](https://github.com/GetShopTV/swagger2/pull/173))
38−- Make nullary schemas valid
39− (see [#168](https://github.com/GetShopTV/swagger2/pull/168))
40−
41−2.3.0.1
42−-------
43−
44−- Support GHC-8.6
45−
46−2.3
47−---
48−
49−Major changes:
50−
51−- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));
52−- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));
53−
54−Dependencies and CI:
55−
56−- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));
57−- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));
58−- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));
59−- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));
60−
61−2.2.2
62−-----
63−
64−* Add `ToSchema Version` instance
65−* Use base-compat-batteries (0.10)
66−* PVP bounds
67−
68−2.2.1
69−-----
70−
71−* Add `Semigroup` instances
72−* GHC-8.4 compatibility
73−* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141))
74−* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142))
75−* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139))
76−* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132))
77−
78−2.2
79−---
80−
81−* Treat unknown properties as validation errors in `validateToJSON` (see [#126](https://github.com/GetShopTV/swagger2/pull/126));
82−* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes (see [#126](https://github.com/GetShopTV/swagger2/pull/126));
83−* Add more `Schema` helpers (see [#126](https://github.com/GetShopTV/swagger2/pull/126)):
84− * `genericNameSchema` — to give a custom schema `Generic`-based name;
85− * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s;
86− * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys;
87−* Add a few tests with invalid `Schema`.
88−
89−2.1.6
90−-----
91−
92−* 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));
93−* Fix instance for `NominalDiffTime` (see [#121](https://github.com/GetShopTV/swagger2/pull/121));
94−* Fix build for `aeson-1.2.2.0` (see [#125](https://github.com/GetShopTV/swagger2/pull/125)).
95−
96−2.1.5
97−-----
98−
99−* Type error by default when deriving Generic-based instances for mixed sum types (see [#118](https://github.com/GetShopTV/swagger2/pull/118));
100−* Adjust `allOf` to accept referenced schemas (see [#119](https://github.com/GetShopTV/swagger2/issues/119));
101−* Add instances for `Identity` (see [#116](https://github.com/GetShopTV/swagger2/pull/116));
102−* Add Gitter chat badge (see [#114](https://github.com/GetShopTV/swagger2/pull/114)).
103−
104−2.1.4.1
105−-------
106−
107−* 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));
108−* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105));
109−* Allow `generics-sop-0.3` (see [#102](https://github.com/GetShopTV/swagger2/pull/102));
110−* Fix `ToSchema` example in docs (see [#104](https://github.com/GetShopTV/swagger2/pull/104)).
111−
112−2.1.4
113−-----
114−
115−* Add `liftDeclare` (see [#100](https://github.com/GetShopTV/swagger2/pull/100));
116−* Add `MonadDeclare` instances for all monad transformers (see [#100](https://github.com/GetShopTV/swagger2/pull/100)).
117−
118−2.1.3
119−-----
120−
121−* 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)).
122−* 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))
123−* Improve documentation for generic sum type instance derivation (see [#75](https://github.com/GetShopTV/swagger2/pull/75))
124−* Compile warning free (see [#82](https://github.com/GetShopTV/swagger2/pull/82))
125−
126−2.1.2.1
127−-------
128−
129−* Bug fix previous release
130−
131−2.1.2
132−---
133−
134−* Minor changes:
135− * Support `aeson-1.0.0.0` (see [#70](https://github.com/GetShopTV/swagger2/pull/70)).
136−
137−2.1.1
138−---
139−
140−* Minor changes:
141− * Proper `Schema` examples for `Char`, `Day`, `LocalTime`, `ZonedTime` and `UTCTime`.
142−
143−2.1
144−---
145−
146−* Major changes:
147− * Use `InsOrdHashMap` to preserve insertion order for endpoints and definitions (see [#56](https://github.com/GetShopTV/swagger2/pull/56));
148− * Add support for GHC 8.0 (see [#65](https://github.com/GetShopTV/swagger2/pull/65)).
149−
150−2.0.2
151−---
152−
153−* Fixes:
154− * Fix `additionalProperties` to allow references;
155− * Fix `ToSchema` instances for `Map` and `HashMap` (prevent infinite recursion for recursive values).
156−
157−2.0.1
158−---
159−
160−* Fixes:
161− * Re-export `Pattern` synonym from `Data.Swagger`;
162− * Documentation fixes.
163−
164−2.0
165−---
166−
167−* Major changes:
168− * GHC 7.8 support (see [#49](https://github.com/GetShopTV/swagger2/pull/49));
169− * Switch to classy field lenses (see [#41](https://github.com/GetShopTV/swagger2/pull/41));
170− * Add `Data.Swagger.Schema.Validation` (see [#18](https://github.com/GetShopTV/swagger2/pull/18));
171− * Add `Data.Swagger.Operation` with helpers (see [#50](https://github.com/GetShopTV/swagger2/pull/50));
172− * Add `IsString` instances for some types (see [#47](https://github.com/GetShopTV/swagger2/pull/47));
173− * Add helpers to sketch `Schema` from JSON (see [#48](https://github.com/GetShopTV/swagger2/pull/48)).
174−
175−* Minor changes:
176− * Make `NamedSchema` a `data` rather than `type` (see [#42](https://github.com/GetShopTV/swagger2/pull/42));
177− * Change `Definitions` to `Definitions Schema`;
178− * Add schema templates for `"binary"`, `"byte"` and `"password"` formats (see [63ed597](https://github.com/GetShopTV/swagger2/commit/63ed59736dc4f942f0e2a7d668d7cee513fa9eaf));
179− * Add `Monoid` instance for `Contact`;
180− * Change `tags` to be `Set` rather than list.
181−
182−* Fixes:
183− * Fix schema for `()` and nullary constructors (see [ab65c4a](https://github.com/GetShopTV/swagger2/commit/ab65c4a48253c34f8a88221a53dc97bf5e6e8d29));
184− * Fix `Operation` `FromJSON` instance to allow missing `tags` and `parameters` properties.
185−
18611.2.1
1872---
1883
189−* Minor changes:
4+* Minor change:
1905 * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.
1916
1927* Fixes:
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015-2017, GetShopTV
1+Copyright (c) 2015, GetShopTV
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without
README.md+1−3
@@ -1,7 +1,5 @@
11# swagger2
22
3−[![Join the chat at https://gitter.im/haskell-swagger2/Lobby](https://badges.gitter.im/haskell-swagger2/Lobby.svg)](https://gitter.im/haskell-swagger2/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
4−
53[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
64[![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)
75[![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2)
@@ -13,7 +11,7 @@ The original Swagger 2.0 specification is available at http://swagger.io/specifi
1311
1412## Usage
1513
16−This library is intended to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them.
14+This library is inteded to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them.
1715
1816Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2).
1917
Setup.hs−31
@@ -1,33 +1,2 @@
1−{-# LANGUAGE CPP #-}
2−{-# OPTIONS_GHC -Wall #-}
3−module Main (main) where
4−
5−#ifndef MIN_VERSION_cabal_doctest
6−#define MIN_VERSION_cabal_doctest(x,y,z) 0
7−#endif
8−
9−#if MIN_VERSION_cabal_doctest(1,0,0)
10−
11−import Distribution.Extra.Doctest ( defaultMainWithDoctests )
12−main :: IO ()
13−main = defaultMainWithDoctests "doctests"
14−
15−#else
16−
17−#ifdef MIN_VERSION_Cabal
18−-- If the macro is defined, we have new cabal-install,
19−-- but for some reason we don't have cabal-doctest in package-db
20−--
21−-- Probably we are running cabal sdist, when otherwise using new-build
22−-- workflow
23−#warning You are configuring this package without cabal-doctest installed. \
24− The doctests test-suite will not work as a result. \
25− To fix this, install cabal-doctest before configuring.
26−#endif
27−
281import Distribution.Simple
29−
30−main :: IO ()
312main = defaultMain
32−
33−#endif
cabal.projectdeleted−2
@@ -1,2 +0,0 @@
1−packages: .
2−tests: true
examples/hackage.hs+24−40
@@ -13,28 +13,13 @@ import GHC.Generics
1313import Data.Swagger
1414import Data.Swagger.Declare
1515import Data.Swagger.Lens
16−import Data.Swagger.Operation
1716
1817type Username = Text
1918
2019data UserSummary = UserSummary
2120 { summaryUsername :: Username
2221 , summaryUserid :: Int
23− } deriving (Generic)
24−
25−instance ToSchema UserSummary where
26− declareNamedSchema _ = do
27− usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
28− useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
29− return $ NamedSchema (Just "UserSummary") $ mempty
30− & type_ ?~ SwaggerObject
31− & properties .~
32− [ ("summaryUsername", usernameSchema )
33− , ("summaryUserid" , useridSchema )
34− ]
35− & required .~ [ "summaryUsername"
36− , "summaryUserid" ]
37−
22+ } deriving (Generic, ToSchema)
3823
3924type Group = Text
4025
@@ -52,33 +37,32 @@ hackageSwagger = spec & definitions .~ defs
5237 where
5338 (defs, spec) = runDeclare declareHackageSwagger mempty
5439
55−declareHackageSwagger :: Declare (Definitions Schema) Swagger
40+declareHackageSwagger :: Declare Definitions Swagger
5641declareHackageSwagger = do
57− -- param schemas
5842 let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)
59−
60− -- responses
61− userSummaryResponse <- declareResponse (Proxy :: Proxy UserSummary)
62− userDetailedResponse <- declareResponse (Proxy :: Proxy UserDetailed)
63− packagesResponse <- declareResponse (Proxy :: Proxy [Package])
64−
43+ userSummarySchemaRef <- declareSchemaRef (Proxy :: Proxy UserSummary)
44+ userDetailedSchemaRef <- declareSchemaRef (Proxy :: Proxy UserDetailed)
45+ packagesSchemaRef <- declareSchemaRef (Proxy :: Proxy [Package])
6546 return $ mempty
66− & paths .~
67− [ ("/users", mempty & get ?~ (mempty
68− & produces ?~ MimeList ["application/json"]
69− & at 200 ?~ Inline userSummaryResponse))
70− , ("/user/{username}", mempty & get ?~ (mempty
71− & produces ?~ MimeList ["application/json"]
72− & parameters .~ [ Inline $ mempty
73− & name .~ "username"
74− & required ?~ True
75− & schema .~ ParamOther (mempty
76− & in_ .~ ParamPath
77− & paramSchema .~ usernameParamSchema) ]
78− & at 200 ?~ Inline userDetailedResponse))
79− , ("/packages", mempty & get ?~ (mempty
80− & produces ?~ MimeList ["application/json"]
81− & at 200 ?~ Inline packagesResponse))
47+ & paths.pathsMap .~
48+ [ ("/users", mempty & pathItemGet ?~ (mempty
49+ & operationProduces ?~ MimeList ["application/json"]
50+ & operationResponses .~ (mempty
51+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ userSummarySchemaRef))))
52+ , ("/user/{username}", mempty & pathItemGet ?~ (mempty
53+ & operationProduces ?~ MimeList ["application/json"]
54+ & operationParameters .~ [ Inline $ mempty
55+ & paramName .~ "username"
56+ & paramRequired ?~ True
57+ & paramSchema .~ ParamOther (mempty
58+ & paramOtherSchemaIn .~ ParamPath
59+ & paramOtherSchemaParamSchema .~ usernameParamSchema) ]
60+ & operationResponses .~ (mempty
61+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ userDetailedSchemaRef))))
62+ , ("/packages", mempty & pathItemGet ?~ (mempty
63+ & operationProduces ?~ MimeList ["application/json"]
64+ & operationResponses .~ (mempty
65+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ packagesSchemaRef))))
8266 ]
8367
8468main :: IO ()
hackage-docs.shdeleted−78
@@ -1,78 +0,0 @@
1−#!/bin/bash
2−set -e
3−
4−# This if stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh
5−
6−if [ "$#" -ne 1 ]; then
7− echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
8− exit 1
9−fi
10−
11−user=$1
12−
13−cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
14−if [ ! -f "$cabal_file" ]; then
15− echo "Run this script in the top-level package directory"
16− exit 1
17−fi
18−
19−pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
20−ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
21−
22−if [ -z "$pkg" ]; then
23− echo "Unable to determine package name"
24− exit 1
25−fi
26−
27−if [ -z "$ver" ]; then
28− echo "Unable to determine package version"
29− exit 1
30−fi
31−
32−echo "Detected package: $pkg-$ver"
33−
34−dir=$(mktemp -d build-docs.XXXXXX)
35−trap 'rm -r "$dir"' EXIT
36−
37−export PATH=$(stack path --bin-path)
38−
39−ghc --version
40−cabal --version
41−stack --version
42−
43−if haddock --hyperlinked-source >/dev/null
44−then
45− echo "Using fancy hyperlinked source"
46− HYPERLINK_FLAG="--haddock-option=--hyperlinked-source"
47−else
48− echo "Using boring hyperlinked source"
49− HYPERLINK_FLAG="--hyperlink-source"
50−fi
51−
52−# Cabal dist in temporary location
53−builddir=$dir/dist
54−
55−# Build dependencies haddocks with stack, so we get links
56−stack haddock --only-dependencies
57−
58−# Configure using stack databases
59−snapshotpkgdb=$(stack path --snapshot-pkg-db)
60−localpkgdb=$(stack path --local-pkg-db)
61−cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb
62−
63−# Build Hadckage compatible docs
64−cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
65−
66−# Copy into right directory
67−cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs
68−
69−# Tar and gzip
70−tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
71−
72−# Upload
73−curl -X PUT \
74− -H 'Content-Type: application/x-tar' \
75− -H 'Content-Encoding: gzip' \
76− -u "$user" \
77− --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
78− "https://hackage.haskell.org/package/$pkg-$ver/docs"
include/overlapping-compat.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
src/Data/Swagger.hs+11−101
@@ -1,9 +1,4 @@
1−{-# LANGUAGE CPP #-}
21-- |
3−-- Module: Data.Swagger
4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5−-- Stability: experimental
6−--
72-- Swagger™ is a project used to describe and document RESTful APIs.
83--
94-- The Swagger specification defines a set of files required to describe such an API.
@@ -23,19 +18,10 @@ module Data.Swagger (
2318 -- ** Schema specification
2419 -- $schema
2520
26− -- ** Manipulation
27− -- $manipulation
28−
29− -- ** Validation
30− -- $validation
31−
3221 -- * Re-exports
3322 module Data.Swagger.Lens,
34− module Data.Swagger.Optics,
35− module Data.Swagger.Operation,
3623 module Data.Swagger.ParamSchema,
3724 module Data.Swagger.Schema,
38− module Data.Swagger.Schema.Validation,
3925
4026 -- * Swagger specification
4127 Swagger(..),
@@ -77,8 +63,6 @@ module Data.Swagger (
7763 NamedSchema(..),
7864 SwaggerItems(..),
7965 Xml(..),
80− Pattern,
81− AdditionalProperties(..),
8266
8367 -- ** Responses
8468 Responses(..),
@@ -89,7 +73,6 @@ module Data.Swagger (
8973 SecurityScheme(..),
9074 SecuritySchemeType(..),
9175 SecurityRequirement(..),
92− SecurityDefinitions(..),
9376
9477 -- *** API key
9578 ApiKeyParams(..),
@@ -114,11 +97,8 @@ module Data.Swagger (
11497) where
11598
11699import Data.Swagger.Lens
117−import Data.Swagger.Optics ()
118−import Data.Swagger.Operation
119100import Data.Swagger.ParamSchema
120101import Data.Swagger.Schema
121−import Data.Swagger.Schema.Validation
122102
123103import Data.Swagger.Internal
124104
@@ -178,47 +158,44 @@ import Data.Swagger.Internal
178158
179159-- $lens
180160--
181−-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics".
182−--
183161-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
184−-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
162+-- to work comfortly with it. In combination with @'Monoid'@ instances, lenses
185163-- make it fairly simple to construct/modify any part of the specification:
186164--
187165-- >>> :{
188166-- encode $ (mempty :: Swagger)
189−-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
167+-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]
190168-- & paths .~
191169-- [ ("/user", mempty & get ?~ (mempty
192170-- & produces ?~ MimeList ["application/json"]
193171-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))
194172-- & at 404 ?~ "User info not found")) ]
195173-- :}
196−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"
174+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}},\"produces\":[\"application/json\"]}}}}"
197175--
198−-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
199−-- which produces @application/json@ output. It should respond with code @200@ and body specified
176+-- In the snippet above we declare API with a single path @/user@ providing method @GET@
177+-- which produces @application/json@ output and should respond with code @200@ and body specified
200178-- by schema @User@ which is defined in @'definitions'@ property of swagger specification.
201−-- Alternatively it may respond with code @404@ meaning that user info is not found.
202179--
203180-- For convenience, @swagger2@ uses /classy field lenses/. It means that
204181-- field accessor names can be overloaded for different types. One such
205−-- common field is @'description'@. Many components of a Swagger specification
182+-- common field is @'description'@. Many components of Swagger specification
206183-- can have descriptions, and you can use the same name for them:
207184--
208185-- >>> encode $ (mempty :: Response) & description .~ "No content"
209186-- "{\"description\":\"No content\"}"
210187-- >>> :{
211188-- encode $ (mempty :: Schema)
212−-- & type_ ?~ SwaggerBoolean
189+-- & type_ .~ SwaggerBoolean
213190-- & description ?~ "To be or not to be"
214191-- :}
215−-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
192+-- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}"
216193--
217194-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).
218195-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
219196-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
220197--
221−-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber
198+-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber
222199-- "{\"type\":\"number\"}"
223200--
224201-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
@@ -236,7 +213,7 @@ import Data.Swagger.Internal
236213-- A few other field accessors are modified in this way:
237214--
238215-- - @'in_'@, @'type_'@, @'default_'@ (as keywords);
239−-- - @'maximum_'@, @'minimum_'@, @'head_'@ (as conflicting with @Prelude@);
216+-- - @'maximum_'@ and @'minimum_'@ (as conflicting with @Prelude@);
240217-- - @'enum_'@ (as conflicting with @Control.Lens@).
241218
242219-- $schema
@@ -278,73 +255,6 @@ import Data.Swagger.Internal
278255-- >>> encode (Person "David" 28)
279256-- "{\"age\":28,\"name\":\"David\"}"
280257-- >>> encode $ toSchema (Proxy :: Proxy Person)
281−-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
282−--
283−-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a
284−-- schema for basic enums like
285−--
286−-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic
287−-- >>> instance ToSchema SampleEnum
288−-- >>> instance ToJSON SampleEnum
289−--
290−-- and for sum types that have constructors with values
291−--
292−-- >>> data SampleSumType = ChoiceInt Int | ChoiceString String deriving Generic
293−-- >>> instance ToSchema SampleSumType
294−-- >>> instance ToJSON SampleSumType
295−--
296−-- we can not derive a valid schema for a mix of the above. The following will result in a type error
297−--
298−#if __GLASGOW_HASKELL__ < 800
299−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
300−-- >>> instance ToSchema BadMixedType
301−-- ...
302−-- ... error:
303−-- ... • No instance for (Data.Swagger.Internal.TypeShape.CannotDeriveSchemaForMixedSumType
304−-- ... BadMixedType)
305−-- ... arising from a use of ‘Data.Swagger.Internal.Schema.$dmdeclareNamedSchema’
306−-- ... • In the expression:
307−-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
308−-- ... In an equation for ‘declareNamedSchema’:
309−-- ... declareNamedSchema
310−-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
311−-- ... In the instance declaration for ‘ToSchema BadMixedType’
312−#else
313−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
314−-- >>> instance ToSchema BadMixedType
315−-- ...
316−-- ... error:
317−-- ... • Cannot derive Generic-based Swagger Schema for BadMixedType
318−-- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors).
319−-- ... Swagger does not have a good representation for these types.
320−-- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema
321−-- ... that matches aeson's Generic-based toJSON,
322−-- ... but that's not supported by some Swagger tools.
323−-- ... • In the expression:
324−-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
325−-- ... In an equation for ‘declareNamedSchema’:
326−-- ... declareNamedSchema
327−-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
328−-- ... In the instance declaration for ‘ToSchema BadMixedType’
329−#endif
330−--
331−-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON':
332−--
333−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
334−-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
335−-- >>> instance ToJSON BadMixedType
258+-- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}"
336259--
337260
338−-- $manipulation
339−-- Sometimes you have to work with an imported or generated @'Swagger'@.
340−-- For instance, <servant-swagger http://hackage.haskell.org/package/servant-swagger> generates basic @'Swagger'@
341−-- for a type-level servant API.
342−--
343−-- Lenses and prisms can be used to manipulate such specification to add additional information, tags, extra responses, etc.
344−-- To facilitate common needs, @"Data.Swagger.Operation"@ module provides useful helpers.
345−
346−-- $validation
347−-- While @'ToParamSchema'@ and @'ToSchema'@ provide means to easily obtain schemas for Haskell types,
348−-- there is no static mechanism to ensure those instances correspond to the @'ToHttpApiData'@ or @'ToJSON'@ instances.
349−--
350−-- @"Data.Swagger.Schema.Validation"@ addresses @'ToJSON'@/@'ToSchema'@ validation.
src/Data/Swagger/Declare.hs+10−91
@@ -2,33 +2,12 @@
22{-# LANGUAGE FlexibleInstances #-}
33{-# LANGUAGE FunctionalDependencies #-}
44{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE UndecidableInstances #-}
6−-- |
7−-- Module: Data.Swagger.Declare
8−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
9−-- Stability: experimental
10−--
11−-- Declare monad transformer and associated functions.
125module Data.Swagger.Declare where
136
14−import Prelude ()
15−import Prelude.Compat
16−
177import Control.Monad
18−import Control.Monad.Cont (ContT)
19−import Control.Monad.List (ListT)
20−import Control.Monad.Reader (ReaderT)
218import 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
319import Data.Functor.Identity
10+import Data.Monoid
3211
3312-- | A declare monad transformer parametrized by:
3413--
@@ -45,22 +24,22 @@ import Data.Functor.Identity
4524newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
4625 deriving (Functor)
4726
48−instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
27+instance (Monad m, Monoid d) => Applicative (DeclareT d m) where
4928 pure x = DeclareT (\_ -> pure (mempty, x))
5029 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
5130 ~(d', f) <- df d
52− ~(d'', x) <- dx (mappend d d')
53− return (mappend d' d'', f x)
31+ ~(d'', x) <- dx (d <> d')
32+ return (d' <> d'', f x)
5433
55−instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
34+instance (Monad m, Monoid d) => Monad (DeclareT d m) where
5635 return x = DeclareT (\_ -> pure (mempty, x))
5736 DeclareT dx >>= f = DeclareT $ \d -> do
5837 ~(d', x) <- dx d
59− ~(d'', y) <- runDeclareT (f x) (mappend d d')
60− return (mappend d' d'', y)
38+ ~(d'', y) <- runDeclareT (f x) (d <> d')
39+ return (d' <> d'', y)
6140
6241instance Monoid d => MonadTrans (DeclareT d) where
63− lift m = DeclareT (\_ -> (,) mempty `liftM` m)
42+ lift m = DeclareT (\_ -> (,) mempty <$> m)
6443
6544-- |
6645-- Definitions of @declare@ and @look@ must satisfy the following laws:
@@ -79,23 +58,16 @@ instance Monoid d => MonadTrans (DeclareT d) where
7958-- [/@look@ as left identity/]
8059-- @'look' >> m == m@
8160-- for every @m@
82−class (Applicative m, Monad m) => MonadDeclare d m | m -> d where
61+class Monad m => MonadDeclare d m | m -> d where
8362 -- | @'declare' x@ is an action that produces the output @x@.
8463 declare :: d -> m ()
8564 -- | @'look'@ is an action that returns all the output so far.
8665 look :: m d
8766
88−instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
67+instance (Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
8968 declare d = DeclareT (\_ -> return (d, ()))
9069 look = DeclareT (\d -> return (mempty, d))
9170
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−
9971-- | Retrieve a function of all the output so far.
10072looks :: MonadDeclare d m => (d -> a) -> m a
10173looks f = f <$> look
@@ -144,56 +116,3 @@ execDeclare m = runIdentity . execDeclareT m
144116undeclare :: Monoid d => Declare d a -> a
145117undeclare = runIdentity . undeclareT
146118
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 (ListT m) where
166− declare = lift . declare
167− look = lift look
168−
169−instance MonadDeclare d m => MonadDeclare d (MaybeT m) where
170− declare = lift . declare
171− look = lift look
172−
173−instance MonadDeclare d m => MonadDeclare d (ReaderT r m) where
174− declare = lift . declare
175− look = lift look
176−
177−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.RWST r w s m) where
178− declare = lift . declare
179− look = lift look
180−
181−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.RWST r w s m) where
182− declare = lift . declare
183− look = lift look
184−
185−instance MonadDeclare d m => MonadDeclare d (Lazy.StateT s m) where
186− declare = lift . declare
187− look = lift look
188−
189−instance MonadDeclare d m => MonadDeclare d (Strict.StateT s m) where
190− declare = lift . declare
191− look = lift look
192−
193−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.WriterT w m) where
194− declare = lift . declare
195− look = lift look
196−
197−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.WriterT w m) where
198− declare = lift . declare
199− look = lift look
src/Data/Swagger/Internal.hs+146−396
@@ -1,5 +1,3 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
31{-# LANGUAGE DeriveDataTypeable #-}
42{-# LANGUAGE DeriveFunctor #-}
53{-# LANGUAGE DeriveGeneric #-}
@@ -12,66 +10,32 @@
1210{-# LANGUAGE RecordWildCards #-}
1311{-# LANGUAGE ScopedTypeVariables #-}
1412{-# LANGUAGE StandaloneDeriving #-}
15−{-# LANGUAGE TemplateHaskell #-}
16−{-# LANGUAGE TypeFamilies #-}
1713{-# LANGUAGE UndecidableInstances #-}
18−#if __GLASGOW_HASKELL__ <710
19−{-# LANGUAGE PolyKinds #-}
20−#endif
21−#include "overlapping-compat.h"
2214module Data.Swagger.Internal where
2315
24−import Prelude ()
25−import Prelude.Compat
26−
27−import Control.Lens ((&), (.~), (?~))
2816import Control.Applicative
17+import Control.Monad
2918import Data.Aeson
3019import qualified Data.Aeson.Types as JSON
3120import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
32−import Data.Hashable (Hashable)
21+import Data.HashMap.Strict (HashMap)
3322import qualified Data.HashMap.Strict as HashMap
34−import Data.HashSet.InsOrd (InsOrdHashSet)
3523import Data.Map (Map)
3624import qualified Data.Map as Map
37−import Data.Monoid (Monoid (..))
38−import Data.Semigroup.Compat (Semigroup (..))
25+import Data.Monoid
3926import Data.Scientific (Scientific)
4027import Data.String (IsString(..))
4128import Data.Text (Text)
4229import qualified Data.Text as Text
4330import GHC.Generics (Generic)
44−import Network.Socket (HostName, PortNumber)
31+import Network (HostName, PortNumber)
4532import Network.HTTP.Media (MediaType)
4633import Text.Read (readMaybe)
4734
48−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
49−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
50−
51−import Generics.SOP.TH (deriveGeneric)
52−import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON
53− ,sopSwaggerGenericToJSONWithOpts
54− ,sopSwaggerGenericParseJSON
55− ,HasSwaggerAesonOptions(..)
56− ,AesonDefaultValue(..)
57− ,mkSwaggerAesonOptions
58− ,saoAdditionalPairs
59− ,saoSubObject)
6035import Data.Swagger.Internal.Utils
6136
62−#if MIN_VERSION_aeson(0,10,0)
63−import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)
64−#define DEFINE_TOENCODING toEncoding = sopSwaggerGenericToEncoding
65−#else
66−#define DEFINE_TOENCODING
67−#endif
68−
69−-- $setup
70−-- >>> :seti -XDataKinds
71−-- >>> import Data.Aeson
72−
7337-- | A list of definitions that can be used in references.
74−type Definitions = InsOrdHashMap Text
38+type Definitions = HashMap Text
7539
7640-- | This is the root document object for the API specification.
7741data Swagger = Swagger
@@ -103,7 +67,7 @@ data Swagger = Swagger
10367 -- | The available paths and operations for the API.
10468 -- Holds the relative paths to the individual endpoints.
10569 -- The path is appended to the @'basePath'@ in order to construct the full URL.
106− , _swaggerPaths :: InsOrdHashMap FilePath PathItem
70+ , _swaggerPaths :: HashMap FilePath PathItem
10771
10872 -- | An object to hold data types produced and consumed by operations.
10973 , _swaggerDefinitions :: Definitions Schema
@@ -117,7 +81,7 @@ data Swagger = Swagger
11781 , _swaggerResponses :: Definitions Response
11882
11983 -- | Security scheme definitions that can be used across the specification.
120− , _swaggerSecurityDefinitions :: SecurityDefinitions
84+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme
12185
12286 -- | A declaration of which security schemes are applied for the API as a whole.
12387 -- The list of values describes alternative security schemes that can be used
@@ -130,7 +94,7 @@ data Swagger = Swagger
13094 -- Not all tags that are used by the Operation Object must be declared.
13195 -- The tags that are not declared may be organized randomly or based on the tools' logic.
13296 -- Each tag name in the list MUST be unique.
133− , _swaggerTags :: InsOrdHashSet Tag
97+ , _swaggerTags :: [Tag]
13498
13599 -- | Additional external documentation.
136100 , _swaggerExternalDocs :: Maybe ExternalDocs
@@ -252,7 +216,7 @@ data PathItem = PathItem
252216data Operation = Operation
253217 { -- | A list of tags for API documentation control.
254218 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
255− _operationTags :: InsOrdHashSet TagName
219+ _operationTags :: [TagName]
256220
257221 -- | A short summary of what the operation does.
258222 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -309,7 +273,7 @@ data Operation = Operation
309273 } deriving (Eq, Show, Generic, Data, Typeable)
310274
311275newtype MimeList = MimeList { getMimeList :: [MediaType] }
312− deriving (Eq, Show, Semigroup, Monoid, Typeable)
276+ deriving (Eq, Show, Monoid, Typeable)
313277
314278mimeListConstr :: Constr
315279mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
@@ -360,8 +324,8 @@ data ParamOtherSchema = ParamOtherSchema
360324 -- Default value is @False@.
361325 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
362326
363− , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
364− } deriving (Eq, Show, Generic, Typeable, Data)
327+ , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
328+ } deriving (Eq, Show, Generic, Data, Typeable)
365329
366330-- | Items for @'SwaggerArray'@ schemas.
367331--
@@ -374,78 +338,28 @@ data ParamOtherSchema = ParamOtherSchema
374338--
375339-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
376340data SwaggerItems t where
377− SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k
378− SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema
379− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
380− deriving (Typeable)
341+ SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t
342+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema
343+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema
381344
382345deriving instance Eq (SwaggerItems t)
383346deriving instance Show (SwaggerItems t)
384−--deriving instance Typeable (SwaggerItems t)
347+deriving instance Typeable (SwaggerItems t)
385348
386349swaggerItemsPrimitiveConstr :: Constr
387350swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
388351
389−swaggerItemsObjectConstr :: Constr
390−swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix
391−
392−swaggerItemsArrayConstr :: Constr
393−swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix
394−
395352swaggerItemsDataType :: DataType
396353swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
397354
398−-- Note: unfortunately we have to write these Data instances by hand,
399−-- to get better contexts / avoid duplicate name when using standalone deriving
400−
401−instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where
402− -- TODO: define gfoldl
355+instance {-# OVERLAPPABLE #-} Data t => Data (SwaggerItems t) where
403356 gunfold k z c = case constrIndex c of
404357 1 -> k (k (z SwaggerItemsPrimitive))
405358 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
406359 toConstr _ = swaggerItemsPrimitiveConstr
407360 dataTypeOf _ = swaggerItemsDataType
408361
409−-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only
410−instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where
411− -- TODO: define gfoldl
412− gunfold k z c = case constrIndex c of
413− 1 -> k (k (z SwaggerItemsPrimitive))
414− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindParamOtherSchema)."
415− toConstr _ = swaggerItemsPrimitiveConstr
416− dataTypeOf _ = swaggerItemsDataType
417−
418−instance Data (SwaggerItems 'SwaggerKindSchema) where
419− gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema"
420− gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref
421− gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref
422−
423− gunfold k z c = case constrIndex c of
424− 2 -> k (z SwaggerItemsObject)
425− 3 -> k (z SwaggerItemsArray)
426− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)."
427−
428− toConstr (SwaggerItemsPrimitive _ _) = error "Not supported"
429− toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr
430− toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr
431−
432− dataTypeOf _ = swaggerItemsDataType
433−
434−-- | Type used as a kind to avoid overlapping instances.
435−data SwaggerKind t
436− = SwaggerKindNormal t
437− | SwaggerKindParamOtherSchema
438− | SwaggerKindSchema
439− deriving (Typeable)
440−
441−deriving instance Typeable 'SwaggerKindNormal
442−deriving instance Typeable 'SwaggerKindParamOtherSchema
443−deriving instance Typeable 'SwaggerKindSchema
444−
445−type family SwaggerKindType (k :: SwaggerKind *) :: *
446−type instance SwaggerKindType ('SwaggerKindNormal t) = t
447−type instance SwaggerKindType 'SwaggerKindSchema = Schema
448−type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema
362+deriving instance Data (SwaggerItems Schema)
449363
450364data SwaggerType t where
451365 SwaggerString :: SwaggerType t
@@ -453,44 +367,44 @@ data SwaggerType t where
453367 SwaggerInteger :: SwaggerType t
454368 SwaggerBoolean :: SwaggerType t
455369 SwaggerArray :: SwaggerType t
456− SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema
457− SwaggerNull :: SwaggerType 'SwaggerKindSchema
458− SwaggerObject :: SwaggerType 'SwaggerKindSchema
459− deriving (Typeable)
370+ SwaggerFile :: SwaggerType ParamOtherSchema
371+ SwaggerNull :: SwaggerType Schema
372+ SwaggerObject :: SwaggerType Schema
460373
461374deriving instance Eq (SwaggerType t)
462375deriving instance Show (SwaggerType t)
376+deriving instance Typeable (SwaggerType t)
463377
464378swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
465379swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
466380
467−swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType
381+swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
468382swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
469383
470−swaggerCommonTypes :: [SwaggerType k]
384+swaggerCommonTypes :: [SwaggerType t]
471385swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
472386
473−swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]
387+swaggerParamTypes :: [SwaggerType ParamOtherSchema]
474388swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
475389
476−swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]
390+swaggerSchemaTypes :: [SwaggerType Schema]
477391swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
478392
479393swaggerTypeConstrs :: [Constr]
480−swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema])
394+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])
481395 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
482396
483−instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where
397+instance {-# OVERLAPPABLE #-} Typeable t => Data (SwaggerType t) where
484398 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
485399 toConstr = swaggerTypeConstr
486400 dataTypeOf = swaggerTypeDataType
487401
488−instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where
402+instance {-# OVERLAPPING #-} Data (SwaggerType ParamOtherSchema) where
489403 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
490404 toConstr = swaggerTypeConstr
491405 dataTypeOf = swaggerTypeDataType
492406
493−instance Data (SwaggerType 'SwaggerKindSchema) where
407+instance {-# OVERLAPPING #-} Data (SwaggerType Schema) where
494408 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
495409 toConstr = swaggerTypeConstr
496410 dataTypeOf = swaggerTypeDataType
@@ -530,11 +444,11 @@ data CollectionFormat t where
530444 -- Corresponds to multiple parameter instances
531445 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
532446 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
533− CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema
534− deriving (Typeable)
447+ CollectionMulti :: CollectionFormat ParamOtherSchema
535448
536449deriving instance Eq (CollectionFormat t)
537450deriving instance Show (CollectionFormat t)
451+deriving instance Typeable (CollectionFormat t)
538452
539453collectionFormatConstr :: CollectionFormat t -> Constr
540454collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix
@@ -546,12 +460,12 @@ collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
546460collectionCommonFormats :: [CollectionFormat t]
547461collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
548462
549−instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where
463+instance {-# OVERLAPPABLE #-} Data t => Data (CollectionFormat t) where
550464 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
551465 toConstr = collectionFormatConstr
552466 dataTypeOf _ = collectionFormatDataType
553467
554−deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)
468+deriving instance {-# OVERLAPPING #-} Data (CollectionFormat ParamOtherSchema)
555469
556470type ParamName = Text
557471
@@ -560,9 +474,9 @@ data Schema = Schema
560474 , _schemaDescription :: Maybe Text
561475 , _schemaRequired :: [ParamName]
562476
563− , _schemaAllOf :: Maybe [Referenced Schema]
564− , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
565− , _schemaAdditionalProperties :: Maybe AdditionalProperties
477+ , _schemaAllOf :: Maybe [Schema]
478+ , _schemaProperties :: HashMap Text (Referenced Schema)
479+ , _schemaAdditionalProperties :: Maybe Schema
566480
567481 , _schemaDiscriminator :: Maybe Text
568482 , _schemaReadOnly :: Maybe Bool
@@ -573,7 +487,7 @@ data Schema = Schema
573487 , _schemaMaxProperties :: Maybe Integer
574488 , _schemaMinProperties :: Maybe Integer
575489
576− , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema
490+ , _schemaParamSchema :: ParamSchema Schema
577491 } deriving (Eq, Show, Generic, Data, Typeable)
578492
579493-- | A @'Schema'@ with an optional name.
@@ -583,10 +497,7 @@ data NamedSchema = NamedSchema
583497 , _namedSchemaSchema :: Schema
584498 } deriving (Eq, Show, Generic, Data, Typeable)
585499
586−-- | Regex pattern for @string@ type.
587−type Pattern = Text
588−
589−data ParamSchema (t :: SwaggerKind *) = ParamSchema
500+data ParamSchema t = ParamSchema
590501 { -- | Declares the value of the parameter that the server will use if none is provided,
591502 -- for example a @"count"@ to control the number of results per page might default to @100@
592503 -- if not supplied by the client in the request.
@@ -594,7 +505,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
594505 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
595506 _paramSchemaDefault :: Maybe Value
596507
597− , _paramSchemaType :: Maybe (SwaggerType t)
508+ , _paramSchemaType :: SwaggerType t
598509 , _paramSchemaFormat :: Maybe Format
599510 , _paramSchemaItems :: Maybe (SwaggerItems t)
600511 , _paramSchemaMaximum :: Maybe Scientific
@@ -603,7 +514,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
603514 , _paramSchemaExclusiveMinimum :: Maybe Bool
604515 , _paramSchemaMaxLength :: Maybe Integer
605516 , _paramSchemaMinLength :: Maybe Integer
606− , _paramSchemaPattern :: Maybe Pattern
517+ , _paramSchemaPattern :: Maybe Text
607518 , _paramSchemaMaxItems :: Maybe Integer
608519 , _paramSchemaMinItems :: Maybe Integer
609520 , _paramSchemaUniqueItems :: Maybe Bool
@@ -611,7 +522,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
611522 , _paramSchemaMultipleOf :: Maybe Scientific
612523 } deriving (Eq, Show, Generic, Typeable)
613524
614−deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)
525+deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)
615526
616527data Xml = Xml
617528 { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -653,7 +564,7 @@ data Responses = Responses
653564
654565 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
655566 -- Describes the expected response for those HTTP status codes.
656− , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)
567+ , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
657568 } deriving (Eq, Show, Generic, Data, Typeable)
658569
659570type HttpStatusCode = Int
@@ -672,7 +583,7 @@ data Response = Response
672583 , _responseSchema :: Maybe (Referenced Schema)
673584
674585 -- | A list of headers that are sent with the response.
675− , _responseHeaders :: InsOrdHashMap HeaderName Header
586+ , _responseHeaders :: HashMap HeaderName Header
676587
677588 -- | An example of the response message.
678589 , _responseExamples :: Maybe Example
@@ -687,7 +598,7 @@ data Header = Header
687598 { -- | A short description of the header.
688599 _headerDescription :: Maybe Text
689600
690− , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)
601+ , _headerParamSchema :: ParamSchema Header
691602 } deriving (Eq, Show, Generic, Data, Typeable)
692603
693604data Example = Example { getExample :: Map MediaType Value }
@@ -738,7 +649,7 @@ data OAuth2Params = OAuth2Params
738649 _oauth2Flow :: OAuth2Flow
739650
740651 -- | The available scopes for the OAuth2 security scheme.
741− , _oauth2Scopes :: InsOrdHashMap Text Text
652+ , _oauth2Scopes :: HashMap Text Text
742653 } deriving (Eq, Show, Generic, Data, Typeable)
743654
744655data SecuritySchemeType
@@ -755,28 +666,12 @@ data SecurityScheme = SecurityScheme
755666 , _securitySchemeDescription :: Maybe Text
756667 } deriving (Eq, Show, Generic, Data, Typeable)
757668
758−
759−-- | merge scopes of two OAuth2 security schemes when their flows are identical.
760−-- In other case returns first security scheme
761−mergeSecurityScheme :: SecurityScheme -> SecurityScheme -> SecurityScheme
762−mergeSecurityScheme s1@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 scopes1)) desc)
763− s2@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow2 scopes2)) _)
764− = if flow1 == flow2 then
765− SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 (scopes1 <> scopes2))) desc
766− else
767− s1
768−mergeSecurityScheme s1 _ = s1
769−
770−newtype SecurityDefinitions
771− = SecurityDefinitions (Definitions SecurityScheme)
772− deriving (Eq, Show, Generic, Data, Typeable)
773−
774669-- | Lists the required security schemes to execute this operation.
775670-- The object can have multiple security schemes declared in it which are all required
776671-- (that is, there is a logical AND between the schemes).
777672newtype SecurityRequirement = SecurityRequirement
778− { getSecurityRequirement :: InsOrdHashMap Text [Text]
779− } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
673+ { getSecurityRequirement :: HashMap Text [Text]
674+ } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
780675
781676-- | Tag name.
782677type TagName = Text
@@ -793,9 +688,7 @@ data Tag = Tag
793688
794689 -- | Additional external documentation for this tag.
795690 , _tagExternalDocs :: Maybe ExternalDocs
796− } deriving (Eq, Ord, Show, Generic, Data, Typeable)
797−
798−instance Hashable Tag
691+ } deriving (Eq, Show, Generic, Data, Typeable)
799692
800693instance IsString Tag where
801694 fromString s = Tag (fromString s) Nothing Nothing
@@ -808,9 +701,7 @@ data ExternalDocs = ExternalDocs
808701
809702 -- | The URL for the target documentation.
810703 , _externalDocsUrl :: URL
811− } deriving (Eq, Ord, Show, Generic, Data, Typeable)
812−
813−instance Hashable ExternalDocs
704+ } deriving (Eq, Show, Generic, Data, Typeable)
814705
815706-- | A simple object to allow referencing other definitions in the specification.
816707-- It can be used to reference parameters and responses that are defined at the top level for reuse.
@@ -825,111 +716,67 @@ data Referenced a
825716instance IsString a => IsString (Referenced a) where
826717 fromString = Inline . fromString
827718
828−newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable)
829−
830−data AdditionalProperties
831− = AdditionalPropertiesAllowed Bool
832− | AdditionalPropertiesSchema (Referenced Schema)
833− deriving (Eq, Show, Data, Typeable)
719+newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON, Data, Typeable)
834720
835721-- =======================================================================
836722-- Monoid instances
837723-- =======================================================================
838724
839−instance Semigroup Swagger where
840− (<>) = genericMappend
841725instance Monoid Swagger where
842726 mempty = genericMempty
843− mappend = (<>)
727+ mappend = genericMappend
844728
845−instance Semigroup Info where
846− (<>) = genericMappend
847729instance Monoid Info where
848730 mempty = genericMempty
849− mappend = (<>)
731+ mappend = genericMappend
850732
851−instance Semigroup Contact where
852− (<>) = genericMappend
853733instance Monoid Contact where
854734 mempty = genericMempty
855− mappend = (<>)
735+ mappend = genericMappend
856736
857−instance Semigroup PathItem where
858− (<>) = genericMappend
859737instance Monoid PathItem where
860738 mempty = genericMempty
861− mappend = (<>)
739+ mappend = genericMappend
862740
863−instance Semigroup Schema where
864− (<>) = genericMappend
865741instance Monoid Schema where
866742 mempty = genericMempty
867− mappend = (<>)
743+ mappend = genericMappend
868744
869−instance Semigroup (ParamSchema t) where
870− (<>) = genericMappend
871745instance Monoid (ParamSchema t) where
872746 mempty = genericMempty
873− mappend = (<>)
747+ mappend = genericMappend
874748
875−instance Semigroup Param where
876− (<>) = genericMappend
877749instance Monoid Param where
878750 mempty = genericMempty
879− mappend = (<>)
751+ mappend = genericMappend
880752
881−instance Semigroup ParamOtherSchema where
882− (<>) = genericMappend
883753instance Monoid ParamOtherSchema where
884754 mempty = genericMempty
885− mappend = (<>)
755+ mappend = genericMappend
886756
887−instance Semigroup Header where
888− (<>) = genericMappend
889757instance Monoid Header where
890758 mempty = genericMempty
891− mappend = (<>)
759+ mappend = genericMappend
892760
893−instance Semigroup Responses where
894− (<>) = genericMappend
895761instance Monoid Responses where
896762 mempty = genericMempty
897− mappend = (<>)
763+ mappend = genericMappend
898764
899−instance Semigroup Response where
900− (<>) = genericMappend
901765instance Monoid Response where
902766 mempty = genericMempty
903− mappend = (<>)
767+ mappend = genericMappend
904768
905−instance Semigroup ExternalDocs where
906− (<>) = genericMappend
907769instance Monoid ExternalDocs where
908770 mempty = genericMempty
909− mappend = (<>)
771+ mappend = genericMappend
910772
911−instance Semigroup Operation where
912− (<>) = genericMappend
913773instance Monoid Operation where
914774 mempty = genericMempty
915− mappend = (<>)
775+ mappend = genericMappend
916776
917−instance Semigroup Example where
918− (<>) = genericMappend
919777instance Monoid Example where
920778 mempty = genericMempty
921− mappend = (<>)
922−
923−instance Semigroup SecurityScheme where
924− (<>) = mergeSecurityScheme
925−
926−instance Semigroup SecurityDefinitions where
927− (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =
928− SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2
929−
930−instance Monoid SecurityDefinitions where
931− mempty = SecurityDefinitions $ InsOrdHashMap.empty
932− mappend = (<>)
779+ mappend = genericMappend
933780
934781-- =======================================================================
935782-- SwaggerMonoid helper instances
@@ -945,8 +792,6 @@ instance SwaggerMonoid Responses
945792instance SwaggerMonoid Response
946793instance SwaggerMonoid ExternalDocs
947794instance SwaggerMonoid Operation
948−instance SwaggerMonoid SecurityDefinitions
949−instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
950795
951796instance SwaggerMonoid MimeList
952797deriving instance SwaggerMonoid URL
@@ -959,13 +804,13 @@ instance SwaggerMonoid ParamLocation where
959804 swaggerMempty = ParamQuery
960805 swaggerMappend _ y = y
961806
962−instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
963− swaggerMempty = InsOrdHashMap.empty
964− swaggerMappend = InsOrdHashMap.unionWith mappend
807+instance SwaggerMonoid (HashMap FilePath PathItem) where
808+ swaggerMempty = HashMap.empty
809+ swaggerMappend = HashMap.unionWith mappend
965810
966811instance Monoid a => SwaggerMonoid (Referenced a) where
967812 swaggerMempty = Inline mempty
968− swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
813+ swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
969814 swaggerMappend _ y = y
970815
971816instance SwaggerMonoid ParamAnySchema where
@@ -1059,8 +904,7 @@ instance ToJSON OAuth2Flow where
1059904 , "tokenUrl" .= tokenUrl ]
1060905
1061906instance ToJSON OAuth2Params where
1062− toJSON = sopSwaggerGenericToJSON
1063− DEFINE_TOENCODING
907+ toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")
1064908
1065909instance ToJSON SecuritySchemeType where
1066910 toJSON SecuritySchemeBasic
@@ -1073,37 +917,28 @@ instance ToJSON SecuritySchemeType where
1073917 <+> object [ "type" .= ("oauth2" :: Text) ]
1074918
1075919instance ToJSON Swagger where
1076− toJSON = sopSwaggerGenericToJSON
1077− DEFINE_TOENCODING
920+ toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")
921+ where
922+ addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
923+ addVersion _ = error "impossible"
1078924
1079925instance ToJSON SecurityScheme where
1080− toJSON = sopSwaggerGenericToJSON
1081− DEFINE_TOENCODING
926+ toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
1082927
1083928instance ToJSON Schema where
1084− toJSON = sopSwaggerGenericToJSON
1085− DEFINE_TOENCODING
929+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
930+ where
931+ f "items" (Array _) = True
932+ f _ _ = False
1086933
1087934instance ToJSON Header where
1088− toJSON = sopSwaggerGenericToJSON
1089− DEFINE_TOENCODING
935+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
1090936
1091−-- | As for nullary schema for 0-arity type constructors, see
1092−-- <https://github.com/GetShopTV/swagger2/issues/167>.
1093−--
1094−-- >>> encode (SwaggerItemsArray [])
1095−-- "{\"example\":[],\"items\":{},\"maxItems\":0}"
1096−--
1097−instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
937+instance ToJSON (SwaggerItems t) where
1098938 toJSON (SwaggerItemsPrimitive fmt schema) = object
1099939 [ "collectionFormat" .= fmt
1100940 , "items" .= schema ]
1101941 toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1102− toJSON (SwaggerItemsArray []) = object
1103− [ "items" .= object []
1104− , "maxItems" .= (0 :: Int)
1105− , "example" .= Array mempty
1106− ]
1107942 toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
1108943
1109944instance ToJSON Host where
@@ -1116,39 +951,31 @@ instance ToJSON MimeList where
1116951 toJSON (MimeList xs) = toJSON (map show xs)
1117952
1118953instance ToJSON Param where
1119− toJSON = sopSwaggerGenericToJSON
1120− DEFINE_TOENCODING
954+ toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
1121955
1122956instance ToJSON ParamAnySchema where
1123957 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
1124958 toJSON (ParamOther s) = toJSON s
1125959
1126960instance ToJSON ParamOtherSchema where
1127− toJSON = sopSwaggerGenericToJSON
1128− DEFINE_TOENCODING
961+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1129962
1130963instance ToJSON Responses where
1131− toJSON = sopSwaggerGenericToJSON
1132− DEFINE_TOENCODING
964+ toJSON (Responses def rs) = omitEmpties $
965+ toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
1133966
1134967instance ToJSON Response where
1135− toJSON = sopSwaggerGenericToJSON
1136− DEFINE_TOENCODING
968+ toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
1137969
1138970instance ToJSON Operation where
1139− toJSON = sopSwaggerGenericToJSON
1140− DEFINE_TOENCODING
971+ toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")
1141972
1142973instance ToJSON PathItem where
1143− toJSON = sopSwaggerGenericToJSON
1144− DEFINE_TOENCODING
974+ toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")
1145975
1146976instance ToJSON Example where
1147977 toJSON = toJSON . Map.mapKeys show . getExample
1148978
1149−instance ToJSON SecurityDefinitions where
1150− toJSON (SecurityDefinitions sd) = toJSON sd
1151−
1152979instance ToJSON Reference where
1153980 toJSON (Reference ref) = object [ "$ref" .= ref ]
1154981
@@ -1177,14 +1004,11 @@ instance ToJSON (CollectionFormat t) where
11771004 toJSON CollectionPipes = "pipes"
11781005 toJSON CollectionMulti = "multi"
11791006
1180−instance ToJSON (ParamSchema k) where
1181− -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`?
1182− toJSON = sopSwaggerGenericToJSONWithOpts $
1183− mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1184−
1185−instance ToJSON AdditionalProperties where
1186− toJSON (AdditionalPropertiesAllowed b) = toJSON b
1187− toJSON (AdditionalPropertiesSchema s) = toJSON s
1007+instance ToJSON (ParamSchema t) where
1008+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
1009+ where
1010+ f "items" (Array _) = True
1011+ f _ _ = False
11881012
11891013-- =======================================================================
11901014-- Manual FromJSON instances
@@ -1204,7 +1028,7 @@ instance FromJSON OAuth2Flow where
12041028 parseJSON _ = empty
12051029
12061030instance FromJSON OAuth2Params where
1207− parseJSON = sopSwaggerGenericParseJSON
1031+ parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
12081032
12091033instance FromJSON SecuritySchemeType where
12101034 parseJSON js@(Object o) = do
@@ -1217,65 +1041,57 @@ instance FromJSON SecuritySchemeType where
12171041 parseJSON _ = empty
12181042
12191043instance FromJSON Swagger where
1220− parseJSON = sopSwaggerGenericParseJSON
1044+ parseJSON js@(Object o) = do
1045+ (version :: Text) <- o .: "swagger"
1046+ when (version /= "2.0") empty
1047+ (genericParseJSON (jsonPrefix "swagger")
1048+ `withDefaults` [ "consumes" .= (mempty :: MimeList)
1049+ , "produces" .= (mempty :: MimeList)
1050+ , "security" .= ([] :: [SecurityRequirement])
1051+ , "tags" .= ([] :: [Tag])
1052+ , "definitions" .= (mempty :: Definitions Schema)
1053+ , "parameters" .= (mempty :: Definitions Param)
1054+ , "responses" .= (mempty :: Definitions Response)
1055+ , "securityDefinitions" .= (mempty :: Definitions SecurityScheme)
1056+ ] ) js
1057+ parseJSON _ = empty
12211058
12221059instance FromJSON SecurityScheme where
1223− parseJSON = sopSwaggerGenericParseJSON
1060+ parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
12241061
12251062instance FromJSON Schema where
1226− parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
1227− where nullaryCleanup :: Schema -> Schema
1228− nullaryCleanup s@Schema{_schemaParamSchema=ps} =
1229− if _paramSchemaItems ps == Just (SwaggerItemsArray [])
1230− then s { _schemaExample = Nothing
1231− , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } }
1232− else s
1063+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
1064+ `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
1065+ , "required" .= ([] :: [ParamName]) ]
12331066
12341067instance FromJSON Header where
1235− parseJSON = sopSwaggerGenericParseJSON
1068+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
12361069
1237−instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where
1238− parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1070+instance {-# OVERLAPPABLE #-} (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where
1071+ parseJSON (Object o) = SwaggerItemsPrimitive
12391072 <$> o .:? "collectionFormat"
12401073 <*> (o .: "items" >>= parseJSON)
12411074
1242−instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where
1243− parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1244− <$> o .:? "collectionFormat"
1245− <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))
1246−
1247−-- |
1248−--
1249−-- >>> decode "{}" :: Maybe (SwaggerItems 'SwaggerKindSchema)
1250−-- Just (SwaggerItemsArray [])
1251−--
1252−-- >>> eitherDecode "{\"$ref\":\"#/definitions/example\"}" :: Either String (SwaggerItems 'SwaggerKindSchema)
1253−-- Right (SwaggerItemsObject (Ref (Reference {getReference = "example"})))
1254−--
1255−-- >>> eitherDecode "[{\"$ref\":\"#/definitions/example\"}]" :: Either String (SwaggerItems 'SwaggerKindSchema)
1256−-- Right (SwaggerItemsArray [Ref (Reference {getReference = "example"})])
1257−--
1258−instance FromJSON (SwaggerItems 'SwaggerKindSchema) where
1259− parseJSON js@(Object obj)
1260− | null obj = pure $ SwaggerItemsArray [] -- Nullary schema.
1261− | otherwise = SwaggerItemsObject <$> parseJSON js
1075+instance {-# OVERLAPPING #-} FromJSON (SwaggerItems Schema) where
1076+ parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
12621077 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
12631078 parseJSON _ = empty
12641079
12651080instance FromJSON Host where
1266− parseJSON (String s) = case map Text.unpack $ Text.split (== ':') s of
1267− [host] -> return $ Host host Nothing
1268− [host, port] -> case readMaybe port of
1269− Nothing -> fail $ "Invalid port `" ++ port ++ "'"
1270− Just p -> return $ Host host (Just (fromInteger p))
1271− _ -> fail $ "Invalid host `" ++ Text.unpack s ++ "'"
1081+ parseJSON (String s) =
1082+ case fromInteger <$> readMaybe portStr of
1083+ Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'"
1084+ mport -> pure $ Host host mport
1085+ where
1086+ (hostText, portText) = Text.breakOn ":" s
1087+ [host, portStr] = map Text.unpack [hostText, portText]
12721088 parseJSON _ = empty
12731089
12741090instance FromJSON MimeList where
12751091 parseJSON js = (MimeList . map fromString) <$> parseJSON js
12761092
12771093instance FromJSON Param where
1278− parseJSON = sopSwaggerGenericParseJSON
1094+ parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
12791095
12801096instance FromJSON ParamAnySchema where
12811097 parseJSON js@(Object o) = do
@@ -1288,12 +1104,12 @@ instance FromJSON ParamAnySchema where
12881104 parseJSON _ = empty
12891105
12901106instance FromJSON ParamOtherSchema where
1291− parseJSON = sopSwaggerGenericParseJSON
1107+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
12921108
12931109instance FromJSON Responses where
12941110 parseJSON (Object o) = Responses
12951111 <$> o .:? "default"
1296− <*> (parseJSON (Object (HashMap.delete "default" o)))
1112+ <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
12971113 parseJSON _ = empty
12981114
12991115instance FromJSON Example where
@@ -1302,16 +1118,16 @@ instance FromJSON Example where
13021118 pure $ Example (Map.mapKeys fromString m)
13031119
13041120instance FromJSON Response where
1305− parseJSON = sopSwaggerGenericParseJSON
1121+ parseJSON = genericParseJSON (jsonPrefix "response")
1122+ `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
13061123
13071124instance FromJSON Operation where
1308− parseJSON = sopSwaggerGenericParseJSON
1125+ parseJSON = genericParseJSON (jsonPrefix "operation")
1126+ `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) ]
13091127
13101128instance FromJSON PathItem where
1311− parseJSON = sopSwaggerGenericParseJSON
1312−
1313−instance FromJSON SecurityDefinitions where
1314− parseJSON js = SecurityDefinitions <$> parseJSON js
1129+ parseJSON = genericParseJSON (jsonPrefix "pathItem")
1130+ `withDefaults` [ "parameters" .= ([] :: [Param]) ]
13151131
13161132instance FromJSON Reference where
13171133 parseJSON (Object o) = Reference <$> o .: "$ref"
@@ -1328,7 +1144,6 @@ referencedParseJSON prefix js@(Object o) = do
13281144 case Text.stripPrefix prefix s of
13291145 Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s
13301146 Just suffix -> pure (Reference suffix)
1331−referencedParseJSON _ _ = fail "referenceParseJSON: not an object"
13321147
13331148instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/definitions/"
13341149instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/parameters/"
@@ -1337,91 +1152,26 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#
13371152instance FromJSON Xml where
13381153 parseJSON = genericParseJSON (jsonPrefix "xml")
13391154
1340−instance FromJSON (SwaggerType 'SwaggerKindSchema) where
1155+instance FromJSON (SwaggerType Schema) where
13411156 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
13421157
1343−instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where
1158+instance FromJSON (SwaggerType ParamOtherSchema) where
13441159 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
13451160
1346−instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where
1161+instance {-# OVERLAPPABLE #-} FromJSON (SwaggerType t) where
13471162 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
13481163
1349−instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where
1164+instance {-# OVERLAPPABLE #-} FromJSON (CollectionFormat t) where
13501165 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
13511166
1352−-- NOTE: There aren't collections of 'Schema'
1353−--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where
1354−-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1355−
1356−instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where
1167+instance FromJSON (CollectionFormat ParamOtherSchema) where
13571168 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
13581169
1359−instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where
1360− parseJSON = sopSwaggerGenericParseJSON
1361−instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where
1362− parseJSON = sopSwaggerGenericParseJSON
1363−instance FromJSON (ParamSchema 'SwaggerKindSchema) where
1364− parseJSON = sopSwaggerGenericParseJSON
1365−
1366−instance FromJSON AdditionalProperties where
1367− parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b
1368− parseJSON js = AdditionalPropertiesSchema <$> parseJSON js
1369−
1370−-------------------------------------------------------------------------------
1371−-- TH splices
1372−-------------------------------------------------------------------------------
1373−
1374−deriveGeneric ''Header
1375−deriveGeneric ''OAuth2Params
1376−deriveGeneric ''Operation
1377−deriveGeneric ''Param
1378−deriveGeneric ''ParamOtherSchema
1379−deriveGeneric ''PathItem
1380−deriveGeneric ''Response
1381−deriveGeneric ''Responses
1382−deriveGeneric ''SecurityScheme
1383−deriveGeneric ''Schema
1384−deriveGeneric ''ParamSchema
1385−deriveGeneric ''Swagger
1386−
1387−instance HasSwaggerAesonOptions Header where
1388− swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema"
1389−instance HasSwaggerAesonOptions OAuth2Params where
1390− swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow"
1391−instance HasSwaggerAesonOptions Operation where
1392− swaggerAesonOptions _ = mkSwaggerAesonOptions "operation"
1393−instance HasSwaggerAesonOptions Param where
1394− swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject ?~ "schema"
1395−instance HasSwaggerAesonOptions ParamOtherSchema where
1396− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramOtherSchema" & saoSubObject ?~ "paramSchema"
1397−instance HasSwaggerAesonOptions PathItem where
1398− swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem"
1399−instance HasSwaggerAesonOptions Response where
1400− swaggerAesonOptions _ = mkSwaggerAesonOptions "response"
1401−instance HasSwaggerAesonOptions Responses where
1402− swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses"
1403−instance HasSwaggerAesonOptions SecurityScheme where
1404− swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type"
1405−instance HasSwaggerAesonOptions Schema where
1406− swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema"
1407−instance HasSwaggerAesonOptions Swagger where
1408− swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")]
1409−
1410−instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where
1411− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1412−instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where
1413− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1414−-- NOTE: Schema doesn't have 'items' sub object!
1415−instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where
1416− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema"
1417−
1418−instance AesonDefaultValue (ParamSchema s)
1419−instance AesonDefaultValue OAuth2Flow
1420−instance AesonDefaultValue Responses
1421−instance AesonDefaultValue ParamAnySchema
1422−instance AesonDefaultValue SecuritySchemeType
1423−instance AesonDefaultValue (SwaggerType a)
1424−instance AesonDefaultValue MimeList where defaultValue = Just mempty
1425−instance AesonDefaultValue Info
1426−instance AesonDefaultValue ParamLocation
1427−instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty
1170+-- NOTE: The constraints @FromJSON (SwaggerType t)@ and
1171+-- @FromJSON (SwaggerItems t)@ are necessary here!
1172+-- Without the constraint the general instance will be used
1173+-- that only accepts common types (i.e. NOT object, null or file)
1174+-- and primitive array items.
1175+instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
1176+ parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
1177+
src/Data/Swagger/Internal/AesonUtils.hsdeleted−346
@@ -1,346 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE ExplicitForAll #-}
7−{-# LANGUAGE TemplateHaskell #-}
8−#if __GLASGOW_HASKELL__ >= 800
9−{-# LANGUAGE UndecidableSuperClasses #-}
10−#endif
11−module Data.Swagger.Internal.AesonUtils (
12− -- * Generic functions
13− AesonDefaultValue(..),
14− sopSwaggerGenericToJSON,
15−#if MIN_VERSION_aeson(0,10,0)
16− sopSwaggerGenericToEncoding,
17−#endif
18− sopSwaggerGenericToJSONWithOpts,
19− sopSwaggerGenericParseJSON,
20− -- * Options
21− HasSwaggerAesonOptions(..),
22− SwaggerAesonOptions,
23− mkSwaggerAesonOptions,
24− saoPrefix,
25− saoAdditionalPairs,
26− saoSubObject,
27− ) where
28−
29−import Prelude ()
30−import Prelude.Compat
31−
32−import Control.Applicative ((<|>))
33−import Control.Lens (makeLenses, (^.))
34−import Control.Monad (unless)
35−import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)
36−import Data.Aeson.Types (Parser, Pair)
37−import Data.Char (toLower, isUpper)
38−import Data.Foldable (traverse_)
39−import Data.Text (Text)
40−
41−import Generics.SOP
42−
43−import qualified Data.Text as T
44−import qualified Data.HashMap.Strict as HM
45−import qualified Data.Set as Set
46−import qualified Data.HashMap.Strict.InsOrd as InsOrd
47−import qualified Data.HashSet.InsOrd as InsOrdHS
48−
49−#if MIN_VERSION_aeson(0,10,0)
50−import Data.Aeson (Encoding, pairs, (.=), Series)
51−#endif
52−
53−-------------------------------------------------------------------------------
54−-- SwaggerAesonOptions
55−-------------------------------------------------------------------------------
56−
57−data SwaggerAesonOptions = SwaggerAesonOptions
58− { _saoPrefix :: String
59− , _saoAdditionalPairs :: [(Text, Value)]
60− , _saoSubObject :: Maybe String
61− }
62−
63−mkSwaggerAesonOptions
64− :: String -- ^ prefix
65− -> SwaggerAesonOptions
66−mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing
67−
68−makeLenses ''SwaggerAesonOptions
69−
70−class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
71− swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions
72−
73− -- So far we use only default definitions
74− aesonDefaults :: Proxy a -> POP Maybe (Code a)
75− aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
76−
77−-------------------------------------------------------------------------------
78−-- Generics
79−-------------------------------------------------------------------------------
80−
81−class AesonDefaultValue a where
82− defaultValue :: Maybe a
83− defaultValue = Nothing
84−
85−instance AesonDefaultValue Text where defaultValue = Nothing
86−instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
87−instance AesonDefaultValue [a] where defaultValue = Just []
88−instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
89−instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty
90−instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
91−
92−-------------------------------------------------------------------------------
93−-- ToJSON
94−-------------------------------------------------------------------------------
95−
96−-- | Generic serialisation for swagger records.
97−--
98−-- Features
99−--
100−-- * omits nulls, empty objects and empty arrays (configurable)
101−-- * possible to add fields
102−-- * possible to merge sub-object
103−sopSwaggerGenericToJSON
104− :: forall a xs.
105− ( HasDatatypeInfo a
106− , HasSwaggerAesonOptions a
107− , All2 ToJSON (Code a)
108− , All2 Eq (Code a)
109− , Code a ~ '[xs]
110− )
111− => a
112− -> Value
113−sopSwaggerGenericToJSON x =
114− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
115− in object (opts ^. saoAdditionalPairs ++ ps)
116− where
117− proxy = Proxy :: Proxy a
118− opts = swaggerAesonOptions proxy
119−
120−-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)
121−--
122−-- Also uses default `aesonDefaults`
123−sopSwaggerGenericToJSONWithOpts
124− :: forall a xs.
125− ( Generic a
126− , All2 AesonDefaultValue (Code a)
127− , HasDatatypeInfo a
128− , All2 ToJSON (Code a)
129− , All2 Eq (Code a)
130− , Code a ~ '[xs]
131− )
132− => SwaggerAesonOptions
133− -> a
134− -> Value
135−sopSwaggerGenericToJSONWithOpts opts x =
136− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs
137− in object (opts ^. saoAdditionalPairs ++ ps)
138− where
139− proxy = Proxy :: Proxy a
140− defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
141−
142−sopSwaggerGenericToJSON'
143− :: (All2 ToJSON '[xs], All2 Eq '[xs])
144− => SwaggerAesonOptions
145− -> SOP I '[xs]
146− -> DatatypeInfo '[xs]
147− -> POP Maybe '[xs]
148− -> [Pair]
149−#if MIN_VERSION_generics_sop(0,5,0)
150−sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
151−#else
152−sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
153−#endif
154− sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
155−sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
156−
157−sopSwaggerGenericToJSON''
158− :: (All ToJSON xs, All Eq xs)
159− => SwaggerAesonOptions
160− -> NP I xs
161− -> NP FieldInfo xs
162− -> NP Maybe xs
163− -> [Pair]
164−sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
165− where
166− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
167− go Nil Nil Nil = []
168− go (I x :* xs) (FieldInfo name :* names) (def :* defs)
169− | Just name' == sub = case json of
170− Object m -> HM.toList m ++ rest
171− Null -> rest
172− _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
173− -- If default value: omit it.
174− | Just x == def =
175− rest
176− | otherwise =
177− (T.pack name', json) : rest
178− where
179− json = toJSON x
180− name' = fieldNameModifier name
181− rest = go xs names defs
182−#if __GLASGOW_HASKELL__ < 800
183− go _ _ _ = error "not empty"
184−#endif
185−
186− fieldNameModifier = modifier . drop 1
187− modifier = lowerFirstUppers . drop (length prefix)
188− lowerFirstUppers s = map toLower x ++ y
189− where (x, y) = span isUpper s
190−
191−-------------------------------------------------------------------------------
192−-- FromJSON
193−-------------------------------------------------------------------------------
194−
195−sopSwaggerGenericParseJSON
196− :: forall a xs.
197− ( HasDatatypeInfo a
198− , HasSwaggerAesonOptions a
199− , All2 FromJSON (Code a)
200− , All2 Eq (Code a)
201− , Code a ~ '[xs]
202− )
203− => Value
204− -> Parser a
205−sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->
206− let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)
207− in do
208− traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs)
209− to <$> ps
210− where
211− proxy = Proxy :: Proxy a
212− opts = swaggerAesonOptions proxy
213−
214− parseAdditionalField :: Object -> (Text, Value) -> Parser ()
215− parseAdditionalField obj (k, v) = do
216− v' <- obj .: k
217− unless (v == v') $ fail $
218− "Additonal field don't match for key " ++ T.unpack k
219− ++ ": " ++ show v
220− ++ " /= " ++ show v'
221−
222−sopSwaggerGenericParseJSON'
223− :: (All2 FromJSON '[xs], All2 Eq '[xs])
224− => SwaggerAesonOptions
225− -> Object
226− -> DatatypeInfo '[xs]
227− -> POP Maybe '[xs]
228− -> Parser (SOP I '[xs])
229−#if MIN_VERSION_generics_sop(0,5,0)
230−sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
231−#else
232−sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
233−#endif
234− SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
235−sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
236−
237−sopSwaggerGenericParseJSON''
238− :: (All FromJSON xs, All Eq xs)
239− => SwaggerAesonOptions
240− -> Object
241− -> NP FieldInfo xs
242− -> NP Maybe xs
243− -> Parser (NP I xs)
244−sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
245− where
246− go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
247− go Nil Nil = pure Nil
248− go (FieldInfo name :* names) (def :* defs)
249− | Just name' == sub =
250− -- Note: we might strip fields of outer structure.
251− cons <$> (withDef $ parseJSON $ Object obj) <*> rest
252− | otherwise = case def of
253− Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest
254− Nothing -> cons <$> obj .: T.pack name' <*> rest
255− where
256− cons h t = I h :* t
257− name' = fieldNameModifier name
258− rest = go names defs
259−
260− withDef = case def of
261− Just def' -> (<|> pure def')
262− Nothing -> id
263−#if __GLASGOW_HASKELL__ < 800
264− go _ _ = error "not empty"
265−#endif
266−
267− fieldNameModifier = modifier . drop 1
268− modifier = lowerFirstUppers . drop (length prefix)
269− lowerFirstUppers s = map toLower x ++ y
270− where (x, y) = span isUpper s
271−
272−-------------------------------------------------------------------------------
273−-- ToEncoding
274−-------------------------------------------------------------------------------
275−
276−#if MIN_VERSION_aeson(0,10,0)
277−
278−sopSwaggerGenericToEncoding
279− :: forall a xs.
280− ( HasDatatypeInfo a
281− , HasSwaggerAesonOptions a
282− , All2 ToJSON (Code a)
283− , All2 Eq (Code a)
284− , Code a ~ '[xs]
285− )
286− => a
287− -> Encoding
288−sopSwaggerGenericToEncoding x =
289− let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
290− in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)
291− where
292− proxy = Proxy :: Proxy a
293− opts = swaggerAesonOptions proxy
294−
295−pairsToSeries :: [Pair] -> Series
296−pairsToSeries = foldMap (\(k, v) -> (k .= v))
297−
298−sopSwaggerGenericToEncoding'
299− :: (All2 ToJSON '[xs], All2 Eq '[xs])
300− => SwaggerAesonOptions
301− -> SOP I '[xs]
302− -> DatatypeInfo '[xs]
303− -> POP Maybe '[xs]
304− -> Series
305−#if MIN_VERSION_generics_sop(0,5,0)
306−sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
307−#else
308−sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
309−#endif
310− sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
311−sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
312−
313−sopSwaggerGenericToEncoding''
314− :: (All ToJSON xs, All Eq xs)
315− => SwaggerAesonOptions
316− -> NP I xs
317− -> NP FieldInfo xs
318− -> NP Maybe xs
319− -> Series
320−sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go
321− where
322− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
323− go Nil Nil Nil = mempty
324− go (I x :* xs) (FieldInfo name :* names) (def :* defs)
325− | Just name' == sub = case toJSON x of
326− Object m -> pairsToSeries (HM.toList m) <> rest
327− Null -> rest
328− _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)
329− -- If default value: omit it.
330− | Just x == def =
331− rest
332− | otherwise =
333− (T.pack name' .= x) <> rest
334− where
335− name' = fieldNameModifier name
336− rest = go xs names defs
337−#if __GLASGOW_HASKELL__ < 800
338− go _ _ _ = error "not empty"
339−#endif
340−
341− fieldNameModifier = modifier . drop 1
342− modifier = lowerFirstUppers . drop (length prefix)
343− lowerFirstUppers s = map toLower x ++ y
344− where (x, y) = span isUpper s
345−
346−#endif
src/Data/Swagger/Internal/ParamSchema.hs+24−123
@@ -1,5 +1,3 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
31{-# LANGUAGE DefaultSignatures #-}
42{-# LANGUAGE FlexibleContexts #-}
53{-# LANGUAGE FlexibleInstances #-}
@@ -8,21 +6,12 @@
86{-# LANGUAGE PackageImports #-}
97{-# LANGUAGE PolyKinds #-}
108{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeFamilies #-}
129{-# LANGUAGE TypeOperators #-}
1310{-# LANGUAGE TypeSynonymInstances #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−#if __GLASGOW_HASKELL__ >= 800
16−-- Generic a is redundant in ToParamSchema a default imple
17−{-# OPTIONS_GHC -Wno-redundant-constraints #-}
18−-- For TypeErrors
19−{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
20−#endif
21−#include "overlapping-compat.h"
2211module Data.Swagger.Internal.ParamSchema where
2312
2413import Control.Lens
25−import Data.Aeson (ToJSON (..))
14+import Data.Aeson
2615import Data.Proxy
2716import GHC.Generics
2817
@@ -31,50 +20,15 @@ import "unordered-containers" Data.HashSet (HashSet)
3120import Data.Monoid
3221import Data.Set (Set)
3322import Data.Scientific
34−import Data.Fixed (HasResolution(..), Fixed, Pico)
3523import qualified Data.Text as T
3624import qualified Data.Text.Lazy as TL
3725import Data.Time
38−import qualified Data.Vector as V
39−import qualified Data.Vector.Primitive as VP
40−import qualified Data.Vector.Storable as VS
41−import qualified Data.Vector.Unboxed as VU
42−import Data.Version (Version)
43−import Numeric.Natural.Compat (Natural)
4426import Data.Word
45−import Data.UUID.Types (UUID)
46−import Web.Cookie (SetCookie)
4727
4828import Data.Swagger.Internal
4929import Data.Swagger.Lens
5030import Data.Swagger.SchemaOptions
5131
52−#if __GLASGOW_HASKELL__ < 800
53−#else
54−import qualified Data.ByteString as BS
55−import qualified Data.ByteString.Lazy as BSL
56−import GHC.TypeLits (TypeError, ErrorMessage(..))
57−#endif
58−
59−-- | Default schema for binary data (any sequence of octets).
60−binaryParamSchema :: ParamSchema t
61−binaryParamSchema = mempty
62− & type_ ?~ SwaggerString
63− & format ?~ "binary"
64−
65−-- | Default schema for binary data (base64 encoded).
66−byteParamSchema :: ParamSchema t
67−byteParamSchema = mempty
68− & type_ ?~ SwaggerString
69− & format ?~ "byte"
70−
71−-- | Default schema for password string.
72−-- @"password"@ format is used to hint UIs the input needs to be obscured.
73−passwordParamSchema :: ParamSchema t
74−passwordParamSchema = mempty
75− & type_ ?~ SwaggerString
76− & format ?~ "password"
77−
7832-- | Convert a type into a plain @'ParamSchema'@.
7933--
8034-- An example type and instance:
@@ -87,9 +41,9 @@ passwordParamSchema = mempty
8741-- data Direction = Up | Down
8842--
8943-- instance ToParamSchema Direction where
90−-- toParamSchema _ = mempty
91−-- & type_ ?~ SwaggerString
92−-- & enum_ ?~ [ \"Up\", \"Down\" ]
44+-- toParamSchema = mempty
45+-- & type_ .~ SwaggerString
46+-- & enum_ .~ [ \"Up\", \"Down\" ]
9347-- @
9448--
9549-- Instead of manually writing your @'ToParamSchema'@ instance you can
@@ -115,24 +69,18 @@ class ToParamSchema a where
11569 --
11670 -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
11771 -- "{\"type\":\"integer\"}"
118− toParamSchema :: Proxy a -> ParamSchema t
119− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t
72+ toParamSchema :: proxy a -> ParamSchema t
73+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t
12074 toParamSchema = genericToParamSchema defaultSchemaOptions
12175
122−instance OVERLAPPING_ ToParamSchema String where
123− toParamSchema _ = mempty & type_ ?~ SwaggerString
76+instance {-# OVERLAPPING #-} ToParamSchema String where
77+ toParamSchema _ = mempty & type_ .~ SwaggerString
12478
12579instance ToParamSchema Bool where
126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
80+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean
12781
12882instance ToParamSchema Integer where
129− toParamSchema _ = mempty & type_ ?~ SwaggerInteger
130−
131−instance ToParamSchema Natural where
132− toParamSchema _ = mempty
133− & type_ ?~ SwaggerInteger
134− & minimum_ ?~ 0
135− & exclusiveMinimum ?~ False
83+ toParamSchema _ = mempty & type_ .~ SwaggerInteger
13684
13785instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
13886instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
@@ -154,51 +102,40 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
154102--
155103-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
156104-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
157−toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
105+toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t
158106toParamSchemaBoundedIntegral _ = mempty
159− & type_ ?~ SwaggerInteger
107+ & type_ .~ SwaggerInteger
160108 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
161109 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
162110
163111instance ToParamSchema Char where
164112 toParamSchema _ = mempty
165− & type_ ?~ SwaggerString
113+ & type_ .~ SwaggerString
166114 & maxLength ?~ 1
167115 & minLength ?~ 1
168116
169117instance ToParamSchema Scientific where
170− toParamSchema _ = mempty & type_ ?~ SwaggerNumber
171−
172−instance HasResolution a => ToParamSchema (Fixed a) where
173− toParamSchema _ = mempty
174− & type_ ?~ SwaggerNumber
175− & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
118+ toParamSchema _ = mempty & type_ .~ SwaggerNumber
176119
177120instance ToParamSchema Double where
178121 toParamSchema _ = mempty
179− & type_ ?~ SwaggerNumber
122+ & type_ .~ SwaggerNumber
180123 & format ?~ "double"
181124
182125instance ToParamSchema Float where
183126 toParamSchema _ = mempty
184− & type_ ?~ SwaggerNumber
127+ & type_ .~ SwaggerNumber
185128 & format ?~ "float"
186129
187130timeParamSchema :: String -> ParamSchema t
188131timeParamSchema fmt = mempty
189− & type_ ?~ SwaggerString
132+ & type_ .~ SwaggerString
190133 & format ?~ T.pack fmt
191134
192135-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
193136instance ToParamSchema Day where
194137 toParamSchema _ = timeParamSchema "date"
195138
196−-- |
197−-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
198−-- Just "hh:MM:ss"
199−instance ToParamSchema TimeOfDay where
200− toParamSchema _ = timeParamSchema "hh:MM:ss"
201−
202139-- |
203140-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
204141-- Just "yyyy-mm-ddThh:MM:ss"
@@ -218,7 +155,7 @@ instance ToParamSchema UTCTime where
218155 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
219156
220157instance ToParamSchema NominalDiffTime where
221− toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
158+ toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)
222159
223160instance ToParamSchema T.Text where
224161 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
@@ -226,28 +163,6 @@ instance ToParamSchema T.Text where
226163instance ToParamSchema TL.Text where
227164 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
228165
229−instance ToParamSchema Version where
230− toParamSchema _ = mempty
231− & type_ ?~ SwaggerString
232− & pattern ?~ "^\\d+(\\.\\d+)*$"
233−
234−instance ToParamSchema SetCookie where
235− toParamSchema _ = mempty
236− & type_ ?~ SwaggerString
237−
238−
239−#if __GLASGOW_HASKELL__ < 800
240−#else
241−type family ToParamSchemaByteStringError bs where
242− ToParamSchemaByteStringError bs = TypeError
243− ( 'Text "Impossible to have an instance " :<>: ShowType (ToParamSchema bs) :<>: Text "."
244− :$$: 'Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."
245− :$$: 'Text "Consider using byteParamSchema or binaryParamSchema templates." )
246−
247−instance ToParamSchemaByteStringError BS.ByteString => ToParamSchema BS.ByteString where toParamSchema = error "impossible"
248−instance ToParamSchemaByteStringError BSL.ByteString => ToParamSchema BSL.ByteString where toParamSchema = error "impossible"
249−#endif
250−
251166instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
252167instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
253168instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
@@ -256,18 +171,11 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to
256171instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
257172instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
258173
259−instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
260−
261174instance ToParamSchema a => ToParamSchema [a] where
262175 toParamSchema _ = mempty
263− & type_ ?~ SwaggerArray
176+ & type_ .~ SwaggerArray
264177 & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
265178
266−instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
267−instance ToParamSchema a => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
268−instance ToParamSchema a => ToParamSchema (VS.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
269−instance ToParamSchema a => ToParamSchema (VU.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
270−
271179instance ToParamSchema a => ToParamSchema (Set a) where
272180 toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
273181 & uniqueItems ?~ True
@@ -280,25 +188,20 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
280188-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
281189instance ToParamSchema () where
282190 toParamSchema _ = mempty
283− & type_ ?~ SwaggerString
191+ & type_ .~ SwaggerString
284192 & enum_ ?~ ["_"]
285193
286−instance ToParamSchema UUID where
287− toParamSchema _ = mempty
288− & type_ ?~ SwaggerString
289− & format ?~ "uuid"
290−
291194-- | A configurable generic @'ParamSchema'@ creator.
292195--
293196-- >>> :set -XDeriveGeneric
294197-- >>> data Color = Red | Blue deriving Generic
295198-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
296199-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
297−genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t
200+genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t
298201genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
299202
300203class GToParamSchema (f :: * -> *) where
301− gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
204+ gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
302205
303206instance GToParamSchema f => GToParamSchema (D1 d f) where
304207 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
@@ -316,14 +219,14 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
316219 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
317220
318221class GEnumParamSchema (f :: * -> *) where
319− genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
222+ genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
320223
321224instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
322225 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
323226
324227instance Constructor c => GEnumParamSchema (C1 c U1) where
325228 genumParamSchema opts _ s = s
326− & type_ ?~ SwaggerString
229+ & type_ .~ SwaggerString
327230 & enum_ %~ addEnumValue tag
328231 where
329232 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
@@ -333,5 +236,3 @@ instance Constructor c => GEnumParamSchema (C1 c U1) where
333236
334237data Proxy3 a b c = Proxy3
335238
336−-- $setup
337−-- >>> import Data.Aeson (encode)
src/Data/Swagger/Internal/Schema.hs+90−403
@@ -1,10 +1,7 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
31{-# LANGUAGE DefaultSignatures #-}
42{-# LANGUAGE FlexibleContexts #-}
53{-# LANGUAGE FlexibleInstances #-}
64{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE DataKinds #-}
85{-# LANGUAGE OverloadedLists #-}
96{-# LANGUAGE OverloadedStrings #-}
107{-# LANGUAGE PackageImports #-}
@@ -14,69 +11,39 @@
1411{-# LANGUAGE TypeFamilies #-}
1512{-# LANGUAGE TypeOperators #-}
1613{-# LANGUAGE TypeSynonymInstances #-}
17−{-# LANGUAGE UndecidableInstances #-}
18−#if __GLASGOW_HASKELL__ >= 800
19−-- Few generics related redundant constraints
20−{-# OPTIONS_GHC -Wno-redundant-constraints #-}
21−-- For TypeErrors
22−{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
23−#endif
24−#include "overlapping-compat.h"
2514module Data.Swagger.Internal.Schema where
2615
27−import Prelude ()
28−import Prelude.Compat
29−
3016import Control.Lens
3117import Data.Data.Lens (template)
3218
3319import Control.Monad
3420import Control.Monad.Writer
35−import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
21+import Data.Aeson
3622import Data.Char
3723import Data.Data (Data)
3824import Data.Foldable (traverse_)
3925import Data.HashMap.Strict (HashMap)
4026import qualified Data.HashMap.Strict as HashMap
41−import "unordered-containers" Data.HashSet (HashSet)
42−import qualified "unordered-containers" Data.HashSet as HashSet
43−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
27+import "unordered-containers" Data.HashSet (HashSet)
4428import Data.Int
4529import Data.IntSet (IntSet)
4630import Data.IntMap (IntMap)
47−import Data.List.NonEmpty.Compat (NonEmpty)
4831import Data.Map (Map)
32+import Data.Monoid
4933import Data.Proxy
5034import Data.Scientific (Scientific)
51−import Data.Fixed (Fixed, HasResolution, Pico)
5235import Data.Set (Set)
5336import qualified Data.Text as T
5437import qualified Data.Text.Lazy as TL
5538import 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)
6239import Data.Word
6340import GHC.Generics
64−import qualified Data.UUID.Types as UUID
6541
6642import Data.Swagger.Declare
6743import Data.Swagger.Internal
6844import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
69−import Data.Swagger.Lens hiding (name, schema)
70−import qualified Data.Swagger.Lens as Swagger
45+import Data.Swagger.Lens
7146import Data.Swagger.SchemaOptions
72−import Data.Swagger.Internal.TypeShape
73−
74−#if __GLASGOW_HASKELL__ < 800
75−#else
76−import qualified Data.ByteString as BS
77−import qualified Data.ByteString.Lazy as BSL
78−import GHC.TypeLits (TypeError, ErrorMessage(..))
79−#endif
8047
8148unnamed :: Schema -> NamedSchema
8249unnamed schema = NamedSchema Nothing schema
@@ -102,21 +69,19 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
10269-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
10370--
10471-- import Control.Lens
105−-- import Data.Proxy
106−-- import Data.Swagger
10772--
10873-- data Coord = Coord { x :: Double, y :: Double }
10974--
11075-- instance ToSchema Coord where
111−-- declareNamedSchema _ = do
112−-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
113−-- return $ NamedSchema (Just \"Coord\") $ mempty
114−-- & type_ ?~ SwaggerObject
115−-- & properties .~
116−-- [ (\"x\", doubleSchema)
117−-- , (\"y\", doubleSchema)
118−-- ]
119−-- & required .~ [ \"x\", \"y\" ]
76+-- declareNamedSchema = pure (Just \"Coord\", schema)
77+-- where
78+-- schema = mempty
79+-- & type_ .~ SwaggerObject
80+-- & properties .~
81+-- [ (\"x\", toSchemaRef (Proxy :: Proxy Double))
82+-- , (\"y\", toSchemaRef (Proxy :: Proxy Double))
83+-- ]
84+-- & required .~ [ \"x\", \"y\" ]
12085-- @
12186--
12287-- Instead of manually writing your @'ToSchema'@ instance you can
@@ -142,17 +107,12 @@ class ToSchema a where
142107 -- together with all used definitions.
143108 -- Note that the schema itself is included in definitions
144109 -- only if it is recursive (and thus needs its definition in scope).
145− declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
146− default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
147− Proxy a -> Declare (Definitions Schema) NamedSchema
110+ declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
111+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
148112 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
149113
150−instance ToSchema TimeOfDay where
151− declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152− & example ?~ toJSON (TimeOfDay 12 33 15)
153−
154114-- | Convert a type into a schema and declare all used schema definitions.
155−declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
115+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
156116declareSchema = fmap _namedSchemaSchema . declareNamedSchema
157117
158118-- | Convert a type into an optionally named schema.
@@ -165,8 +125,8 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
165125-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
166126-- Just "Day"
167127-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
168−-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
169−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
128+-- "{\"format\":\"date\",\"type\":\"string\"}"
129+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
170130toNamedSchema = undeclare . declareNamedSchema
171131
172132-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -176,7 +136,7 @@ toNamedSchema = undeclare . declareNamedSchema
176136--
177137-- >>> schemaName (Proxy :: Proxy UTCTime)
178138-- Just "UTCTime"
179−schemaName :: ToSchema a => Proxy a -> Maybe T.Text
139+schemaName :: ToSchema a => proxy a -> Maybe T.Text
180140schemaName = _namedSchemaName . toNamedSchema
181141
182142-- | Convert a type into a schema.
@@ -186,7 +146,7 @@ schemaName = _namedSchemaName . toNamedSchema
186146--
187147-- >>> encode $ toSchema (Proxy :: Proxy [Day])
188148-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
189−toSchema :: ToSchema a => Proxy a -> Schema
149+toSchema :: ToSchema a => proxy a -> Schema
190150toSchema = _namedSchemaSchema . toNamedSchema
191151
192152-- | Convert a type into a referenced schema if possible.
@@ -197,7 +157,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
197157--
198158-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
199159-- "{\"$ref\":\"#/definitions/Day\"}"
200−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
160+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
201161toSchemaRef = undeclare . declareSchemaRef
202162
203163-- | Convert a type into a referenced schema if possible
@@ -207,7 +167,7 @@ toSchemaRef = undeclare . declareSchemaRef
207167-- Schema definitions are typically declared for every referenced schema.
208168-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
209169-- will be declared (regardless of whether it is recusive or not).
210−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
170+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
211171declareSchemaRef proxy = do
212172 case toNamedSchema proxy of
213173 NamedSchema (Just name) schema -> do
@@ -219,7 +179,7 @@ declareSchemaRef proxy = do
219179 -- have already declared it.
220180 -- If we have, we don't need to declare anything for
221181 -- this schema this time and thus simply return the reference.
222− known <- looks (InsOrdHashMap.member name)
182+ known <- looks (HashMap.member name)
223183 when (not known) $ do
224184 declare [(name, schema)]
225185 void $ declareNamedSchema proxy
@@ -238,7 +198,7 @@ inlineSchemasWhen p defs = template %~ deref
238198 where
239199 deref r@(Ref (Reference name))
240200 | p name =
241− case InsOrdHashMap.lookup name defs of
201+ case HashMap.lookup name defs of
242202 Just schema -> Inline (inlineSchemasWhen p defs schema)
243203 Nothing -> r
244204 | otherwise = r
@@ -265,11 +225,11 @@ inlineAllSchemas = inlineSchemasWhen (const True)
265225-- | Convert a type into a schema without references.
266226--
267227-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
268−-- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
228+-- "{\"items\":{\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
269229--
270230-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
271231-- when inlining recursive schemas.
272−toInlinedSchema :: ToSchema a => Proxy a -> Schema
232+toInlinedSchema :: ToSchema a => proxy a -> Schema
273233toInlinedSchema proxy = inlineAllSchemas defs schema
274234 where
275235 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -280,7 +240,7 @@ inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
280240inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
281241 where
282242 nonRecursive name =
283− case InsOrdHashMap.lookup name defs of
243+ case HashMap.lookup name defs of
284244 Just schema -> name `notElem` execDeclare (usedNames schema) mempty
285245 Nothing -> False
286246
@@ -292,141 +252,22 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
292252 seen <- looks (name `elem`)
293253 when (not seen) $ do
294254 declare [name]
295− traverse_ usedNames (InsOrdHashMap.lookup name defs)
255+ traverse_ usedNames (HashMap.lookup name defs)
296256 Inline subschema -> usedNames subschema
297257
298−-- | Default schema for binary data (any sequence of octets).
299−binarySchema :: Schema
300−binarySchema = mempty
301− & type_ ?~ SwaggerString
302− & format ?~ "binary"
303−
304−-- | Default schema for binary data (base64 encoded).
305−byteSchema :: Schema
306−byteSchema = mempty
307− & type_ ?~ SwaggerString
308− & format ?~ "byte"
309−
310−-- | Default schema for password string.
311−-- @"password"@ format is used to hint UIs the input needs to be obscured.
312−passwordSchema :: Schema
313−passwordSchema = mempty
314− & type_ ?~ SwaggerString
315− & format ?~ "password"
316−
317−-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
318−-- Produced schema can be used for further refinement.
319−--
320−-- >>> encode $ sketchSchema "hello"
321−-- "{\"example\":\"hello\",\"type\":\"string\"}"
322−--
323−-- >>> encode $ sketchSchema (1, 2, 3)
324−-- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}"
325−--
326−-- >>> encode $ sketchSchema ("Jack", 25)
327−-- "{\"example\":[\"Jack\",25],\"items\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"type\":\"array\"}"
328−--
329−-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
330−-- >>> instance ToJSON Person
331−-- >>> encode $ sketchSchema (Person "Jack" 25)
332−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"
333−sketchSchema :: ToJSON a => a -> Schema
334−sketchSchema = sketch . toJSON
335− where
336− sketch Null = go Null
337− sketch js@(Bool _) = go js
338− sketch js = go js & example ?~ js
339−
340− go Null = mempty & type_ ?~ SwaggerNull
341− go (Bool _) = mempty & type_ ?~ SwaggerBoolean
342− go (String _) = mempty & type_ ?~ SwaggerString
343− go (Number _) = mempty & type_ ?~ SwaggerNumber
344− go (Array xs) = mempty
345− & type_ ?~ SwaggerArray
346− & items ?~ case ischema of
347− Just s -> SwaggerItemsObject (Inline s)
348− _ -> SwaggerItemsArray (map Inline ys)
349− where
350− ys = map go (V.toList xs)
351− allSame = and ((zipWith (==)) ys (tail ys))
352−
353− ischema = case ys of
354− (z:_) | allSame -> Just z
355− _ -> Nothing
356− go (Object o) = mempty
357− & type_ ?~ SwaggerObject
358− & required .~ HashMap.keys o
359− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
360−
361−-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
362−-- Produced schema uses as much constraints as possible.
363−--
364−-- >>> encode $ sketchStrictSchema "hello"
365−-- "{\"maxLength\":5,\"pattern\":\"hello\",\"minLength\":5,\"type\":\"string\",\"enum\":[\"hello\"]}"
366−--
367−-- >>> encode $ sketchStrictSchema (1, 2, 3)
368−-- "{\"minItems\":3,\"uniqueItems\":true,\"items\":[{\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\",\"enum\":[1]},{\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\",\"enum\":[2]},{\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\",\"enum\":[3]}],\"maxItems\":3,\"type\":\"array\",\"enum\":[[1,2,3]]}"
369−--
370−-- >>> encode $ sketchStrictSchema ("Jack", 25)
371−-- "{\"minItems\":2,\"uniqueItems\":true,\"items\":[{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]},{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]}],\"maxItems\":2,\"type\":\"array\",\"enum\":[[\"Jack\",25]]}"
372−--
373−-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
374−-- >>> instance ToJSON Person
375−-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
376−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}},\"maxProperties\":2,\"minProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}]}"
377−sketchStrictSchema :: ToJSON a => a -> Schema
378−sketchStrictSchema = go . toJSON
379− where
380− go Null = mempty & type_ ?~ SwaggerNull
381− go js@(Bool _) = mempty
382− & type_ ?~ SwaggerBoolean
383− & enum_ ?~ [js]
384− go js@(String s) = mempty
385− & type_ ?~ SwaggerString
386− & maxLength ?~ fromIntegral (T.length s)
387− & minLength ?~ fromIntegral (T.length s)
388− & pattern ?~ s
389− & enum_ ?~ [js]
390− go js@(Number n) = mempty
391− & type_ ?~ SwaggerNumber
392− & maximum_ ?~ n
393− & minimum_ ?~ n
394− & multipleOf ?~ n
395− & enum_ ?~ [js]
396− go js@(Array xs) = mempty
397− & type_ ?~ SwaggerArray
398− & maxItems ?~ fromIntegral sz
399− & minItems ?~ fromIntegral sz
400− & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
401− & uniqueItems ?~ allUnique
402− & enum_ ?~ [js]
403− where
404− sz = length xs
405− allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
406− go js@(Object o) = mempty
407− & type_ ?~ SwaggerObject
408− & required .~ names
409− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
410− & maxProperties ?~ fromIntegral (length names)
411− & minProperties ?~ fromIntegral (length names)
412− & enum_ ?~ [js]
413− where
414− names = HashMap.keys o
415−
416258class GToSchema (f :: * -> *) where
417− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
259+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
418260
419−instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
261+instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
420262 declareNamedSchema _ = do
421263 ref <- declareSchemaRef (Proxy :: Proxy a)
422264 return $ unnamed $ mempty
423− & type_ ?~ SwaggerArray
265+ & type_ .~ SwaggerArray
424266 & items ?~ SwaggerItemsObject ref
425267
426−instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
268+instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
427269instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
428270instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
430271instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
431272instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
432273instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
@@ -438,16 +279,11 @@ instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
438279instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
439280instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
440281
441−instance ToSchema Char where
442− declareNamedSchema proxy = plain (paramSchemaToSchema proxy)
443− & mapped.Swagger.schema.example ?~ toJSON '?'
444−
282+instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema
445283instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
446284instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
447285instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
448286
449−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
450−
451287instance ToSchema a => ToSchema (Maybe a) where
452288 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
453289
@@ -456,11 +292,6 @@ instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
456292instance ToSchema () where
457293 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
458294
459−-- | For 'ToJSON' instance, see <http://hackage.haskell.org/package/uuid-aeson uuid-aeson> package.
460−instance ToSchema UUID.UUID where
461− declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
462− & example ?~ toJSON (UUID.toText UUID.nil)
463−
464295instance (ToSchema a, ToSchema b) => ToSchema (a, b)
465296instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
466297instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
@@ -470,81 +301,46 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
470301
471302timeSchema :: T.Text -> Schema
472303timeSchema fmt = mempty
473− & type_ ?~ SwaggerString
304+ & type_ .~ SwaggerString
474305 & format ?~ fmt
475306
476307-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
477308instance ToSchema Day where
478− declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"
479− & example ?~ toJSON (fromGregorian 2016 7 22)
309+ declareNamedSchema _ = pure $ named "Day" (timeSchema "date")
480310
481311-- |
482312-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
483313-- Just "yyyy-mm-ddThh:MM:ss"
484314instance ToSchema LocalTime where
485− declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
486− & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
315+ declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")
487316
488317-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
489318instance ToSchema ZonedTime where
490319 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
491− & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
492320
493321instance ToSchema NominalDiffTime where
494− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
322+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
495323
496324-- |
497325-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
498326-- Just "yyyy-mm-ddThh:MM:ssZ"
499327instance ToSchema UTCTime where
500− declareNamedSchema _ = pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"
501− & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)
328+ declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")
502329
503330instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
504331instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
505332
506−instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
507−
508−#if __GLASGOW_HASKELL__ < 800
509−#else
510−type family ToSchemaByteStringError bs where
511− ToSchemaByteStringError bs = TypeError
512− ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."
513− :$$: Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."
514− :$$: Text "Consider using byteSchema or binarySchema templates." )
515−
516−instance ToSchemaByteStringError BS.ByteString => ToSchema BS.ByteString where declareNamedSchema = error "impossible"
517−instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"
518−#endif
519−
520333instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
521334
522335-- | NOTE: This schema does not account for the uniqueness of keys.
523336instance ToSchema a => ToSchema (IntMap a) where
524337 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
525338
526−#if MIN_VERSION_aeson(1,0,0)
527−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
528− declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of
529− ToJSONKeyText _ _ -> declareObjectMapSchema
530− ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])
531− where
532− declareObjectMapSchema = do
533− schema <- declareSchemaRef (Proxy :: Proxy v)
534− return $ unnamed $ mempty
535− & type_ ?~ SwaggerObject
536− & additionalProperties ?~ AdditionalPropertiesSchema schema
537−
538−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
539− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
540−
541−#else
542−
543339instance ToSchema a => ToSchema (Map String a) where
544340 declareNamedSchema _ = do
545− schema <- declareSchemaRef (Proxy :: Proxy a)
341+ schema <- declareSchema (Proxy :: Proxy a)
546342 return $ unnamed $ mempty
547− & type_ ?~ SwaggerObject
343+ & type_ .~ SwaggerObject
548344 & additionalProperties ?~ schema
549345
550346instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -554,19 +350,6 @@ instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ =
554350instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
555351instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
556352
557−#endif
558−
559−instance OVERLAPPING_ ToSchema Object where
560− declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
561− & type_ ?~ SwaggerObject
562− & description ?~ "Arbitrary JSON object."
563− & additionalProperties ?~ AdditionalPropertiesAllowed True
564−
565−instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
566−instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
567−instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
568−instance ToSchema a => ToSchema (VP.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
569−
570353instance ToSchema a => ToSchema (Set a) where
571354 declareNamedSchema _ = do
572355 schema <- declareSchema (Proxy :: Proxy [a])
@@ -575,13 +358,6 @@ instance ToSchema a => ToSchema (Set a) where
575358
576359instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
577360
578−-- | @since 2.2.1
579−instance ToSchema a => ToSchema (NonEmpty a) where
580− declareNamedSchema _ = do
581− schema <- declareSchema (Proxy :: Proxy [a])
582− return $ unnamed $ schema
583− & minItems .~ Just 1
584−
585361instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
586362instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
587363
@@ -591,161 +367,81 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname
591367instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
592368instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
593369
594−instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
595−
596370-- | Default schema for @'Bounded'@, @'Integral'@ types.
597371--
598372-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
599373-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
600−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
374+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
601375toSchemaBoundedIntegral _ = mempty
602− & type_ ?~ SwaggerInteger
376+ & type_ .~ SwaggerInteger
603377 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
604378 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
605379
606380-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
607−genericToNamedSchemaBoundedIntegral :: forall a d f.
381+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
608382 ( Bounded a, Integral a
609383 , Generic a, Rep a ~ D1 d f, Datatype d)
610− => SchemaOptions -> Proxy a -> NamedSchema
384+ => SchemaOptions -> proxy a -> NamedSchema
611385genericToNamedSchemaBoundedIntegral opts proxy
612− = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
613−
614−-- | Declare a named schema for a @newtype@ wrapper.
615−genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
616− (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
617− => SchemaOptions -- ^ How to derive the name.
618− -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.
619− -> Proxy a
620− -> Declare (Definitions Schema) NamedSchema
621−genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
622−
623−-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
624−-- This makes a much more useful schema when there aren't many options for key values.
625−--
626−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
627−-- >>> instance ToJSON ButtonState
628−-- >>> instance ToSchema ButtonState
629−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
630−-- >>> type ImageUrl = T.Text
631−-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
632−-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
633−--
634−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
635−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
636−declareSchemaBoundedEnumKeyMapping :: forall map key value.
637− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
638− => Proxy (map key value) -> Declare (Definitions Schema) Schema
639−declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
640− ToJSONKeyText keyToText _ -> objectSchema keyToText
641− ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
642− where
643− objectSchema keyToText = do
644− valueRef <- declareSchemaRef (Proxy :: Proxy value)
645− let allKeys = [minBound..maxBound :: key]
646− mkPair k = (keyToText k, valueRef)
647− return $ mempty
648− & type_ ?~ SwaggerObject
649− & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
650−
651−-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
652−-- This makes a much more useful schema when there aren't many options for key values.
653−--
654−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
655−-- >>> instance ToJSON ButtonState
656−-- >>> instance ToSchema ButtonState
657−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
658−-- >>> type ImageUrl = T.Text
659−-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
660−-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
661−--
662−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
663−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
664−toSchemaBoundedEnumKeyMapping :: forall map key value.
665− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
666− => Proxy (map key value) -> Schema
667−toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
386+ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
668387
669388-- | A configurable generic @'Schema'@ creator.
670−genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
671− SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
672−genericDeclareSchema = genericDeclareSchemaUnrestricted
389+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
390+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
673391
674392-- | A configurable generic @'NamedSchema'@ creator.
675393-- This function applied to @'defaultSchemaOptions'@
676394-- is used as the default for @'declareNamedSchema'@
677395-- when the type is an instance of @'Generic'@.
678−genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
679− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
680−genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
396+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
397+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
681398
682−-- | A configurable generic @'Schema'@ creator.
683−--
684−-- Unlike 'genericDeclareSchema' also works for mixed sum types.
685−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
686−genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
687−genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
688−
689−-- | A configurable generic @'NamedSchema'@ creator.
690−--
691−-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
692−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
693−genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>
694− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
695−genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
696−
697−-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
698−genericNameSchema :: forall a d f.
699− (Generic a, Rep a ~ D1 d f, Datatype d)
700− => SchemaOptions -> Proxy a -> Schema -> NamedSchema
701−genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
702−
703−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
704−gdatatypeSchemaName opts _ = case orig of
399+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
400+gdatatypeSchemaName opts _ = case name of
705401 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
706402 _ -> Nothing
707403 where
708− orig = datatypeName (Proxy3 :: Proxy3 d f a)
709− name = datatypeNameModifier opts orig
404+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
710405
711406-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
712−paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
713− SchemaOptions -> Proxy a -> NamedSchema
714−paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
407+paramSchemaToNamedSchema :: forall a d f proxy.
408+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
409+ => SchemaOptions -> proxy a -> NamedSchema
410+paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
715411
716412-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
717−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
718−paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
413+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
414+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
719415
720416nullarySchema :: Schema
721417nullarySchema = mempty
722− & type_ ?~ SwaggerArray
418+ & type_ .~ SwaggerArray
723419 & items ?~ SwaggerItemsArray []
724420
725−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
421+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
726422gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
727423
728−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
424+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
729425gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
730426
731427instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
732428 gdeclareNamedSchema opts _ schema = do
733− NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema
734− gdeclareNamedSchema opts (Proxy :: Proxy g) gschema
429+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema
430+ gdeclareNamedSchema opts (Proxy :: Proxy f) gschema
735431
736432instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
737433 gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
738434 where
739435 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
740436
741−instance OVERLAPPABLE_ GToSchema f => GToSchema (C1 c f) where
437+instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
742438 gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)
743439
744−instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
440+instance {-# OVERLAPPING #-} Constructor c => GToSchema (C1 c U1) where
745441 gdeclareNamedSchema = gdeclareNamedSumSchema
746442
747443-- | Single field constructor.
748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
444+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
749445 gdeclareNamedSchema opts _ s
750446 | unwrapUnaryRecords opts = fieldSchema
751447 | otherwise =
@@ -759,7 +455,7 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
759455 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
760456 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
761457
762−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
458+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
763459gdeclareSchemaRef opts proxy = do
764460 case gtoNamedSchema opts proxy of
765461 NamedSchema (Just name) schema -> do
@@ -771,16 +467,16 @@ gdeclareSchemaRef opts proxy = do
771467 -- have already declared it.
772468 -- If we have, we don't need to declare anything for
773469 -- this schema this time and thus simply return the reference.
774− known <- looks (InsOrdHashMap.member name)
470+ known <- looks (HashMap.member name)
775471 when (not known) $ do
776472 declare [(name, schema)]
777473 void $ gdeclareNamedSchema opts proxy mempty
778474 return $ Ref (Reference name)
779475 _ -> Inline <$> gdeclareSchema opts proxy
780476
781−appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
477+appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)
782478appendItem x Nothing = Just (SwaggerItemsArray [x])
783−appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
479+appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs))
784480appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
785481
786482withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
@@ -790,40 +486,35 @@ withFieldSchema opts _ isRequiredField schema = do
790486 return $
791487 if T.null fname
792488 then schema
793− & type_ ?~ SwaggerArray
489+ & type_ .~ SwaggerArray
794490 & items %~ appendItem ref
795− & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796− & minItems %~ Just . maybe 1 (+1) -- increment minItems
797491 else schema
798− & type_ ?~ SwaggerObject
492+ & type_ .~ SwaggerObject
799493 & properties . at fname ?~ ref
800494 & if isRequiredField
801− then required %~ (++ [fname])
495+ then required %~ (fname :)
802496 else id
803497 where
804498 fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
805499
806500-- | Optional record fields.
807−instance OVERLAPPING_ (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
501+instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
808502 gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
809503
810504-- | Record fields.
811−instance OVERLAPPABLE_ (Selector s, GToSchema f) => GToSchema (S1 s f) where
505+instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
812506 gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
813507
814−instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
508+instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
815509 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
816510
817−instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
511+instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
818512 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
819513
820−instance ( GSumToSchema f
821− , GSumToSchema g
822− ) => GToSchema (f :+: g)
823− where
514+instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
824515 gdeclareNamedSchema = gdeclareNamedSumSchema
825516
826−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
517+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
827518gdeclareNamedSumSchema opts proxy s
828519 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
829520 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -832,34 +523,34 @@ gdeclareNamedSumSchema opts proxy s
832523 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
833524
834525 toStringTag schema = mempty
835− & type_ ?~ SwaggerString
836− & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
526+ & type_ .~ SwaggerString
527+ & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
837528
838529type AllNullary = All
839530
840−class GSumToSchema (f :: * -> *) where
841− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
531+class GSumToSchema f where
532+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
842533
843534instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
844− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
535+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)
845536
846−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
847− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
537+gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
538+ Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
848539gsumConToSchemaWith ref opts _ schema = schema
849− & type_ ?~ SwaggerObject
540+ & type_ .~ SwaggerObject
850541 & properties . at tag ?~ ref
851542 & maxProperties ?~ 1
852543 & minProperties ?~ 1
853544 where
854545 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
855546
856−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
857− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
547+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
548+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
858549gsumConToSchema opts proxy schema = do
859550 ref <- gdeclareSchemaRef opts proxy
860551 return $ gsumConToSchemaWith ref opts proxy schema
861552
862−instance OVERLAPPABLE_ (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
553+instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
863554 gsumToSchema opts proxy schema = do
864555 tell (All False)
865556 lift $ gsumConToSchema opts proxy schema
@@ -876,7 +567,3 @@ data Proxy2 a b = Proxy2
876567
877568data Proxy3 a b c = Proxy3
878569
879−-- $setup
880−-- >>> import Data.Swagger
881−-- >>> import Data.Aeson (encode)
882−-- >>> import Data.Aeson.Types (toJSONKeyText)
src/Data/Swagger/Internal/Schema/Validation.hsdeleted−511
@@ -1,511 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE PackageImports #-}
11−{-# LANGUAGE RankNTypes #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−-- |
16−-- Module: Data.Swagger.Internal.Schema.Validation
17−-- Copyright: (c) 2015 GetShopTV
18−-- License: BSD3
19−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
20−-- Stability: experimental
21−--
22−-- Validate JSON values with Swagger Schema.
23−module Data.Swagger.Internal.Schema.Validation where
24−
25−import Prelude ()
26−import Prelude.Compat
27−
28−import Control.Applicative
29−import Control.Lens
30−import Control.Monad (when)
31−
32−import Data.Aeson hiding (Result)
33−import Data.Aeson.Encode.Pretty (encodePretty)
34−import Data.Foldable (for_, sequenceA_,
35− traverse_)
36−import Data.HashMap.Strict (HashMap)
37−import qualified Data.HashMap.Strict as HashMap
38−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
39−import qualified "unordered-containers" Data.HashSet as HashSet
40−import Data.Proxy
41−import Data.Scientific (Scientific, isInteger)
42−import Data.Text (Text)
43−import qualified Data.Text as Text
44−import qualified Data.Text.Lazy as TL
45−import qualified Data.Text.Lazy.Encoding as TL
46−import Data.Vector (Vector)
47−import qualified Data.Vector as Vector
48−
49−import Data.Swagger.Declare
50−import Data.Swagger.Internal
51−import Data.Swagger.Internal.Schema
52−import Data.Swagger.Lens
53−
54−-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
55−-- This can be used with QuickCheck to ensure those instances are coherent:
56−--
57−-- prop> validateToJSON (x :: Int) == []
58−--
59−-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
60−-- See @'validateToJSONWithPatternChecker'@.
61−--
62−-- See 'renderValidationErrors' on how the output is structured.
63−validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String
64−validatePrettyToJSON = renderValidationErrors validateToJSON
65−
66−-- | Variant of 'validatePrettyToJSON' with typed output.
67−validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
68−validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
69−
70−-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
71−-- This can be used with QuickCheck to ensure those instances are coherent.
72−--
73−-- For validation without patterns see @'validateToJSON'@. See also:
74−-- 'renderValidationErrors'.
75−validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]
76−validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON
77− where
78− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
79−
80−-- | Pretty print validation errors
81−-- together with actual JSON and Swagger Schema
82−-- (using 'encodePretty').
83−--
84−-- >>> import Data.Aeson as Aeson
85−-- >>> import Data.Foldable (traverse_)
86−-- >>> import GHC.Generics
87−-- >>> data Phone = Phone { value :: String } deriving (Generic)
88−-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)
89−-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]
90−-- >>> instance ToSchema Phone
91−-- >>> instance ToSchema Person
92−-- >>> let person = Person { name = "John", phone = Phone "123456" }
93−-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person
94−-- Validation against the schema fails:
95−-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
96−-- <BLANKLINE>
97−-- JSON value:
98−-- {
99−-- "name": "John"
100−-- }
101−-- <BLANKLINE>
102−-- Swagger Schema:
103−-- {
104−-- "required": [
105−-- "name",
106−-- "phone"
107−-- ],
108−-- "type": "object",
109−-- "properties": {
110−-- "phone": {
111−-- "$ref": "#/definitions/Phone"
112−-- },
113−-- "name": {
114−-- "type": "string"
115−-- }
116−-- }
117−-- }
118−-- <BLANKLINE>
119−-- Swagger Description Context:
120−-- {
121−-- "Phone": {
122−-- "required": [
123−-- "value"
124−-- ],
125−-- "type": "object",
126−-- "properties": {
127−-- "value": {
128−-- "type": "string"
129−-- }
130−-- }
131−-- }
132−-- }
133−-- <BLANKLINE>
134−renderValidationErrors
135− :: forall a. (ToJSON a, ToSchema a)
136− => (a -> [ValidationError]) -> a -> Maybe String
137−renderValidationErrors f x =
138− case f x of
139− [] -> Nothing
140− errors -> Just $ unlines
141− [ "Validation against the schema fails:"
142− , unlines (map (" * " ++) errors)
143− , "JSON value:"
144− , ppJSONString (toJSON x)
145− , ""
146− , "Swagger Schema:"
147− , ppJSONString (toJSON schema_)
148− , ""
149− , "Swagger Description Context:"
150− , ppJSONString (toJSON refs_)
151− ]
152− where
153− ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty
154− (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
155−
156−-- | Validate JSON @'Value'@ against Swagger @'Schema'@.
157−--
158−-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []
159−--
160−-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.
161−-- See @'validateJSONWithPatternChecker'@.
162−validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]
163−validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True)
164−
165−-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker.
166−--
167−-- For validation without patterns see @'validateJSON'@.
168−validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]
169−validateJSONWithPatternChecker checker defs sch js =
170− case runValidation (validateWithSchema js) cfg sch of
171− Failed xs -> xs
172− Passed _ -> mempty
173− where
174− cfg = defaultConfig
175− { configPatternChecker = checker
176− , configDefinitions = defs }
177−
178−-- | Validation error message.
179−type ValidationError = String
180−
181−-- | Validation result type.
182−data Result a
183− = Failed [ValidationError] -- ^ Validation failed with a list of error messages.
184− | Passed a -- ^ Validation passed.
185− deriving (Eq, Show, Functor)
186−
187−instance Applicative Result where
188− pure = Passed
189− Passed f <*> Passed x = Passed (f x)
190− Failed xs <*> Failed ys = Failed (xs <> ys)
191− Failed xs <*> _ = Failed xs
192− _ <*> Failed ys = Failed ys
193−
194−instance Alternative Result where
195− empty = Failed mempty
196− Passed x <|> _ = Passed x
197− _ <|> y = y
198−
199−instance Monad Result where
200− return = pure
201− Passed x >>= f = f x
202− Failed xs >>= _ = Failed xs
203−
204−-- | Validation configuration.
205−data Config = Config
206− { -- | Pattern checker for @'_paramSchemaPattern'@ validation.
207− configPatternChecker :: Pattern -> Text -> Bool
208− -- | Schema definitions in scope to resolve references.
209− , configDefinitions :: Definitions Schema
210− }
211−
212−-- | Default @'Config'@:
213−--
214−-- @
215−-- defaultConfig = 'Config'
216−-- { 'configPatternChecker' = \\_pattern _str -> True
217−-- , 'configDefinitions' = mempty
218−-- }
219−-- @
220−defaultConfig :: Config
221−defaultConfig = Config
222− { configPatternChecker = \_pattern _str -> True
223− , configDefinitions = mempty
224− }
225−
226−-- | Value validation.
227−newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }
228− deriving (Functor)
229−
230−instance Applicative (Validation schema) where
231− pure x = Validation (\_ _ -> pure x)
232− Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)
233−
234−instance Alternative (Validation schema) where
235− empty = Validation (\_ _ -> empty)
236− Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)
237−
238−instance Profunctor Validation where
239− dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))
240−
241−instance Choice Validation where
242− left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))
243− right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))
244−
245−instance Monad (Validation s) where
246− return = pure
247− Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)
248− (>>) = (*>)
249−
250−withConfig :: (Config -> Validation s a) -> Validation s a
251−withConfig f = Validation (\c -> runValidation (f c) c)
252−
253−withSchema :: (s -> Validation s a) -> Validation s a
254−withSchema f = Validation (\c s -> runValidation (f s) c s)
255−
256−-- | Issue an error message.
257−invalid :: String -> Validation schema a
258−invalid msg = Validation (\_ _ -> Failed [msg])
259−
260−-- | Validation passed.
261−valid :: Validation schema ()
262−valid = pure ()
263−
264−-- | Validate schema's property given a lens into that property
265−-- and property checker.
266−checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
267−checkMissing missing l g = withSchema $ \sch ->
268− case sch ^. l of
269− Nothing -> missing
270− Just x -> g x
271−
272−-- | Validate schema's property given a lens into that property
273−-- and property checker.
274−-- If property is missing in schema, consider it valid.
275−check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
276−check = checkMissing valid
277−
278−-- | Validate same value with different schema.
279−sub :: t -> Validation t a -> Validation s a
280−sub = lmap . const
281−
282−-- | Validate same value with a part of the original schema.
283−sub_ :: Getting a s a -> Validation a r -> Validation s r
284−sub_ = lmap . view
285−
286−-- | Validate value against a schema given schema reference and validation function.
287−withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
288−withRef (Reference ref) f = withConfig $ \cfg ->
289− case InsOrdHashMap.lookup ref (configDefinitions cfg) of
290− Nothing -> invalid $ "unknown schema " ++ show ref
291− Just s -> f s
292−
293−validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
294−validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)
295−validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
296−
297−-- | Validate JSON @'Value'@ with Swagger @'Schema'@.
298−validateWithSchema :: Value -> Validation Schema ()
299−validateWithSchema value = do
300− validateSchemaType value
301− sub_ paramSchema $ validateEnum value
302−
303−-- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@.
304−validateWithParamSchema :: Value -> Validation (ParamSchema t) ()
305−validateWithParamSchema value = do
306− validateParamSchemaType value
307− validateEnum value
308−
309−validateInteger :: Scientific -> Validation (ParamSchema t) ()
310−validateInteger n = do
311− when (not (isInteger n)) $
312− invalid ("not an integer")
313− validateNumber n
314−
315−validateNumber :: Scientific -> Validation (ParamSchema t) ()
316−validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do
317− let exMax = Just True == sch ^. exclusiveMaximum
318− exMin = Just True == sch ^. exclusiveMinimum
319−
320− check maximum_ $ \m ->
321− when (if exMax then (n >= m) else (n > m)) $
322− invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")
323−
324− check minimum_ $ \m ->
325− when (if exMin then (n <= m) else (n < m)) $
326− invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")")
327−
328− check multipleOf $ \k ->
329− when (not (isInteger (n / k))) $
330− invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)
331−
332−validateString :: Text -> Validation (ParamSchema t) ()
333−validateString s = do
334− check maxLength $ \n ->
335− when (len > fromInteger n) $
336− invalid ("string is too long (length should be <=" ++ show n ++ ")")
337−
338− check minLength $ \n ->
339− when (len < fromInteger n) $
340− invalid ("string is too short (length should be >=" ++ show n ++ ")")
341−
342− check pattern $ \regex -> do
343− withConfig $ \cfg -> do
344− when (not (configPatternChecker cfg regex s)) $
345− invalid ("string does not match pattern " ++ show regex)
346− where
347− len = Text.length s
348−
349−validateArray :: Vector Value -> Validation (ParamSchema t) ()
350−validateArray xs = do
351− check maxItems $ \n ->
352− when (len > fromInteger n) $
353− invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")")
354−
355− check minItems $ \n ->
356− when (len < fromInteger n) $
357− invalid ("array is too short (size should be >=" ++ show n ++ ")")
358−
359− check items $ \case
360− SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs
361− SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs
362− SwaggerItemsArray itemSchemas -> do
363− when (len /= length itemSchemas) $
364− invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")
365− sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
366−
367− check uniqueItems $ \unique ->
368− when (unique && not allUnique) $
369− invalid ("array is expected to contain unique items, but it does not")
370− where
371− len = Vector.length xs
372− allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
373−
374−validateObject :: HashMap Text Value -> Validation Schema ()
375−validateObject o = withSchema $ \sch ->
376− case sch ^. discriminator of
377− Just pname -> case fromJSON <$> HashMap.lookup pname o of
378− Just (Success ref) -> validateWithSchemaRef ref (Object o)
379− Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)
380− Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing")
381− Nothing -> do
382− check maxProperties $ \n ->
383− when (size > n) $
384− invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")")
385−
386− check minProperties $ \n ->
387− when (size < n) $
388− invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")")
389−
390− validateRequired
391− validateProps
392− where
393− size = fromIntegral (HashMap.size o)
394−
395− validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)
396− validateReq n =
397− when (not (HashMap.member n o)) $
398− invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))
399−
400− validateProps = withSchema $ \sch -> do
401− for_ (HashMap.toList o) $ \(k, v) ->
402− case v of
403− Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
404− _ ->
405− case InsOrdHashMap.lookup k (sch ^. properties) of
406− Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
407− Just s -> validateWithSchemaRef s v
408−
409− validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid
410− validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"
411− validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v
412−
413− unknownProperty :: Text -> Validation s a
414− unknownProperty pname = invalid $
415− "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"
416−
417−validateEnum :: Value -> Validation (ParamSchema t) ()
418−validateEnum value = do
419− check enum_ $ \xs ->
420− when (value `notElem` xs) $
421− invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
422−
423−-- | Infer schema type based on used properties.
424−--
425−-- This is like 'inferParamSchemaTypes', but also works for objects:
426−--
427−-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"
428−-- Just [SwaggerObject]
429−inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema]
430−inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++
431− [ SwaggerObject | any ($ sch)
432− [ has (additionalProperties._Just)
433− , has (maxProperties._Just)
434− , has (minProperties._Just)
435− , has (properties.folded)
436− , has (required.folded) ] ]
437−
438−-- | Infer schema type based on used properties.
439−--
440−-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"
441−-- Just [SwaggerString]
442−--
443−-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"
444−-- Just [SwaggerArray]
445−--
446−-- From numeric properties 'SwaggerInteger' type is inferred.
447−-- If you want 'SwaggerNumber' instead, you must specify it explicitly.
448−--
449−-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"
450−-- Just [SwaggerInteger]
451−inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t]
452−inferParamSchemaTypes sch = concat
453− [ [ SwaggerArray | any ($ sch)
454− [ has (items._Just)
455− , has (maxItems._Just)
456− , has (minItems._Just)
457− , has (uniqueItems._Just) ] ]
458− , [ SwaggerInteger | any ($ sch)
459− [ has (exclusiveMaximum._Just)
460− , has (exclusiveMinimum._Just)
461− , has (maximum_._Just)
462− , has (minimum_._Just)
463− , has (multipleOf._Just) ] ]
464− , [ SwaggerString | any ($ sch)
465− [ has (maxLength._Just)
466− , has (minLength._Just)
467− , has (pattern._Just) ] ]
468− ]
469−
470−validateSchemaType :: Value -> Validation Schema ()
471−validateSchemaType value = withSchema $ \sch ->
472− case (sch ^. type_, value) of
473− (Just SwaggerNull, Null) -> valid
474− (Just SwaggerBoolean, Bool _) -> valid
475− (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
476− (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
477− (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)
478− (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
479− (Just SwaggerObject, Object o) -> validateObject o
480− (Nothing, Null) -> valid
481− (Nothing, Bool _) -> valid
482− -- Number by default
483− (Nothing, Number n) -> sub_ paramSchema (validateNumber n)
484− (Nothing, String s) -> sub_ paramSchema (validateString s)
485− (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)
486− (Nothing, Object o) -> validateObject o
487− bad -> invalid $ "expected JSON value of type " ++ showType bad
488−
489−validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
490−validateParamSchemaType value = withSchema $ \sch ->
491− case (sch ^. type_, value) of
492− (Just SwaggerBoolean, Bool _) -> valid
493− (Just SwaggerInteger, Number n) -> validateInteger n
494− (Just SwaggerNumber, Number n) -> validateNumber n
495− (Just SwaggerString, String s) -> validateString s
496− (Just SwaggerArray, Array xs) -> validateArray xs
497− (Nothing, Bool _) -> valid
498− -- Number by default
499− (Nothing, Number n) -> validateNumber n
500− (Nothing, String s) -> validateString s
501− (Nothing, Array xs) -> validateArray xs
502− bad -> invalid $ "expected JSON value of type " ++ showType bad
503−
504−showType :: (Maybe (SwaggerType t), Value) -> String
505−showType (Just type_, _) = show type_
506−showType (Nothing, Null) = "SwaggerNull"
507−showType (Nothing, Bool _) = "SwaggerBoolean"
508−showType (Nothing, Number _) = "SwaggerNumber"
509−showType (Nothing, String _) = "SwaggerString"
510−showType (Nothing, Array _) = "SwaggerArray"
511−showType (Nothing, Object _) = "SwaggerObject"
src/Data/Swagger/Internal/TypeShape.hsdeleted−66
@@ -1,66 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−
9−module Data.Swagger.Internal.TypeShape where
10−
11−import Data.Proxy
12−import GHC.Generics
13−import GHC.TypeLits
14−import GHC.Exts (Constraint)
15−
16−-- | Shape of a datatype.
17−data TypeShape
18− = Enumeration -- ^ A simple enumeration.
19− | SumOfProducts -- ^ A product or a sum of non-unit products.
20− | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.
21−
22−-- | A combined shape for a product type.
23−type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
24− ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products
25− ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products
26− ProdCombine a b = SumOfProducts
27−
28−-- | A combined shape for a sum type.
29−type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
30− SumCombine Enumeration Enumeration = Enumeration
31− SumCombine SumOfProducts SumOfProducts = SumOfProducts
32− SumCombine a b = Mixed
33−
34−type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where
35− TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))
36−
37−type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where
38− GenericHasSimpleShape t f Enumeration = ()
39− GenericHasSimpleShape t f SumOfProducts = ()
40−#if __GLASGOW_HASKELL__ < 800
41− GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t
42−
43−class CannotDeriveSchemaForMixedSumType t where
44−#else
45− GenericHasSimpleShape t f Mixed =
46− TypeError
47− ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t
48− :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."
49− :$$: Text "Swagger does not have a good representation for these types."
50− :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"
51− :$$: Text "that matches aeson's Generic-based toJSON,"
52− :$$: Text "but that's not supported by some Swagger tools."
53− )
54−#endif
55−
56−-- | Infer a 'TypeShape' for a generic representation of a type.
57−type family GenericShape (g :: * -> *) :: TypeShape
58−
59−type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)
60−type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)
61−type instance GenericShape (D1 d f) = GenericShape f
62−type instance GenericShape (C1 c U1) = Enumeration
63−type instance GenericShape (C1 c (S1 s f)) = SumOfProducts
64−type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
65−
66−
src/Data/Swagger/Internal/Utils.hs+47−13
@@ -6,9 +6,8 @@
66{-# LANGUAGE TypeOperators #-}
77module Data.Swagger.Internal.Utils where
88
9−import Prelude ()
10−import Prelude.Compat
11−
9+import Control.Arrow (first)
10+import Control.Applicative
1211import Control.Lens ((&), (%~))
1312import Control.Lens.TH
1413import Data.Aeson
@@ -18,13 +17,12 @@ import Data.Data
1817import Data.Hashable (Hashable)
1918import Data.HashMap.Strict (HashMap)
2019import qualified Data.HashMap.Strict as HashMap
21−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
22−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
2320import Data.Map (Map)
24−import Data.Set (Set)
21+import Data.Monoid
2522import Data.Text (Text)
2623import GHC.Generics
2724import Language.Haskell.TH (mkName)
25+import Text.Read (readMaybe)
2826
2927swaggerFieldRules :: LensRules
3028swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
@@ -43,7 +41,6 @@ swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
4341 fixName' "minimum" = "minimum_" -- Prelude conflict
4442 fixName' "maximum" = "maximum_" -- Prelude conflict
4543 fixName' "enum" = "enum_" -- Control.Lens conflict
46− fixName' "head" = "head_" -- Prelude conflict
4744 fixName' n = n
4845
4946gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
@@ -51,6 +48,17 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of
5148 Just x -> z x
5249 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
5350
51+hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v
52+hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList
53+
54+hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)
55+hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList
56+ where
57+ g (x, y) = (\a -> (a, y)) <$> f x
58+
59+hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)
60+hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)
61+
5462jsonPrefix :: String -> Options
5563jsonPrefix prefix = defaultOptions
5664 { fieldLabelModifier = modifier . drop 1
@@ -72,10 +80,40 @@ parseOneOf xs js =
7280 where
7381 ys = zip (map toJSON xs) xs
7482
83+omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value
84+omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o)
85+ where
86+ nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
87+omitEmptiesExcept _ js = js
88+
89+omitEmpties :: Value -> Value
90+omitEmpties = omitEmptiesExcept (\_ _ -> False)
91+
92+genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
93+genericToJSONWithSub sub opts x =
94+ case genericToJSON opts x of
95+ Object o ->
96+ case HashMap.lookup sub o of
97+ Just so -> Object (HashMap.delete sub o) <+> so
98+ Nothing -> Object o -- no subjson, leaving object as is
99+ _ -> error "genericToJSONWithSub: subjson is not an object"
100+
101+genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
102+genericParseJSONWithSub sub opts js@(Object o)
103+ = genericParseJSON opts js -- try without subjson
104+ <|> genericParseJSON opts js' -- try with subjson
105+ where
106+ js' = Object (HashMap.insert sub (Object o) o)
107+genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"
108+
75109(<+>) :: Value -> Value -> Value
76110Object x <+> Object y = Object (x <> y)
77111_ <+> _ = error "<+>: merging non-objects"
78112
113+withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
114+withDefaults parser defs js@(Object _) = parser (js <+> object defs)
115+withDefaults _ _ _ = empty
116+
79117genericMempty :: (Generic a, GMonoid (Rep a)) => a
80118genericMempty = to gmempty
81119
@@ -111,17 +149,12 @@ class SwaggerMonoid m where
111149 swaggerMappend = mappend
112150
113151instance SwaggerMonoid [a]
114−instance Ord a => SwaggerMonoid (Set a)
115152instance Ord k => SwaggerMonoid (Map k v)
116153
117−instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
154+instance {-# OVERLAPPABLE #-} (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
118155 swaggerMempty = mempty
119156 swaggerMappend = HashMap.unionWith (\_old new -> new)
120157
121−instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where
122− swaggerMempty = mempty
123− swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)
124−
125158instance SwaggerMonoid Text where
126159 swaggerMempty = mempty
127160 swaggerMappend x "" = x
@@ -131,3 +164,4 @@ instance SwaggerMonoid (Maybe a) where
131164 swaggerMempty = Nothing
132165 swaggerMappend x Nothing = x
133166 swaggerMappend _ y = y
167+
src/Data/Swagger/Lens.hs+23−57
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE FlexibleContexts #-}
32{-# LANGUAGE FlexibleInstances #-}
43{-# LANGUAGE FunctionalDependencies #-}
@@ -7,16 +6,7 @@
76{-# LANGUAGE RankNTypes #-}
87{-# LANGUAGE TemplateHaskell #-}
98{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE DataKinds #-}
119{-# LANGUAGE UndecidableInstances #-}
12−{-# OPTIONS_GHC -fno-warn-orphans #-}
13−#include "overlapping-compat.h"
14−-- |
15−-- Module: Data.Swagger.Lens
16−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
17−-- Stability: experimental
18−--
19−-- Lenses and prisms for Swagger.
2010module Data.Swagger.Lens where
2111
2212import Control.Lens
@@ -33,7 +23,7 @@ makeFields ''Host
3323makeFields ''Info
3424makeFields ''Contact
3525makeFields ''License
36−makeLensesWith swaggerFieldRules ''PathItem
26+makeFields ''PathItem
3727makeFields ''Tag
3828makeFields ''Operation
3929makeFields ''Param
@@ -60,23 +50,19 @@ makePrisms ''Referenced
6050
6151-- ** 'SwaggerItems' prisms
6252
63−_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]
53+_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema]
6454_SwaggerItemsArray
65− = unto (\x -> SwaggerItemsArray x)
66−{- \x -> case x of
55+ = prism (\x -> SwaggerItemsArray x) $ \x -> case x of
6756 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
6857 SwaggerItemsObject o -> Left (SwaggerItemsObject o)
6958 SwaggerItemsArray a -> Right a
70−-}
7159
72−_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)
60+_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema)
7361_SwaggerItemsObject
74− = unto (\x -> SwaggerItemsObject x)
75−{- \x -> case x of
62+ = prism (\x -> SwaggerItemsObject x) $ \x -> case x of
7663 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
7764 SwaggerItemsObject o -> Right o
7865 SwaggerItemsArray a -> Left (SwaggerItemsArray a)
79−-}
8066
8167_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)
8268_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)
@@ -96,19 +82,11 @@ instance At Responses where at n = responses . at n
9682instance Ixed Operation where ix n = responses . ix n
9783instance At Operation where at n = responses . at n
9884
99−type instance Index SecurityDefinitions = Text
100−type instance IxValue SecurityDefinitions = SecurityScheme
101−
102−instance Ixed SecurityDefinitions where ix n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). ix n
103−instance At SecurityDefinitions where at n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). at n
104−
105−instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema
106−
10785-- HasType instances
108−instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_
109−instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
110−instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
111−instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_
86+instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_
87+instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_
88+instance HasType NamedSchema (SwaggerType Schema) where type_ = schema.paramSchema.type_
89+instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_
11290
11391-- HasDefault instances
11492instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
@@ -117,70 +95,58 @@ instance HasDefault ParamOtherSchema (Maybe Value) where default_ = paramSchema.
11795
11896-- OVERLAPPABLE instances
11997
120−instance
121−#if __GLASGOW_HASKELL__ >= 710
122− OVERLAPPABLE_
123−#endif
124− HasParamSchema s (ParamSchema t)
98+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
12599 => HasFormat s (Maybe Format) where
126100 format = paramSchema.format
127101
128−instance
129−#if __GLASGOW_HASKELL__ >= 710
130− OVERLAPPABLE_
131−#endif
132− HasParamSchema s (ParamSchema t)
102+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
133103 => HasItems s (Maybe (SwaggerItems t)) where
134104 items = paramSchema.items
135105
136−instance
137−#if __GLASGOW_HASKELL__ >= 710
138− OVERLAPPABLE_
139−#endif
140− HasParamSchema s (ParamSchema t)
106+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
141107 => HasMaximum s (Maybe Scientific) where
142108 maximum_ = paramSchema.maximum_
143109
144−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
110+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
145111 => HasExclusiveMaximum s (Maybe Bool) where
146112 exclusiveMaximum = paramSchema.exclusiveMaximum
147113
148−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
114+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
149115 => HasMinimum s (Maybe Scientific) where
150116 minimum_ = paramSchema.minimum_
151117
152−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
118+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
153119 => HasExclusiveMinimum s (Maybe Bool) where
154120 exclusiveMinimum = paramSchema.exclusiveMinimum
155121
156−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
122+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
157123 => HasMaxLength s (Maybe Integer) where
158124 maxLength = paramSchema.maxLength
159125
160−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
126+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
161127 => HasMinLength s (Maybe Integer) where
162128 minLength = paramSchema.minLength
163129
164−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
130+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
165131 => HasPattern s (Maybe Text) where
166132 pattern = paramSchema.pattern
167133
168−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
134+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
169135 => HasMaxItems s (Maybe Integer) where
170136 maxItems = paramSchema.maxItems
171137
172−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
138+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
173139 => HasMinItems s (Maybe Integer) where
174140 minItems = paramSchema.minItems
175141
176−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
142+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
177143 => HasUniqueItems s (Maybe Bool) where
178144 uniqueItems = paramSchema.uniqueItems
179145
180−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
146+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
181147 => HasEnum s (Maybe [Value]) where
182148 enum_ = paramSchema.enum_
183149
184−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
150+instance {-# OVERLAPPABLE #-} HasParamSchema s (ParamSchema t)
185151 => HasMultipleOf s (Maybe Scientific) where
186152 multipleOf = paramSchema.multipleOf
src/Data/Swagger/Operation.hsdeleted−193
@@ -1,193 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−-- |
3−-- Module: Data.Swagger.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.Swagger.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−
43−import Data.Swagger.Declare
44−import Data.Swagger.Internal
45−import Data.Swagger.Lens
46−import Data.Swagger.Schema
47−
48−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
49−import qualified Data.HashSet.InsOrd as InsOrdHS
50−
51−-- $setup
52−-- >>> import Data.Aeson
53−-- >>> import Data.Proxy
54−-- >>> import Data.Time
55−
56−-- | Prepend path piece to all operations of the spec.
57−-- Leading and trailing slashes are trimmed/added automatically.
58−--
59−-- >>> let api = (mempty :: Swagger) & paths .~ [("/info", mempty)]
60−-- >>> encode $ prependPath "user/{user_id}" api ^. paths
61−-- "{\"/user/{user_id}/info\":{}}"
62−prependPath :: FilePath -> Swagger -> Swagger
63−prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)
64− where
65− x </> y = case trim y of
66− "" -> "/" <> trim x
67− y' -> "/" <> trim x <> "/" <> y'
68−
69− trim = dropWhile (== '/') . dropWhileEnd (== '/')
70−
71−-- | All operations of a Swagger spec.
72−allOperations :: Traversal' Swagger Operation
73−allOperations = paths.traverse.template
74−
75−-- | @'operationsOf' sub@ will traverse only those operations
76−-- that are present in @sub@. Note that @'Operation'@ is determined
77−-- by both path and method.
78−--
79−-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"
80−-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
81−-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
82−-- >>> encode api
83−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
84−-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"
85−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
86−operationsOf :: Swagger -> Traversal' Swagger Operation
87−operationsOf sub = paths.itraversed.withIndex.subops
88− where
89− -- | Traverse operations that correspond to paths and methods of the sub API.
90− subops :: Traversal' (FilePath, PathItem) Operation
91− subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of
92− Just subitem -> (,) path <$> methodsOf subitem f item
93− Nothing -> pure (path, item)
94−
95− -- | Traverse operations that exist in a given @'PathItem'@
96− -- This is used to traverse only the operations that exist in sub API.
97− methodsOf :: PathItem -> Traversal' PathItem Operation
98− methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just
99− where
100− ops = pathItem ^.. template :: [Maybe Operation]
101− ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops
102−
103−-- | Apply tags to all operations and update the global list of tags.
104−--
105−-- @
106−-- 'applyTags' = 'applyTagsFor' 'allOperations'
107−-- @
108−applyTags :: [Tag] -> Swagger -> Swagger
109−applyTags = applyTagsFor allOperations
110−
111−-- | Apply tags to a part of Swagger spec and update the global
112−-- list of tags.
113−applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
114−applyTagsFor ops ts swag = swag
115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
116− & tags %~ (<> InsOrdHS.fromList ts)
117−
118−-- | Construct a response with @'Schema'@ while declaring all
119−-- necessary schema definitions.
120−--
121−-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
122−-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"
123−declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response
124−declareResponse proxy = do
125− s <- declareSchemaRef proxy
126− return (mempty & schema ?~ s)
127−
128−-- | Set response for all operations.
129−-- This will also update global schema definitions.
130−--
131−-- If the response already exists it will be overwritten.
132−--
133−-- @
134−-- 'setResponse' = 'setResponseFor' 'allOperations'
135−-- @
136−--
137−-- Example:
138−--
139−-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
140−-- >>> let res = declareResponse (Proxy :: Proxy Day)
141−-- >>> encode $ api & setResponse 200 res
142−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}"
143−--
144−-- See also @'setResponseWith'@.
145−setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
146−setResponse = setResponseFor allOperations
147−
148−-- | Set or update response for all operations.
149−-- This will also update global schema definitions.
150−--
151−-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
152−-- then just the new response is used.
153−--
154−-- @
155−-- 'setResponseWith' = 'setResponseForWith' 'allOperations'
156−-- @
157−--
158−-- See also @'setResponse'@.
159−setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
160−setResponseWith = setResponseForWith allOperations
161−
162−-- | Set response for specified operations.
163−-- This will also update global schema definitions.
164−--
165−-- If the response already exists it will be overwritten.
166−--
167−-- See also @'setResponseForWith'@.
168−setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
169−setResponseFor ops code dres swag = swag
170− & definitions %~ (<> defs)
171− & ops . at code ?~ Inline res
172− where
173− (defs, res) = runDeclare dres mempty
174−
175−-- | Set or update response for specified operations.
176−-- This will also update global schema definitions.
177−--
178−-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
179−-- then just the new response is used.
180−--
181−-- See also @'setResponseFor'@.
182−setResponseForWith :: Traversal' Swagger Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
183−setResponseForWith ops f code dres swag = swag
184− & definitions %~ (<> defs)
185− & ops . at code %~ Just . Inline . combine
186− where
187− (defs, new) = runDeclare dres mempty
188−
189− combine (Just (Ref (Reference n))) = case swag ^. responses.at n of
190− Just old -> f old new
191− Nothing -> new -- response name can't be dereferenced, replacing with new response
192− combine (Just (Inline old)) = f old new
193− combine Nothing = new
src/Data/Swagger/Optics.hsdeleted−597
@@ -1,597 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE OverloadedLabels #-}
5−{-# LANGUAGE TemplateHaskell #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−{-# OPTIONS_GHC -fno-warn-orphans #-}
9−-- |
10−-- Module: Data.Swagger.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−--
21−-- Example from the "Data.Swagger" module using @optics@:
22−--
23−-- >>> :{
24−-- encode $ (mempty :: Swagger)
25−-- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]
26−-- & #paths .~
27−-- [ ("/user", mempty & #get ?~ (mempty
28−-- & #produces ?~ MimeList ["application/json"]
29−-- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))
30−-- & at 404 ?~ "User info not found")) ]
31−-- :}
32−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"
33−--
34−-- For convenience optics are defined as /labels/. It means that field accessor
35−-- names can be overloaded for different types. One such common field is
36−-- @#description@. Many components of a Swagger specification can have
37−-- descriptions, and you can use the same name for them:
38−--
39−-- >>> encode $ (mempty :: Response) & #description .~ "No content"
40−-- "{\"description\":\"No content\"}"
41−-- >>> :{
42−-- encode $ (mempty :: Schema)
43−-- & #type ?~ SwaggerBoolean
44−-- & #description ?~ "To be or not to be"
45−-- :}
46−-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
47−--
48−-- @'ParamSchema'@ is basically the /base schema specification/ and many types
49−-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively
50−-- made fields of the type that has it. For example, you can use @#type@ to
51−-- access @'SwaggerType'@ of @'Header'@ schema without having to use
52−-- @#paramSchema@:
53−--
54−-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber
55−-- "{\"type\":\"number\"}"
56−--
57−-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and
58−-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:
59−--
60−-- >>> :{
61−-- encode $ (mempty :: Operation)
62−-- & at 404 ?~ "Not found"
63−-- :}
64−-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"
65−--
66−module Data.Swagger.Optics () where
67−
68−import Data.Aeson (Value)
69−import Data.Scientific (Scientific)
70−import Data.Swagger.Internal
71−import Data.Text (Text)
72−import Optics.Core
73−import Optics.TH
74−
75−-- Lenses
76−
77−makeFieldLabels ''Swagger
78−makeFieldLabels ''Host
79−makeFieldLabels ''Info
80−makeFieldLabels ''Contact
81−makeFieldLabels ''License
82−makeFieldLabels ''PathItem
83−makeFieldLabels ''Tag
84−makeFieldLabels ''Operation
85−makeFieldLabels ''Param
86−makeFieldLabels ''ParamOtherSchema
87−makeFieldLabels ''Header
88−makeFieldLabels ''Schema
89−makeFieldLabels ''NamedSchema
90−makeFieldLabels ''ParamSchema
91−makeFieldLabels ''Xml
92−makeFieldLabels ''Responses
93−makeFieldLabels ''Response
94−makeFieldLabels ''SecurityScheme
95−makeFieldLabels ''ApiKeyParams
96−makeFieldLabels ''OAuth2Params
97−makeFieldLabels ''ExternalDocs
98−
99−-- Prisms
100−
101−makePrismLabels ''ParamAnySchema
102−makePrismLabels ''SecuritySchemeType
103−makePrismLabels ''Referenced
104−
105−-- SwaggerItems prisms
106−
107−instance
108− ( a ~ [Referenced Schema]
109− , b ~ [Referenced Schema]
110− ) => LabelOptic "_SwaggerItemsArray"
111− A_Review
112− (SwaggerItems 'SwaggerKindSchema)
113− (SwaggerItems 'SwaggerKindSchema)
114− a
115− b where
116− labelOptic = unto (\x -> SwaggerItemsArray x)
117− {-# INLINE labelOptic #-}
118−
119−instance
120− ( a ~ Referenced Schema
121− , b ~ Referenced Schema
122− ) => LabelOptic "_SwaggerItemsObject"
123− A_Review
124− (SwaggerItems 'SwaggerKindSchema)
125− (SwaggerItems 'SwaggerKindSchema)
126− a
127− b where
128− labelOptic = unto (\x -> SwaggerItemsObject x)
129− {-# INLINE labelOptic #-}
130−
131−instance
132− ( a ~ (Maybe (CollectionFormat t), ParamSchema t)
133− , b ~ (Maybe (CollectionFormat t), ParamSchema t)
134− ) => LabelOptic "_SwaggerItemsPrimitive"
135− A_Review
136− (SwaggerItems t)
137− (SwaggerItems t)
138− a
139− b where
140− labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)
141− {-# INLINE labelOptic #-}
142−
143−-- =============================================================
144−-- More helpful instances for easier access to schema properties
145−
146−type instance Index Responses = HttpStatusCode
147−type instance Index Operation = HttpStatusCode
148−
149−type instance IxValue Responses = Referenced Response
150−type instance IxValue Operation = Referenced Response
151−
152−instance Ixed Responses where
153− ix n = #responses % ix n
154− {-# INLINE ix #-}
155−instance At Responses where
156− at n = #responses % at n
157− {-# INLINE at #-}
158−
159−instance Ixed Operation where
160− ix n = #responses % ix n
161− {-# INLINE ix #-}
162−instance At Operation where
163− at n = #responses % at n
164− {-# INLINE at #-}
165−
166−-- #paramSchema
167−
168−instance
169− ( a ~ ParamSchema 'SwaggerKindSchema
170− , b ~ ParamSchema 'SwaggerKindSchema
171− ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where
172− labelOptic = #schema % #paramSchema
173− {-# INLINE labelOptic #-}
174−
175−-- #type
176−
177−instance
178− ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))
179− , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))
180− ) => LabelOptic "type" A_Lens Header Header a b where
181− labelOptic = #paramSchema % #type
182− {-# INLINE labelOptic #-}
183−
184−instance
185− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)
186− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)
187− ) => LabelOptic "type" A_Lens Schema Schema a b where
188− labelOptic = #paramSchema % #type
189− {-# INLINE labelOptic #-}
190−
191−instance
192− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)
193− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)
194− ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where
195− labelOptic = #paramSchema % #type
196− {-# INLINE labelOptic #-}
197−
198−instance
199− ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
200− , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
201− ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where
202− labelOptic = #paramSchema % #type
203− {-# INLINE labelOptic #-}
204−
205−-- #default
206−
207−instance
208− ( a ~ Maybe Value, b ~ Maybe Value
209− ) => LabelOptic "default" A_Lens Header Header a b where
210− labelOptic = #paramSchema % #default
211− {-# INLINE labelOptic #-}
212−
213−instance
214− ( a ~ Maybe Value, b ~ Maybe Value
215− ) => LabelOptic "default" A_Lens Schema Schema a b where
216− labelOptic = #paramSchema % #default
217− {-# INLINE labelOptic #-}
218−
219−instance
220− ( a ~ Maybe Value, b ~ Maybe Value
221− ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where
222− labelOptic = #paramSchema % #default
223− {-# INLINE labelOptic #-}
224−
225−instance
226− ( a ~ Maybe Value, b ~ Maybe Value
227− ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where
228− labelOptic = #paramSchema % #default
229− {-# INLINE labelOptic #-}
230−
231−-- #format
232−
233−instance
234− ( a ~ Maybe Format, b ~ Maybe Format
235− ) => LabelOptic "format" A_Lens Header Header a b where
236− labelOptic = #paramSchema % #format
237− {-# INLINE labelOptic #-}
238−
239−instance
240− ( a ~ Maybe Format, b ~ Maybe Format
241− ) => LabelOptic "format" A_Lens Schema Schema a b where
242− labelOptic = #paramSchema % #format
243− {-# INLINE labelOptic #-}
244−
245−instance
246− ( a ~ Maybe Format, b ~ Maybe Format
247− ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where
248− labelOptic = #paramSchema % #format
249− {-# INLINE labelOptic #-}
250−
251−instance
252− ( a ~ Maybe Format, b ~ Maybe Format
253− ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where
254− labelOptic = #paramSchema % #format
255− {-# INLINE labelOptic #-}
256−
257−-- #items
258−
259−instance
260− ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))
261− , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))
262− ) => LabelOptic "items" A_Lens Header Header a b where
263− labelOptic = #paramSchema % #items
264− {-# INLINE labelOptic #-}
265−
266−instance
267− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)
268− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)
269− ) => LabelOptic "items" A_Lens Schema Schema a b where
270− labelOptic = #paramSchema % #items
271− {-# INLINE labelOptic #-}
272−
273−instance
274− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)
275− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)
276− ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where
277− labelOptic = #paramSchema % #items
278− {-# INLINE labelOptic #-}
279−
280−instance
281− ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)
282− , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)
283− ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where
284− labelOptic = #paramSchema % #items
285− {-# INLINE labelOptic #-}
286−
287−-- #maximum
288−
289−instance
290− ( a ~ Maybe Scientific, b ~ Maybe Scientific
291− ) => LabelOptic "maximum" A_Lens Header Header a b where
292− labelOptic = #paramSchema % #maximum
293− {-# INLINE labelOptic #-}
294−
295−instance
296− ( a ~ Maybe Scientific, b ~ Maybe Scientific
297− ) => LabelOptic "maximum" A_Lens Schema Schema a b where
298− labelOptic = #paramSchema % #maximum
299− {-# INLINE labelOptic #-}
300−
301−instance
302− ( a ~ Maybe Scientific, b ~ Maybe Scientific
303− ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where
304− labelOptic = #paramSchema % #maximum
305− {-# INLINE labelOptic #-}
306−
307−instance
308− ( a ~ Maybe Scientific, b ~ Maybe Scientific
309− ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where
310− labelOptic = #paramSchema % #maximum
311− {-# INLINE labelOptic #-}
312−
313−-- #exclusiveMaximum
314−
315−instance
316− ( a ~ Maybe Bool, b ~ Maybe Bool
317− ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where
318− labelOptic = #paramSchema % #exclusiveMaximum
319− {-# INLINE labelOptic #-}
320−
321−instance
322− ( a ~ Maybe Bool, b ~ Maybe Bool
323− ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where
324− labelOptic = #paramSchema % #exclusiveMaximum
325− {-# INLINE labelOptic #-}
326−
327−instance
328− ( a ~ Maybe Bool, b ~ Maybe Bool
329− ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where
330− labelOptic = #paramSchema % #exclusiveMaximum
331− {-# INLINE labelOptic #-}
332−
333−instance
334− ( a ~ Maybe Bool, b ~ Maybe Bool
335− ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where
336− labelOptic = #paramSchema % #exclusiveMaximum
337− {-# INLINE labelOptic #-}
338−
339−-- #minimum
340−
341−instance
342− ( a ~ Maybe Scientific, b ~ Maybe Scientific
343− ) => LabelOptic "minimum" A_Lens Header Header a b where
344− labelOptic = #paramSchema % #minimum
345− {-# INLINE labelOptic #-}
346−
347−instance
348− ( a ~ Maybe Scientific, b ~ Maybe Scientific
349− ) => LabelOptic "minimum" A_Lens Schema Schema a b where
350− labelOptic = #paramSchema % #minimum
351− {-# INLINE labelOptic #-}
352−
353−instance
354− ( a ~ Maybe Scientific, b ~ Maybe Scientific
355− ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where
356− labelOptic = #paramSchema % #minimum
357− {-# INLINE labelOptic #-}
358−
359−instance
360− ( a ~ Maybe Scientific, b ~ Maybe Scientific
361− ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where
362− labelOptic = #paramSchema % #minimum
363− {-# INLINE labelOptic #-}
364−
365−-- #exclusiveMinimum
366−
367−instance
368− ( a ~ Maybe Bool, b ~ Maybe Bool
369− ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where
370− labelOptic = #paramSchema % #exclusiveMinimum
371− {-# INLINE labelOptic #-}
372−
373−instance
374− ( a ~ Maybe Bool, b ~ Maybe Bool
375− ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where
376− labelOptic = #paramSchema % #exclusiveMinimum
377− {-# INLINE labelOptic #-}
378−
379−instance
380− ( a ~ Maybe Bool, b ~ Maybe Bool
381− ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where
382− labelOptic = #paramSchema % #exclusiveMinimum
383− {-# INLINE labelOptic #-}
384−
385−instance
386− ( a ~ Maybe Bool, b ~ Maybe Bool
387− ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where
388− labelOptic = #paramSchema % #exclusiveMinimum
389− {-# INLINE labelOptic #-}
390−
391−-- #maxLength
392−
393−instance
394− ( a ~ Maybe Integer, b ~ Maybe Integer
395− ) => LabelOptic "maxLength" A_Lens Header Header a b where
396− labelOptic = #paramSchema % #maxLength
397− {-# INLINE labelOptic #-}
398−
399−instance
400− ( a ~ Maybe Integer, b ~ Maybe Integer
401− ) => LabelOptic "maxLength" A_Lens Schema Schema a b where
402− labelOptic = #paramSchema % #maxLength
403− {-# INLINE labelOptic #-}
404−
405−instance
406− ( a ~ Maybe Integer, b ~ Maybe Integer
407− ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where
408− labelOptic = #paramSchema % #maxLength
409− {-# INLINE labelOptic #-}
410−
411−instance
412− ( a ~ Maybe Integer, b ~ Maybe Integer
413− ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where
414− labelOptic = #paramSchema % #maxLength
415− {-# INLINE labelOptic #-}
416−
417−-- #minLength
418−
419−instance
420− ( a ~ Maybe Integer, b ~ Maybe Integer
421− ) => LabelOptic "minLength" A_Lens Header Header a b where
422− labelOptic = #paramSchema % #minLength
423− {-# INLINE labelOptic #-}
424−
425−instance
426− ( a ~ Maybe Integer, b ~ Maybe Integer
427− ) => LabelOptic "minLength" A_Lens Schema Schema a b where
428− labelOptic = #paramSchema % #minLength
429− {-# INLINE labelOptic #-}
430−
431−instance
432− ( a ~ Maybe Integer, b ~ Maybe Integer
433− ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where
434− labelOptic = #paramSchema % #minLength
435− {-# INLINE labelOptic #-}
436−
437−instance
438− ( a ~ Maybe Integer, b ~ Maybe Integer
439− ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where
440− labelOptic = #paramSchema % #minLength
441− {-# INLINE labelOptic #-}
442−
443−-- #pattern
444−
445−instance
446− ( a ~ Maybe Text, b ~ Maybe Text
447− ) => LabelOptic "pattern" A_Lens Header Header a b where
448− labelOptic = #paramSchema % #pattern
449− {-# INLINE labelOptic #-}
450−
451−instance
452− ( a ~ Maybe Text, b ~ Maybe Text
453− ) => LabelOptic "pattern" A_Lens Schema Schema a b where
454− labelOptic = #paramSchema % #pattern
455− {-# INLINE labelOptic #-}
456−
457−instance
458− ( a ~ Maybe Text, b ~ Maybe Text
459− ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where
460− labelOptic = #paramSchema % #pattern
461− {-# INLINE labelOptic #-}
462−
463−instance
464− ( a ~ Maybe Text, b ~ Maybe Text
465− ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where
466− labelOptic = #paramSchema % #pattern
467− {-# INLINE labelOptic #-}
468−
469−-- #maxItems
470−
471−instance
472− ( a ~ Maybe Integer, b ~ Maybe Integer
473− ) => LabelOptic "maxItems" A_Lens Header Header a b where
474− labelOptic = #paramSchema % #maxItems
475− {-# INLINE labelOptic #-}
476−
477−instance
478− ( a ~ Maybe Integer, b ~ Maybe Integer
479− ) => LabelOptic "maxItems" A_Lens Schema Schema a b where
480− labelOptic = #paramSchema % #maxItems
481− {-# INLINE labelOptic #-}
482−
483−instance
484− ( a ~ Maybe Integer, b ~ Maybe Integer
485− ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where
486− labelOptic = #paramSchema % #maxItems
487− {-# INLINE labelOptic #-}
488−
489−instance
490− ( a ~ Maybe Integer, b ~ Maybe Integer
491− ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
492− labelOptic = #paramSchema % #maxItems
493− {-# INLINE labelOptic #-}
494−
495−-- #minItems
496−
497−instance
498− ( a ~ Maybe Integer, b ~ Maybe Integer
499− ) => LabelOptic "minItems" A_Lens Header Header a b where
500− labelOptic = #paramSchema % #minItems
501− {-# INLINE labelOptic #-}
502−
503−instance
504− ( a ~ Maybe Integer, b ~ Maybe Integer
505− ) => LabelOptic "minItems" A_Lens Schema Schema a b where
506− labelOptic = #paramSchema % #minItems
507− {-# INLINE labelOptic #-}
508−
509−instance
510− ( a ~ Maybe Integer, b ~ Maybe Integer
511− ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where
512− labelOptic = #paramSchema % #minItems
513− {-# INLINE labelOptic #-}
514−
515−instance
516− ( a ~ Maybe Integer, b ~ Maybe Integer
517− ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
518− labelOptic = #paramSchema % #minItems
519− {-# INLINE labelOptic #-}
520−
521−-- #uniqueItems
522−
523−instance
524− ( a ~ Maybe Bool, b ~ Maybe Bool
525− ) => LabelOptic "uniqueItems" A_Lens Header Header a b where
526− labelOptic = #paramSchema % #uniqueItems
527− {-# INLINE labelOptic #-}
528−
529−instance
530− ( a ~ Maybe Bool, b ~ Maybe Bool
531− ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where
532− labelOptic = #paramSchema % #uniqueItems
533− {-# INLINE labelOptic #-}
534−
535−instance
536− ( a ~ Maybe Bool, b ~ Maybe Bool
537− ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where
538− labelOptic = #paramSchema % #uniqueItems
539− {-# INLINE labelOptic #-}
540−
541−instance
542− ( a ~ Maybe Bool, b ~ Maybe Bool
543− ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
544− labelOptic = #paramSchema % #uniqueItems
545− {-# INLINE labelOptic #-}
546−
547−-- #enum
548−
549−instance
550− ( a ~ Maybe [Value], b ~ Maybe [Value]
551− ) => LabelOptic "enum" A_Lens Header Header a b where
552− labelOptic = #paramSchema % #enum
553− {-# INLINE labelOptic #-}
554−
555−instance
556− ( a ~ Maybe [Value], b ~ Maybe [Value]
557− ) => LabelOptic "enum" A_Lens Schema Schema a b where
558− labelOptic = #paramSchema % #enum
559− {-# INLINE labelOptic #-}
560−
561−instance
562− ( a ~ Maybe [Value], b ~ Maybe [Value]
563− ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where
564− labelOptic = #paramSchema % #enum
565− {-# INLINE labelOptic #-}
566−
567−instance
568− ( a ~ Maybe [Value], b ~ Maybe [Value]
569− ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where
570− labelOptic = #paramSchema % #enum
571− {-# INLINE labelOptic #-}
572−
573−-- #multipleOf
574−
575−instance
576− ( a ~ Maybe Scientific, b ~ Maybe Scientific
577− ) => LabelOptic "multipleOf" A_Lens Header Header a b where
578− labelOptic = #paramSchema % #multipleOf
579− {-# INLINE labelOptic #-}
580−
581−instance
582− ( a ~ Maybe Scientific, b ~ Maybe Scientific
583− ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where
584− labelOptic = #paramSchema % #multipleOf
585− {-# INLINE labelOptic #-}
586−
587−instance
588− ( a ~ Maybe Scientific, b ~ Maybe Scientific
589− ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where
590− labelOptic = #paramSchema % #multipleOf
591− {-# INLINE labelOptic #-}
592−
593−instance
594− ( a ~ Maybe Scientific, b ~ Maybe Scientific
595− ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where
596− labelOptic = #paramSchema % #multipleOf
597− {-# INLINE labelOptic #-}
src/Data/Swagger/ParamSchema.hs+2−5
@@ -1,5 +1,7 @@
11-- |
22-- Module: Data.Swagger.ParamSchema
3+-- Copyright: (c) 2015 GetShopTV
4+-- License: BSD3
35-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
46-- Stability: experimental
57--
@@ -12,11 +14,6 @@ module Data.Swagger.ParamSchema (
1214 genericToParamSchema,
1315 toParamSchemaBoundedIntegral,
1416
15− -- * Schema templates
16− passwordParamSchema,
17− binaryParamSchema,
18− byteParamSchema,
19−
2017 -- * Generic encoding configuration
2118 SchemaOptions(..),
2219 defaultSchemaOptions,
src/Data/Swagger/Schema.hs+2−24
@@ -1,5 +1,7 @@
11-- |
22-- Module: Data.Swagger.Schema
3+-- Copyright: (c) 2015 GetShopTV
4+-- License: BSD3
35-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
46-- Stability: experimental
57--
@@ -17,34 +19,11 @@ module Data.Swagger.Schema (
1719 -- * Generic schema encoding
1820 genericDeclareNamedSchema,
1921 genericDeclareSchema,
20− genericDeclareNamedSchemaNewtype,
21− genericNameSchema,
22−
23− -- ** 'Bounded' 'Integral'
2422 genericToNamedSchemaBoundedIntegral,
2523 toSchemaBoundedIntegral,
26−
27− -- ** 'Bounded' 'Enum' key mappings
28− declareSchemaBoundedEnumKeyMapping,
29− toSchemaBoundedEnumKeyMapping,
30−
31− -- ** Reusing 'ToParamSchema'
3224 paramSchemaToNamedSchema,
3325 paramSchemaToSchema,
3426
35− -- ** Unrestricted versions
36− genericDeclareNamedSchemaUnrestricted,
37− genericDeclareSchemaUnrestricted,
38−
39− -- * Schema templates
40− passwordSchema,
41− binarySchema,
42− byteSchema,
43−
44− -- * Sketching @'Schema'@s using @'ToJSON'@
45− sketchSchema,
46− sketchStrictSchema,
47−
4827 -- * Inlining @'Schema'@s
4928 inlineNonRecursiveSchemas,
5029 inlineAllSchemas,
@@ -54,7 +33,6 @@ module Data.Swagger.Schema (
5433 -- * Generic encoding configuration
5534 SchemaOptions(..),
5635 defaultSchemaOptions,
57− fromAesonOptions,
5836) where
5937
6038import Data.Swagger.Internal.Schema
src/Data/Swagger/Schema/Generator.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE OverloadedLists #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.Swagger.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.Maybe
17−import Data.Proxy
18−import Data.Scientific
19−import qualified Data.Set as S
20−import Data.Swagger
21−import Data.Swagger.Declare
22−import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)
23−import qualified Data.Text as T
24−import qualified Data.Vector as V
25−import Test.QuickCheck (arbitrary)
26−import Test.QuickCheck.Gen
27−import Test.QuickCheck.Property
28−
29−-- | Note: 'schemaGen' may 'error', if schema type is not specified,
30−-- and cannot be inferred.
31−schemaGen :: Definitions Schema -> Schema -> Gen Value
32−schemaGen _ schema
33− | Just cases <- schema ^. paramSchema . enum_ = elements cases
34−schemaGen defns schema =
35− case schema ^. type_ of
36− Nothing ->
37− case inferSchemaTypes schema of
38− [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
39− -- Gen is not MonadFail
40− _ -> error "unable to infer schema type"
41− Just SwaggerBoolean -> Bool <$> elements [True, False]
42− Just SwaggerNull -> pure Null
43− Just SwaggerNumber
44− | Just min <- schema ^. minimum_
45− , Just max <- schema ^. maximum_ ->
46− Number . fromFloatDigits <$>
47− choose (toRealFloat min, toRealFloat max :: Double)
48− | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
49− Just SwaggerInteger
50− | Just min <- schema ^. minimum_
51− , Just max <- schema ^. maximum_ ->
52− Number . fromInteger <$>
53− choose (truncate min, truncate max)
54− | otherwise -> Number . fromInteger <$> arbitrary
55− Just SwaggerArray
56− | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
57− | Just items <- schema ^. items ->
58− case items of
59− SwaggerItemsObject ref -> do
60− size <- getSize
61− let itemSchema = dereference defns ref
62− minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems
63− maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems
64− arrayLength <- choose (minLength', max minLength' maxLength')
65− generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema
66− return . Array $ V.fromList generatedArray
67− SwaggerItemsArray refs ->
68− let itemGens = schemaGen defns . dereference defns <$> refs
69− in fmap (Array . V.fromList) $ sequence itemGens
70− Just SwaggerString -> do
71− size <- getSize
72− let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
73− let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
74− length <- choose (minLength', max minLength' maxLength')
75− str <- vectorOf length arbitrary
76− return . String $ T.pack str
77− Just SwaggerObject -> do
78− size <- getSize
79− let props = dereference defns <$> schema ^. properties
80− reqKeys = S.fromList $ schema ^. required
81− allKeys = S.fromList . M.keys $ schema ^. properties
82− optionalKeys = allKeys S.\\ reqKeys
83− minProps' = fromMaybe (length reqKeys) $
84− fromInteger <$> schema ^. minProperties
85− maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties
86− shuffledOptional <- shuffle $ S.toList optionalKeys
87− numProps <- choose (minProps', max minProps' maxProps')
88− let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional
89− let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props
90− let gens = schemaGen defns <$> presentProps
91− additionalGens <- case schema ^. additionalProperties of
92− Just (AdditionalPropertiesSchema addlSchema) -> do
93− additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary
94− return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)
95− _ -> return []
96− x <- sequence $ gens <> additionalGens
97− return . Object $ M.toHashMap x
98− where
99− dereference :: Definitions a -> Referenced a -> a
100− dereference _ (Inline a) = a
101− dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
102−
103−genValue :: (ToSchema a) => Proxy a -> Gen Value
104−genValue p =
105− let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty
106− in schemaGen defs schema
107−
108−validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
109−validateFromJSON p = forAll (genValue p) $
110− \val -> case parseEither parseJSON val of
111− Right (_ :: a) -> succeeded
112− Left err -> failed
113− { reason = err
114− }
src/Data/Swagger/Schema/Validation.hsdeleted−90
@@ -1,90 +0,0 @@
1−-- |
2−-- Module: Data.Swagger.Schema.Validation
3−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4−-- Stability: experimental
5−--
6−-- Validate JSON values with Swagger Schema.
7−module Data.Swagger.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.Swagger.Internal.Schema.Validation
33−
34−-- $setup
35−-- >>> import Control.Lens
36−-- >>> import Data.Aeson
37−-- >>> import Data.Proxy
38−-- >>> import Data.Swagger
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 SwaggerString"]
75−-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])
76−-- ["expected JSON value of type SwaggerString"]
77−-- >>> validateToJSON (123, Nothing :: Maybe String)
78−-- ["expected JSON value of type SwaggerString"]
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/Swagger/SchemaOptions.hs−35
@@ -1,14 +1,5 @@
1−{-# LANGUAGE RecordWildCards #-}
2−-- |
3−-- Module: Data.Swagger.SchemaOptions
4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5−-- Stability: experimental
6−--
7−-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.
81module Data.Swagger.SchemaOptions where
92
10−import qualified Data.Aeson.Types as Aeson
11−
123-- | Options that specify how to encode your type to Swagger schema.
134data SchemaOptions = SchemaOptions
145 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
@@ -44,29 +35,3 @@ defaultSchemaOptions = SchemaOptions
4435 , unwrapUnaryRecords = False
4536 }
4637
47−-- | Convert 'Aeson.Options' to 'SchemaOptions'.
48−--
49−-- Specifically the following fields get copied:
50−--
51−-- * 'fieldLabelModifier'
52−-- * 'constructorTagModifier'
53−-- * 'allNullaryToStringTag'
54−-- * 'unwrapUnaryRecords'
55−--
56−-- Note that these fields have no effect on `SchemaOptions`:
57−--
58−-- * 'Aeson.omitNothingFields'
59−-- * 'Aeson.sumEncoding'
60−-- * 'Aeson.tagSingleConstructors'
61−--
62−-- The rest is defined as in 'defaultSchemaOptions'.
63−--
64−-- @since 2.2.1
65−--
66−fromAesonOptions :: Aeson.Options -> SchemaOptions
67−fromAesonOptions opts = defaultSchemaOptions
68− { fieldLabelModifier = Aeson.fieldLabelModifier opts
69− , constructorTagModifier = Aeson.constructorTagModifier opts
70− , allNullaryToStringTag = Aeson.allNullaryToStringTag opts
71− , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts
72− }
stack.yaml+2−6
@@ -1,9 +1,5 @@
1−resolver: lts-14.3
1+flags: {}
22packages:
33- '.'
44extra-deps:
5−- optics-core-0.2
6−- optics-th-0.2
7−- optics-extra-0.2
8−- indexed-profunctors-0.1
9−- insert-ordered-containers-0.2.3
5+resolver: lts-3.12
swagger2.cabal+34−107
@@ -1,152 +1,79 @@
1−cabal-version: >=1.10
21name: swagger2
3−version: 2.5
4−
2+version: 1.2.1
53synopsis: Swagger 2.0 data model
6−category: Web, Swagger
7−description:
8− This library is intended to be used for decoding and encoding Swagger 2.0 API
9− specifications as well as manipulating them.
10− .
11− The original Swagger 2.0 specification is available at http://swagger.io/specification/.
12−
4+description: Please see README.md
135homepage: https://github.com/GetShopTV/swagger2
146bug-reports: https://github.com/GetShopTV/swagger2/issues
157license: BSD3
168license-file: LICENSE
179author: Nickolay Kudasov
1810maintainer: nickolay@getshoptv.com
19−copyright: (c) 2015-2016, GetShopTV
20−build-type: Custom
11+copyright: (c) 2015, GetShopTV
12+category: Web
13+build-type: Simple
2114extra-source-files:
2215 README.md
2316 , CHANGELOG.md
2417 , examples/*.hs
25− , include/overlapping-compat.h
26−tested-with:
27− GHC ==8.0.2
28− || ==8.2.2
29− || ==8.4.4
30− || ==8.6.5
31− || ==8.8.1
32−
33−custom-setup
34− setup-depends:
35− base, Cabal, cabal-doctest >=1.0.6 && <1.1
18+cabal-version: >=1.10
3619
3720library
3821 hs-source-dirs: src
39− include-dirs: include
4022 exposed-modules:
4123 Data.Swagger
4224 Data.Swagger.Declare
4325 Data.Swagger.Lens
44− Data.Swagger.Operation
45− Data.Swagger.Optics
4626 Data.Swagger.ParamSchema
4727 Data.Swagger.Schema
48− Data.Swagger.Schema.Generator
49− Data.Swagger.Schema.Validation
5028 Data.Swagger.SchemaOptions
5129
5230 -- internal modules
5331 Data.Swagger.Internal
5432 Data.Swagger.Internal.Schema
55− Data.Swagger.Internal.Schema.Validation
5633 Data.Swagger.Internal.ParamSchema
5734 Data.Swagger.Internal.Utils
58− Data.Swagger.Internal.AesonUtils
59− Data.Swagger.Internal.TypeShape
60−
61− -- GHC boot libraries
62− build-depends:
63− base >=4.9 && <4.14
64− , aeson-pretty >=0.8.7 && <0.9
65− , bytestring >=0.10.4.0 && <0.11
66− , containers >=0.5.5.1 && <0.7
67− , template-haskell >=2.9.0.0 && <2.16
68− , time >=1.4.2 && <1.10
69− , transformers >=0.3.0.0 && <0.6
70−
71− build-depends:
72− mtl >=2.1 && <2.3
73− , text >=1.2.3.0 && <1.3
74−
75− -- other dependencies
76− build-depends:
77− base-compat-batteries >=0.10.4 && <0.12
78− , aeson >=1.4.2.0 && <1.5
79− -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
80− , cookie >=0.4.3 && <0.5
81− , generics-sop >=0.3.2.0 && <0.6
82− , hashable >=1.2.7.0 && <1.4
83− , http-media >=0.7.1.2 && <0.9
84− , insert-ordered-containers >=0.2.3 && <0.3
85− , lens >=4.16.1 && <4.19
86− , network >=2.6.3.5 && <3.2
87− , optics-core >=0.2 && <0.3
88− , optics-th >=0.2 && <0.3
89− , scientific >=0.3.6.2 && <0.4
90− , transformers-compat >=0.3 && <0.7
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.14
95−
35+ build-depends: base == 4.*
36+ , aeson
37+ , containers
38+ , hashable
39+ , http-media
40+ , mtl
41+ , network
42+ , text
43+ , template-haskell
44+ , time
45+ , unordered-containers
46+ , lens
47+ , scientific
9648 default-language: Haskell2010
9749
9850test-suite spec
9951 type: exitcode-stdio-1.0
10052 hs-source-dirs: test
10153 main-is: Spec.hs
102−
103− -- From library parat
104− -- We need aeson's toEncoding for doctests too
105− build-depends:
106− base
107− , swagger2
108− , aeson
109− , base-compat-batteries
110− , bytestring
111− , containers
112− , hashable
113− , insert-ordered-containers
114− , lens
115− , mtl
116− , template-haskell
117− , text
118− , time
119− , unordered-containers
120− , vector
121− , QuickCheck
122−
123− -- test-suite only dependencies
124− build-depends:
125− hspec >=2.5.5 && <2.8
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.8
133−
54+ build-depends: base == 4.*
55+ , swagger2
56+ , hspec
57+ , HUnit
58+ , QuickCheck
59+ , text
60+ , aeson
61+ , aeson-qq
62+ , containers
63+ , unordered-containers
64+ , vector
65+ , lens
13466 other-modules:
13567 SpecCommon
13668 Data.SwaggerSpec
137− Data.Swagger.CommonTestTypes
138− Data.Swagger.ParamSchemaSpec
13969 Data.Swagger.SchemaSpec
140− Data.Swagger.Schema.ValidationSpec
141− Data.Swagger.Schema.GeneratorSpec
14270 default-language: Haskell2010
14371
144−test-suite doctests
145− -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes
146− build-depends: base, doctest, Glob, QuickCheck
72+test-suite doctest
73+ build-depends: base, doctest, Glob
14774 default-language: Haskell2010
14875 hs-source-dirs: test
149− main-is: doctests.hs
76+ main-is: DocTest.hs
15077 type: exitcode-stdio-1.0
15178
15279source-repository head
test/Data/Swagger/CommonTestTypes.hsdeleted−679
@@ -1,679 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE QuasiQuotes #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.Swagger.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 GHC.Generics
19−
20−import Data.Swagger
21−
22−-- ========================================================================
23−-- Unit type
24−-- ========================================================================
25−
26−data Unit = Unit deriving (Generic)
27−instance ToParamSchema Unit
28−instance ToSchema Unit
29−
30−unitSchemaJSON :: Value
31−unitSchemaJSON = [aesonQQ|
32−{
33− "type": "string",
34− "enum": ["Unit"]
35−}
36−|]
37−
38−-- ========================================================================
39−-- Color (enum)
40−-- ========================================================================
41−data Color
42− = Red
43− | Green
44− | Blue
45− deriving (Generic)
46−instance ToParamSchema Color
47−instance ToSchema Color
48−
49−colorSchemaJSON :: Value
50−colorSchemaJSON = [aesonQQ|
51−{
52− "type": "string",
53− "enum": ["Red", "Green", "Blue"]
54−}
55−|]
56−
57−-- ========================================================================
58−-- Shade (paramSchemaToNamedSchema)
59−-- ========================================================================
60−
61−data Shade = Dim | Bright deriving (Generic)
62−instance ToParamSchema Shade
63−
64−instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
65−
66−shadeSchemaJSON :: Value
67−shadeSchemaJSON = [aesonQQ|
68−{
69− "type": "string",
70− "enum": ["Dim", "Bright"]
71−}
72−|]
73−
74−-- ========================================================================
75−-- Paint (record with bounded enum property)
76−-- ========================================================================
77−
78−newtype Paint = Paint { color :: Color }
79− deriving (Generic)
80−instance ToSchema Paint
81−
82−paintSchemaJSON :: Value
83−paintSchemaJSON = [aesonQQ|
84−{
85− "type": "object",
86− "properties":
87− {
88− "color":
89− {
90− "$ref": "#/definitions/Color"
91− }
92− },
93− "required": ["color"]
94−}
95−|]
96−
97−paintInlinedSchemaJSON :: Value
98−paintInlinedSchemaJSON = [aesonQQ|
99−{
100− "type": "object",
101− "properties":
102− {
103− "color":
104− {
105− "type": "string",
106− "enum": ["Red", "Green", "Blue"]
107− }
108− },
109− "required": ["color"]
110−}
111−|]
112−
113−-- ========================================================================
114−-- Status (constructorTagModifier)
115−-- ========================================================================
116−
117−data Status
118− = StatusOk
119− | StatusError
120− deriving (Generic)
121−
122−instance ToParamSchema Status where
123− toParamSchema = genericToParamSchema defaultSchemaOptions
124− { constructorTagModifier = map toLower . drop (length "Status") }
125−instance ToSchema Status where
126− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
127− { constructorTagModifier = map toLower . drop (length "Status") }
128−
129−statusSchemaJSON :: Value
130−statusSchemaJSON = [aesonQQ|
131−{
132− "type": "string",
133− "enum": ["ok", "error"]
134−}
135−|]
136−
137−-- ========================================================================
138−-- Email (newtype with unwrapUnaryRecords set to True)
139−-- ========================================================================
140−
141−newtype Email = Email { getEmail :: String }
142− deriving (Generic)
143−instance ToParamSchema Email
144−instance ToSchema Email where
145− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
146− { unwrapUnaryRecords = True }
147−
148−emailSchemaJSON :: Value
149−emailSchemaJSON = [aesonQQ|
150−{
151− "type": "string"
152−}
153−|]
154−
155−-- ========================================================================
156−-- UserId (non-record newtype)
157−-- ========================================================================
158−
159−newtype UserId = UserId Integer
160− deriving (Eq, Ord, Generic)
161−instance ToParamSchema UserId
162−instance ToSchema UserId
163−
164−userIdSchemaJSON :: Value
165−userIdSchemaJSON = [aesonQQ|
166−{
167− "type": "integer"
168−}
169−|]
170−
171−-- ========================================================================
172−-- UserGroup (set newtype)
173−-- ========================================================================
174−
175−newtype UserGroup = UserGroup (Set UserId)
176− deriving (Generic)
177−instance ToSchema UserGroup
178−
179−userGroupSchemaJSON :: Value
180−userGroupSchemaJSON = [aesonQQ|
181−{
182− "type": "array",
183− "items": { "$ref": "#/definitions/UserId" },
184− "uniqueItems": true
185−}
186−|]
187−
188−-- ========================================================================
189−-- Person (simple record with optional fields)
190−-- ========================================================================
191−data Person = Person
192− { name :: String
193− , phone :: Integer
194− , email :: Maybe String
195− } deriving (Generic)
196−
197−instance ToSchema Person
198−
199−personSchemaJSON :: Value
200−personSchemaJSON = [aesonQQ|
201−{
202− "type": "object",
203− "properties":
204− {
205− "name": { "type": "string" },
206− "phone": { "type": "integer" },
207− "email": { "type": "string" }
208− },
209− "required": ["name", "phone"]
210−}
211−|]
212−
213−-- ========================================================================
214−-- Player (record newtype)
215−-- ========================================================================
216−
217−newtype Player = Player
218− { position :: Point
219− } deriving (Generic)
220−instance ToSchema Player
221−
222−playerSchemaJSON :: Value
223−playerSchemaJSON = [aesonQQ|
224−{
225− "type": "object",
226− "properties":
227− {
228− "position":
229− {
230− "$ref": "#/definitions/Point"
231− }
232− },
233− "required": ["position"]
234−}
235−|]
236−
237−newtype Players = Players [Inlined Player]
238− deriving (Generic)
239−instance ToSchema Players
240−
241−playersSchemaJSON :: Value
242−playersSchemaJSON = [aesonQQ|
243−{
244− "type": "array",
245− "items":
246− {
247− "type": "object",
248− "properties":
249− {
250− "position":
251− {
252− "$ref": "#/definitions/Point"
253− }
254− },
255− "required": ["position"]
256− }
257−}
258−|]
259−
260−-- ========================================================================
261−-- Character (sum type with ref and record in alternative)
262−-- ========================================================================
263−
264−data Character
265− = PC Player
266− | NPC { npcName :: String, npcPosition :: Point }
267− deriving (Generic)
268−instance ToSchema Character
269−
270−characterSchemaJSON :: Value
271−characterSchemaJSON = [aesonQQ|
272−{
273− "type": "object",
274− "properties":
275− {
276− "PC": { "$ref": "#/definitions/Player" },
277− "NPC":
278− {
279− "type": "object",
280− "properties":
281− {
282− "npcName": { "type": "string" },
283− "npcPosition": { "$ref": "#/definitions/Point" }
284− },
285− "required": ["npcName", "npcPosition"]
286− }
287− },
288− "maxProperties": 1,
289− "minProperties": 1
290−}
291−|]
292−
293−characterInlinedSchemaJSON :: Value
294−characterInlinedSchemaJSON = [aesonQQ|
295−{
296− "type": "object",
297− "properties":
298− {
299− "PC":
300− {
301− "type": "object",
302− "properties":
303− {
304− "position":
305− {
306− "type": "object",
307− "properties":
308− {
309− "x": { "type": "number", "format": "double" },
310− "y": { "type": "number", "format": "double" }
311− },
312− "required": ["x", "y"]
313− }
314− },
315− "required": ["position"]
316− },
317− "NPC":
318− {
319− "type": "object",
320− "properties":
321− {
322− "npcName": { "type": "string" },
323− "npcPosition":
324− {
325− "type": "object",
326− "properties":
327− {
328− "x": { "type": "number", "format": "double" },
329− "y": { "type": "number", "format": "double" }
330− },
331− "required": ["x", "y"]
332− }
333− },
334− "required": ["npcName", "npcPosition"]
335− }
336− },
337− "maxProperties": 1,
338− "minProperties": 1
339−}
340−|]
341−
342−characterInlinedPlayerSchemaJSON :: Value
343−characterInlinedPlayerSchemaJSON = [aesonQQ|
344−{
345− "type": "object",
346− "properties":
347− {
348− "PC":
349− {
350− "type": "object",
351− "properties":
352− {
353− "position":
354− {
355− "$ref": "#/definitions/Point"
356− }
357− },
358− "required": ["position"]
359− },
360− "NPC":
361− {
362− "type": "object",
363− "properties":
364− {
365− "npcName": { "type": "string" },
366− "npcPosition": { "$ref": "#/definitions/Point" }
367− },
368− "required": ["npcName", "npcPosition"]
369− }
370− },
371− "maxProperties": 1,
372− "minProperties": 1
373−}
374−|]
375−
376−-- ========================================================================
377−-- ISPair (non-record product data type)
378−-- ========================================================================
379−data ISPair = ISPair Integer String
380− deriving (Generic)
381−
382−instance ToSchema ISPair
383−
384−ispairSchemaJSON :: Value
385−ispairSchemaJSON = [aesonQQ|
386−{
387− "type": "array",
388− "items":
389− [
390− { "type": "integer" },
391− { "type": "string" }
392− ],
393− "minItems": 2,
394− "maxItems": 2
395−}
396−|]
397−
398−-- ========================================================================
399−-- Point (record data type with custom fieldLabelModifier)
400−-- ========================================================================
401−
402−data Point = Point
403− { pointX :: Double
404− , pointY :: Double
405− } deriving (Generic)
406−
407−instance ToSchema Point where
408− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
409− { fieldLabelModifier = map toLower . drop (length "point") }
410−
411−pointSchemaJSON :: Value
412−pointSchemaJSON = [aesonQQ|
413−{
414− "type": "object",
415− "properties":
416− {
417− "x": { "type": "number", "format": "double" },
418− "y": { "type": "number", "format": "double" }
419− },
420− "required": ["x", "y"]
421−}
422−|]
423−
424−-- ========================================================================
425−-- Point (record data type with multiple fields)
426−-- ========================================================================
427−
428−data Point5 = Point5
429− { point5X :: Double
430− , point5Y :: Double
431− , point5Z :: Double
432− , point5U :: Double
433− , point5V :: Double -- 5 dimensional!
434− } deriving (Generic)
435−
436−instance ToSchema Point5 where
437− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
438− { fieldLabelModifier = map toLower . drop (length "point5") }
439−
440−point5SchemaJSON :: Value
441−point5SchemaJSON = [aesonQQ|
442−{
443− "type": "object",
444− "properties":
445− {
446− "x": { "type": "number", "format": "double" },
447− "y": { "type": "number", "format": "double" },
448− "z": { "type": "number", "format": "double" },
449− "u": { "type": "number", "format": "double" },
450− "v": { "type": "number", "format": "double" }
451− },
452− "required": ["x", "y", "z", "u", "v"]
453−}
454−|]
455−
456−point5Properties :: [String]
457−point5Properties = ["x", "y", "z", "u", "v"]
458−
459−-- ========================================================================
460−-- MyRoseTree (custom datatypeNameModifier)
461−-- ========================================================================
462−
463−data MyRoseTree = MyRoseTree
464− { root :: String
465− , trees :: [MyRoseTree]
466− } deriving (Generic)
467−
468−instance ToSchema MyRoseTree where
469− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
470− { datatypeNameModifier = drop (length "My") }
471−
472−myRoseTreeSchemaJSON :: Value
473−myRoseTreeSchemaJSON = [aesonQQ|
474−{
475− "type": "object",
476− "properties":
477− {
478− "root": { "type": "string" },
479− "trees":
480− {
481− "type": "array",
482− "items":
483− {
484− "$ref": "#/definitions/RoseTree"
485− }
486− }
487− },
488− "required": ["root", "trees"]
489−}
490−|]
491−
492−data MyRoseTree' = MyRoseTree'
493− { root' :: String
494− , trees' :: [MyRoseTree']
495− } deriving (Generic)
496−
497−instance ToSchema MyRoseTree' where
498− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
499− { datatypeNameModifier = map toLower }
500−
501−myRoseTreeSchemaJSON' :: Value
502−myRoseTreeSchemaJSON' = [aesonQQ|
503−{
504− "type": "object",
505− "properties":
506− {
507− "root'": { "type": "string" },
508− "trees'":
509− {
510− "type": "array",
511− "items":
512− {
513− "$ref": "#/definitions/myrosetree'"
514− }
515− }
516− },
517− "required": ["root'", "trees'"]
518−}
519−|]
520−
521−-- ========================================================================
522−-- Inlined (newtype for inlining schemas)
523−-- ========================================================================
524−
525−newtype Inlined a = Inlined { getInlined :: a }
526−
527−instance ToSchema a => ToSchema (Inlined a) where
528− declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
529− where
530− unname (NamedSchema _ s) = NamedSchema Nothing s
531−
532−-- ========================================================================
533−-- Light (sum type with unwrapUnaryRecords)
534−-- ========================================================================
535−
536−data Light
537− = NoLight
538− | LightFreq Double
539− | LightColor Color
540− | LightWaveLength { waveLength :: Double }
541− deriving (Generic)
542−
543−instance ToSchema Light where
544− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
545− { unwrapUnaryRecords = True }
546−
547−lightSchemaJSON :: Value
548−lightSchemaJSON = [aesonQQ|
549−{
550− "type": "object",
551− "properties":
552− {
553− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
554− "LightFreq": { "type": "number", "format": "double" },
555− "LightColor": { "$ref": "#/definitions/Color" },
556− "LightWaveLength": { "type": "number", "format": "double" }
557− },
558− "maxProperties": 1,
559− "minProperties": 1
560−}
561−|]
562−
563−lightInlinedSchemaJSON :: Value
564−lightInlinedSchemaJSON = [aesonQQ|
565−{
566− "type": "object",
567− "properties":
568− {
569− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
570− "LightFreq": { "type": "number", "format": "double" },
571− "LightColor":
572− {
573− "type": "string",
574− "enum": ["Red", "Green", "Blue"]
575− },
576− "LightWaveLength": { "type": "number", "format": "double" }
577− },
578− "maxProperties": 1,
579− "minProperties": 1
580−}
581−|]
582−
583−-- ========================================================================
584−-- ResourceId (series of newtypes)
585−-- ========================================================================
586−
587−newtype Id = Id String deriving (Generic)
588−instance ToSchema Id
589−
590−newtype ResourceId = ResourceId Id deriving (Generic)
591−instance ToSchema ResourceId
592−
593−-- ========================================================================
594−-- ButtonImages (bounded enum key mapping)
595−-- ========================================================================
596−
597−data ButtonState = Neutral | Focus | Active | Hover | Disabled
598− deriving (Show, Bounded, Enum, Generic)
599−
600−instance ToJSON ButtonState
601−instance ToSchema ButtonState
602−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)
603−
604−type ImageUrl = Text.Text
605−
606−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
607− deriving (Generic)
608−
609−instance ToJSON ButtonImages where
610− toJSON = toJSON . getButtonImages
611−
612−instance ToSchema ButtonImages where
613− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
614− declareSchemaBoundedEnumKeyMapping
615−
616−buttonImagesSchemaJSON :: Value
617−buttonImagesSchemaJSON = [aesonQQ|
618−{
619− "type": "object",
620− "properties":
621− {
622− "Neutral": { "type": "string" },
623− "Focus": { "type": "string" },
624− "Active": { "type": "string" },
625− "Hover": { "type": "string" },
626− "Disabled": { "type": "string" }
627− }
628−}
629−|]
630−
631−-- ========================================================================
632−-- SingleMaybeField (single field data with optional field)
633−-- ========================================================================
634−
635−data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }
636− deriving (Show, Generic)
637−
638−instance ToJSON SingleMaybeField
639−instance ToSchema SingleMaybeField
640−
641−singleMaybeFieldSchemaJSON :: Value
642−singleMaybeFieldSchemaJSON = [aesonQQ|
643−{
644− "type": "object",
645− "properties":
646− {
647− "singleMaybeField": { "type": "string" }
648− }
649−}
650−|]
651−
652−
653−-- ========================================================================
654−-- TimeOfDay
655−-- ========================================================================
656−data TimeOfDay
657− = Int
658− | Pico
659− deriving (Generic)
660−instance ToSchema TimeOfDay
661−instance ToParamSchema TimeOfDay
662−
663−
664−timeOfDaySchemaJSON :: Value
665−timeOfDaySchemaJSON = [aesonQQ|
666−{
667− "example": "12:33:15",
668− "type": "string",
669− "format": "hh:MM:ss"
670−}
671−|]
672−
673−timeOfDayParamSchemaJSON :: Value
674−timeOfDayParamSchemaJSON = [aesonQQ|
675−{
676− "type": "string",
677− "format": "hh:MM:ss"
678−}
679−|]
test/Data/Swagger/ParamSchemaSpec.hs+82−10
@@ -1,29 +1,24 @@
11{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveAnyClass #-}
33{-# LANGUAGE ScopedTypeVariables #-}
44{-# LANGUAGE TemplateHaskell #-}
55{-# LANGUAGE QuasiQuotes #-}
6−{-# LANGUAGE OverloadedStrings #-}
76module Data.Swagger.ParamSchemaSpec where
87
98import Data.Aeson
10−import Data.Aeson.QQ.Simple
9+import Data.Aeson.QQ
1110import Data.Char
1211import Data.Proxy
12+import Data.Set (Set)
1313import GHC.Generics
1414
1515import Data.Swagger
16−import Data.Swagger.Internal (SwaggerKind(..))
1716
18−import Data.Swagger.CommonTestTypes
1917import SpecCommon
2018import Test.Hspec
21−import Data.Time.LocalTime
22−
23−import qualified Data.HashMap.Strict as HM
2419
2520checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
26−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
21+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js
2722
2823spec :: Spec
2924spec = do
@@ -34,7 +29,84 @@ spec = do
3429 context "Unary records" $ do
3530 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
3631 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
3832
3933main :: IO ()
4034main = hspec spec
35+
36+-- ========================================================================
37+-- Unit type
38+-- ========================================================================
39+
40+data Unit = Unit deriving (Generic, ToParamSchema)
41+
42+unitSchemaJSON :: Value
43+unitSchemaJSON = [aesonQQ|
44+{
45+ "type": "string",
46+ "enum": ["Unit"]
47+}
48+|]
49+
50+-- ========================================================================
51+-- Color (enum)
52+-- ========================================================================
53+data Color
54+ = Red
55+ | Green
56+ | Blue
57+ deriving (Generic, ToParamSchema)
58+
59+colorSchemaJSON :: Value
60+colorSchemaJSON = [aesonQQ|
61+{
62+ "type": "string",
63+ "enum": ["Red", "Green", "Blue"]
64+}
65+|]
66+
67+-- ========================================================================
68+-- Status (constructorTagModifier)
69+-- ========================================================================
70+
71+data Status = StatusOk | StatusError deriving (Generic)
72+
73+instance ToParamSchema Status where
74+ toParamSchema = genericToParamSchema defaultSchemaOptions
75+ { constructorTagModifier = map toLower . drop (length "Status") }
76+
77+statusSchemaJSON :: Value
78+statusSchemaJSON = [aesonQQ|
79+{
80+ "type": "string",
81+ "enum": ["ok", "error"]
82+}
83+|]
84+
85+-- ========================================================================
86+-- Email (newtype with unwrapUnaryRecords set to True)
87+-- ========================================================================
88+
89+newtype Email = Email { getEmail :: String }
90+ deriving (Generic, ToParamSchema)
91+
92+emailSchemaJSON :: Value
93+emailSchemaJSON = [aesonQQ|
94+{
95+ "type": "string"
96+}
97+|]
98+
99+-- ========================================================================
100+-- UserId (non-record newtype)
101+-- ========================================================================
102+
103+newtype UserId = UserId Integer
104+ deriving (Generic, ToParamSchema)
105+
106+userIdSchemaJSON :: Value
107+userIdSchemaJSON = [aesonQQ|
108+{
109+ "type": "integer"
110+}
111+|]
112+
test/Data/Swagger/Schema/GeneratorSpec.hsdeleted−168
@@ -1,168 +0,0 @@
1−{-# LANGUAGE OverloadedLists #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE PackageImports #-}
4−module Data.Swagger.Schema.GeneratorSpec where
5−
6−import Prelude ()
7−import Prelude.Compat
8−
9−import Data.Swagger
10−import Data.Swagger.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_ ?~ SwaggerObject
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_ ?~ SwaggerObject
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_ ?~ SwaggerObject
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_ ?~ SwaggerObject
167− & properties .~ [("propE", boolSchema)]
168− & required .~ ["propE"]
test/Data/Swagger/Schema/ValidationSpec.hsdeleted−278
@@ -1,278 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE PackageImports #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# OPTIONS_GHC -fno-warn-orphans #-}
7−module Data.Swagger.Schema.ValidationSpec where
8−
9−import Control.Applicative
10−import Control.Lens ((&), (.~), (?~))
11−import Data.Aeson
12−import Data.Aeson.Types
13−import Data.Hashable (Hashable)
14−import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashMap.Strict as HashMap
16−import "unordered-containers" Data.HashSet (HashSet)
17−import qualified "unordered-containers" Data.HashSet as HashSet
18−import Data.Int
19−import Data.IntMap (IntMap)
20−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
21−import Data.Map (Map, fromList)
22−import Data.Monoid (mempty)
23−import Data.Proxy
24−import Data.Set (Set)
25−import qualified Data.Text as T
26−import qualified Data.Text.Lazy as TL
27−import Data.Time
28−import Data.Version (Version)
29−import Data.Word
30−import GHC.Generics
31−
32−import Data.Swagger
33−import Data.Swagger.Declare
34−
35−import Test.Hspec
36−import Test.Hspec.QuickCheck
37−import Test.QuickCheck
38−import Test.QuickCheck.Instances ()
39−
40−shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
41−shouldValidate _ x = validateToJSON x == []
42−
43−shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool
44−shouldNotValidate f = not . null . validateJSON defs sch . f
45− where
46− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
47−
48−spec :: Spec
49−spec = do
50− describe "Validation" $ do
51− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
52− prop "Char" $ shouldValidate (Proxy :: Proxy Char)
53− prop "Double" $ shouldValidate (Proxy :: Proxy Double)
54− prop "Float" $ shouldValidate (Proxy :: Proxy Float)
55− prop "Int" $ shouldValidate (Proxy :: Proxy Int)
56− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
57− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
58− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
59− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
60− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
61− prop "Word" $ shouldValidate (Proxy :: Proxy Word)
62− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
63− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
64− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
65− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
66− prop "String" $ shouldValidate (Proxy :: Proxy String)
67− prop "()" $ shouldValidate (Proxy :: Proxy ())
68− prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
69− prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
70− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
71− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
72− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
73− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
74− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
75− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
76− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
77− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
78− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
79− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
80− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
81− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
82− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
83− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
84− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
85− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
86− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
87− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
88− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
89− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
90− prop "Person" $ shouldValidate (Proxy :: Proxy Person)
91− prop "Color" $ shouldValidate (Proxy :: Proxy Color)
92− prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
93− prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
94− prop "Light" $ shouldValidate (Proxy :: Proxy Light)
95− prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)
96− prop "Version" $ shouldValidate (Proxy :: Proxy Version)
97− prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)
98−
99− describe "invalid cases" $ do
100− prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON
101− prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON
102− prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON
103− prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON
104− prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON
105−
106−main :: IO ()
107−main = hspec spec
108−
109−-- ========================================================================
110−-- Person (simple record with optional fields)
111−-- ========================================================================
112−data Person = Person
113− { name :: String
114− , phone :: Integer
115− , email :: Maybe String
116− } deriving (Show, Generic)
117−
118−instance ToJSON Person
119−instance ToSchema Person
120−
121−instance Arbitrary Person where
122− arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
123−
124−invalidPersonToJSON :: Person -> Value
125−invalidPersonToJSON Person{..} = object
126− [ T.pack "personName" .= toJSON name
127− , T.pack "personPhone" .= toJSON phone
128− , T.pack "personEmail" .= toJSON email
129− ]
130−
131−-- ========================================================================
132−-- Color (enum)
133−-- ========================================================================
134−data Color = Red | Green | Blue deriving (Show, Generic, Bounded, Enum)
135−
136−instance ToJSON Color
137−instance ToSchema Color
138−
139−instance Arbitrary Color where
140− arbitrary = arbitraryBoundedEnum
141−
142−invalidColorToJSON :: Color -> Value
143−invalidColorToJSON Red = toJSON "red"
144−invalidColorToJSON Green = toJSON "green"
145−invalidColorToJSON Blue = toJSON "blue"
146−
147−-- ========================================================================
148−-- Paint (record with bounded enum property)
149−-- ========================================================================
150−
151−newtype Paint = Paint { color :: Color }
152− deriving (Show, Generic)
153−
154−instance ToJSON Paint
155−instance ToSchema Paint
156−
157−instance Arbitrary Paint where
158− arbitrary = Paint <$> arbitrary
159−
160−invalidPaintToJSON :: Paint -> Value
161−invalidPaintToJSON = toJSON . color
162−
163−-- ========================================================================
164−-- MyRoseTree (custom datatypeNameModifier)
165−-- ========================================================================
166−
167−data MyRoseTree = MyRoseTree
168− { root :: String
169− , trees :: [MyRoseTree]
170− } deriving (Show, Generic)
171−
172−instance ToJSON MyRoseTree
173−
174−instance ToSchema MyRoseTree where
175− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
176− { datatypeNameModifier = drop (length "My") }
177−
178−instance Arbitrary MyRoseTree where
179− arbitrary = fmap (cut limit) $ MyRoseTree <$> arbitrary <*> (take limit <$> arbitrary)
180− where
181− limit = 4
182− cut 0 (MyRoseTree x _ ) = MyRoseTree x []
183− cut n (MyRoseTree x xs) = MyRoseTree x (map (cut (n - 1)) xs)
184−
185−-- ========================================================================
186−-- Light (sum type)
187−-- ========================================================================
188−
189−data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
190−
191−instance ToSchema Light where
192− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
193−
194−instance ToJSON Light where
195− toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
196−
197−instance Arbitrary Light where
198− arbitrary = oneof
199− [ return NoLight
200− , LightFreq <$> arbitrary
201− , LightColor <$> arbitrary
202− ]
203−
204−invalidLightToJSON :: Light -> Value
205−invalidLightToJSON = genericToJSON defaultOptions
206−
207−-- ========================================================================
208−-- ButtonImages (bounded enum key mapping)
209−-- ========================================================================
210−
211−data ButtonState = Neutral | Focus | Active | Hover | Disabled
212− deriving (Show, Eq, Ord, Bounded, Enum, Generic)
213−
214−instance ToJSON ButtonState
215−instance ToSchema ButtonState
216−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
217−
218−instance Arbitrary ButtonState where
219− arbitrary = arbitraryBoundedEnum
220−
221−type ImageUrl = T.Text
222−
223−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
224− deriving (Show, Generic)
225−
226−instance ToJSON ButtonImages where
227− toJSON = toJSON . getButtonImages
228−
229−instance ToSchema ButtonImages where
230− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
231− declareSchemaBoundedEnumKeyMapping
232−
233−invalidButtonImagesToJSON :: ButtonImages -> Value
234−invalidButtonImagesToJSON = genericToJSON defaultOptions
235−
236−instance Arbitrary ButtonImages where
237− arbitrary = ButtonImages <$> arbitrary
238−
239−-- ========================================================================
240−-- FreeForm (wraps a raw JSON Value)
241−-- ========================================================================
242−
243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
244− deriving (Show, Generic)
245−
246−instance ToJSON FreeForm where
247− toJSON = toJSON . jsonContent
248−
249−instance ToSchema FreeForm where
250− declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
251− & type_ ?~ SwaggerObject
252− & additionalProperties ?~ AdditionalPropertiesAllowed True
253−
254−instance Arbitrary FreeForm where
255− arbitrary = (FreeForm . fromList) <$> genObj
256− where
257− genObj = listOf $ do
258− k <- arbitrary
259− v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]
260− pure (k, v)
261−
262−instance Eq ZonedTime where
263− ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
264−
265−-- ========================================================================
266−-- Arbitrary instance for Data.Aeson.Value
267−-- ========================================================================
268−
269−instance Arbitrary Value where
270− -- Weights are almost random
271− -- Uniform oneof tends not to build complex objects cause of recursive call.
272− arbitrary = resize 4 $ frequency
273− [ (3, Object <$> arbitrary)
274− , (3, Array <$> arbitrary)
275− , (3, String <$> arbitrary)
276− , (3, Number <$> arbitrary)
277− , (3, Bool <$> arbitrary)
278− , (1, return Null) ]
test/Data/Swagger/SchemaSpec.hs+504−32
@@ -1,29 +1,27 @@
11{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveAnyClass #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34{-# LANGUAGE TemplateHaskell #-}
45{-# LANGUAGE QuasiQuotes #-}
56module Data.Swagger.SchemaSpec where
67
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
8+import Data.Aeson
9+import Data.Aeson.QQ
10+import Data.Char
11+import qualified Data.HashMap.Strict as HashMap
1312import Data.Proxy
1413import Data.Set (Set)
14+import qualified Data.Set as Set
15+import Data.Text (Text)
1516import qualified Data.Text as Text
17+import GHC.Generics
1618
1719import Data.Swagger
1820import Data.Swagger.Declare
1921
20−import Data.Swagger.CommonTestTypes
2122import SpecCommon
2223import Test.Hspec
2324
24−import qualified Data.HashMap.Strict as HM
25−import Data.Time.LocalTime
26−
2725checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
2826checkToSchema proxy js = toSchema proxy <=> js
2927
@@ -35,29 +33,22 @@ checkSchemaName sname proxy =
3533checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
3634checkDefs proxy names =
3735 it ("uses these definitions " ++ show names) $
38− InsOrdHashMap.keys defs `shouldBe` map Text.pack names
36+ Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)
3937 where
4038 defs = execDeclare (declareNamedSchema proxy) mempty
4139
42−checkProperties :: 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−
4940checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
5041checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
5142
5243checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec
53−checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js
44+checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs schema <=> js
5445 where
55− (defs, s) = runDeclare (declareSchema proxy) mempty
46+ (defs, schema) = runDeclare (declareSchema proxy) mempty
5647
5748checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec
58−checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js
49+checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs schema <=> js
5950 where
60− (defs, s) = runDeclare (declareSchema proxy) mempty
51+ (defs, schema) = runDeclare (declareSchema proxy) mempty
6152
6253spec :: Spec
6354spec = do
@@ -66,9 +57,6 @@ spec = do
6657 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
6758 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
6859 context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
69− context "Point5 (many field record)" $ do
70− checkToSchema (Proxy :: Proxy Point5) point5SchemaJSON
71− checkProperties (Proxy :: Proxy Point5) point5Properties
7260 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
7361 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
7462 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
@@ -77,10 +65,8 @@ spec = do
7765 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
7866 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
7967 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
80− context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
8168 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
8269 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
8470 context "Sum types" $ do
8571 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
8672 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
@@ -96,7 +82,6 @@ spec = do
9682 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
9783 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
9884 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
99− context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]
10085 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
10186 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
10287 describe "Inlining Schemas" $ do
@@ -105,10 +90,497 @@ spec = do
10590 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
10691 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
10792 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
108− context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
109− describe "Bounded Enum key mapping" $ do
110− context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON
111− context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON
11293
11394main :: IO ()
11495main = hspec spec
96+
97+-- ========================================================================
98+-- Person (simple record with optional fields)
99+-- ========================================================================
100+data Person = Person
101+ { name :: String
102+ , phone :: Integer
103+ , email :: Maybe String
104+ } deriving (Generic, ToSchema)
105+
106+personSchemaJSON :: Value
107+personSchemaJSON = [aesonQQ|
108+{
109+ "type": "object",
110+ "properties":
111+ {
112+ "name": { "type": "string" },
113+ "phone": { "type": "integer" },
114+ "email": { "type": "string" }
115+ },
116+ "required": ["name", "phone"]
117+}
118+|]
119+
120+-- ========================================================================
121+-- ISPair (non-record product data type)
122+-- ========================================================================
123+data ISPair = ISPair Integer String
124+ deriving (Generic, ToSchema)
125+
126+ispairSchemaJSON :: Value
127+ispairSchemaJSON = [aesonQQ|
128+{
129+ "type": "array",
130+ "items":
131+ [
132+ { "type": "integer" },
133+ { "type": "string" }
134+ ]
135+}
136+|]
137+
138+-- ========================================================================
139+-- Point (record data type with custom fieldLabelModifier)
140+-- ========================================================================
141+data Point = Point
142+ { pointX :: Double
143+ , pointY :: Double
144+ } deriving (Generic)
145+
146+instance ToSchema Point where
147+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
148+ { fieldLabelModifier = map toLower . drop (length "point") }
149+
150+pointSchemaJSON :: Value
151+pointSchemaJSON = [aesonQQ|
152+{
153+ "type": "object",
154+ "properties":
155+ {
156+ "x": { "type": "number", "format": "double" },
157+ "y": { "type": "number", "format": "double" }
158+ },
159+ "required": ["x", "y"]
160+}
161+|]
162+
163+
164+-- ========================================================================
165+-- Color (enum)
166+-- ========================================================================
167+data Color
168+ = Red
169+ | Green
170+ | Blue
171+ deriving (Generic, ToSchema)
172+
173+colorSchemaJSON :: Value
174+colorSchemaJSON = [aesonQQ|
175+{
176+ "type": "string",
177+ "enum": ["Red", "Green", "Blue"]
178+}
179+|]
180+
181+-- ========================================================================
182+-- Shade (paramSchemaToNamedSchema)
183+-- ========================================================================
184+
185+data Shade = Dim | Bright deriving (Generic, ToParamSchema)
186+
187+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
188+
189+shadeSchemaJSON :: Value
190+shadeSchemaJSON = [aesonQQ|
191+{
192+ "type": "string",
193+ "enum": ["Dim", "Bright"]
194+}
195+|]
196+
197+-- ========================================================================
198+-- Paint (record with bounded enum property)
199+-- ========================================================================
200+
201+newtype Paint = Paint { color :: Color }
202+ deriving (Generic, ToSchema)
203+
204+paintSchemaJSON :: Value
205+paintSchemaJSON = [aesonQQ|
206+{
207+ "type": "object",
208+ "properties":
209+ {
210+ "color":
211+ {
212+ "$ref": "#/definitions/Color"
213+ }
214+ },
215+ "required": ["color"]
216+}
217+|]
218+
219+paintInlinedSchemaJSON :: Value
220+paintInlinedSchemaJSON = [aesonQQ|
221+{
222+ "type": "object",
223+ "properties":
224+ {
225+ "color":
226+ {
227+ "type": "string",
228+ "enum": ["Red", "Green", "Blue"]
229+ }
230+ },
231+ "required": ["color"]
232+}
233+|]
234+
235+-- ========================================================================
236+-- Email (newtype with unwrapUnaryRecords set to True)
237+-- ========================================================================
238+
239+newtype Email = Email { getEmail :: String }
240+ deriving (Generic)
241+
242+instance ToSchema Email where
243+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
244+ { unwrapUnaryRecords = True }
245+
246+emailSchemaJSON :: Value
247+emailSchemaJSON = [aesonQQ|
248+{
249+ "type": "string"
250+}
251+|]
252+
253+-- ========================================================================
254+-- UserId (non-record newtype)
255+-- ========================================================================
256+
257+newtype UserId = UserId Integer
258+ deriving (Eq, Ord, Generic, ToSchema)
259+
260+userIdSchemaJSON :: Value
261+userIdSchemaJSON = [aesonQQ|
262+{
263+ "type": "integer"
264+}
265+|]
266+
267+-- ========================================================================
268+-- UserGroup (set newtype)
269+-- ========================================================================
270+
271+newtype UserGroup = UserGroup (Set UserId)
272+ deriving (Generic, ToSchema)
273+
274+userGroupSchemaJSON :: Value
275+userGroupSchemaJSON = [aesonQQ|
276+{
277+ "type": "array",
278+ "items": { "$ref": "#/definitions/UserId" },
279+ "uniqueItems": true
280+}
281+|]
282+
283+-- ========================================================================
284+-- Player (record newtype)
285+-- ========================================================================
286+
287+newtype Player = Player
288+ { position :: Point
289+ } deriving (Generic, ToSchema)
290+
291+playerSchemaJSON :: Value
292+playerSchemaJSON = [aesonQQ|
293+{
294+ "type": "object",
295+ "properties":
296+ {
297+ "position":
298+ {
299+ "$ref": "#/definitions/Point"
300+ }
301+ },
302+ "required": ["position"]
303+}
304+|]
305+
306+-- ========================================================================
307+-- MyRoseTree (custom datatypeNameModifier)
308+-- ========================================================================
309+
310+data MyRoseTree = MyRoseTree
311+ { root :: String
312+ , trees :: [MyRoseTree]
313+ } deriving (Generic)
314+
315+instance ToSchema MyRoseTree where
316+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
317+ { datatypeNameModifier = drop (length "My") }
318+
319+myRoseTreeSchemaJSON :: Value
320+myRoseTreeSchemaJSON = [aesonQQ|
321+{
322+ "type": "object",
323+ "properties":
324+ {
325+ "root": { "type": "string" },
326+ "trees":
327+ {
328+ "type": "array",
329+ "items":
330+ {
331+ "$ref": "#/definitions/RoseTree"
332+ }
333+ }
334+ },
335+ "required": ["root", "trees"]
336+}
337+|]
338+
339+-- ========================================================================
340+-- Inlined (newtype for inlining schemas)
341+-- ========================================================================
342+
343+newtype Inlined a = Inlined { getInlined :: a }
344+
345+instance ToSchema a => ToSchema (Inlined a) where
346+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
347+ where
348+ unname (NamedSchema _ schema) = NamedSchema Nothing schema
349+
350+newtype Players = Players [Inlined Player]
351+ deriving (Generic, ToSchema)
352+
353+playersSchemaJSON :: Value
354+playersSchemaJSON = [aesonQQ|
355+{
356+ "type": "array",
357+ "items":
358+ {
359+ "type": "object",
360+ "properties":
361+ {
362+ "position":
363+ {
364+ "$ref": "#/definitions/Point"
365+ }
366+ },
367+ "required": ["position"]
368+ }
369+}
370+|]
371+
372+-- ========================================================================
373+-- Status (sum type with unary constructors)
374+-- ========================================================================
375+
376+data Status
377+ = StatusOk String
378+ | StatusError String
379+ deriving (Generic)
380+
381+instance ToSchema Status where
382+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
383+ { constructorTagModifier = map toLower . drop (length "Status") }
384+
385+statusSchemaJSON :: Value
386+statusSchemaJSON = [aesonQQ|
387+{
388+ "type": "object",
389+ "properties":
390+ {
391+ "ok": { "type": "string" },
392+ "error": { "type": "string" }
393+ },
394+ "maxProperties": 1,
395+ "minProperties": 1
396+}
397+|]
398+
399+-- ========================================================================
400+-- Unit type
401+-- ========================================================================
402+
403+data Unit = Unit deriving (Generic, ToSchema)
404+
405+unitSchemaJSON :: Value
406+unitSchemaJSON = [aesonQQ|
407+{
408+ "type": "string",
409+ "enum": ["Unit"]
410+}
411+|]
412+
413+
414+-- ========================================================================
415+-- Character (sum type with ref and record in alternative)
416+-- ========================================================================
417+
418+data Character
419+ = PC Player
420+ | NPC { npcName :: String, npcPosition :: Point }
421+ deriving (Generic, ToSchema)
422+
423+characterSchemaJSON :: Value
424+characterSchemaJSON = [aesonQQ|
425+{
426+ "type": "object",
427+ "properties":
428+ {
429+ "PC": { "$ref": "#/definitions/Player" },
430+ "NPC":
431+ {
432+ "type": "object",
433+ "properties":
434+ {
435+ "npcName": { "type": "string" },
436+ "npcPosition": { "$ref": "#/definitions/Point" }
437+ },
438+ "required": ["npcName", "npcPosition"]
439+ }
440+ },
441+ "maxProperties": 1,
442+ "minProperties": 1
443+}
444+|]
445+
446+characterInlinedSchemaJSON :: Value
447+characterInlinedSchemaJSON = [aesonQQ|
448+{
449+ "type": "object",
450+ "properties":
451+ {
452+ "PC":
453+ {
454+ "type": "object",
455+ "properties":
456+ {
457+ "position":
458+ {
459+ "type": "object",
460+ "properties":
461+ {
462+ "x": { "type": "number", "format": "double" },
463+ "y": { "type": "number", "format": "double" }
464+ },
465+ "required": ["x", "y"]
466+ }
467+ },
468+ "required": ["position"]
469+ },
470+ "NPC":
471+ {
472+ "type": "object",
473+ "properties":
474+ {
475+ "npcName": { "type": "string" },
476+ "npcPosition":
477+ {
478+ "type": "object",
479+ "properties":
480+ {
481+ "x": { "type": "number", "format": "double" },
482+ "y": { "type": "number", "format": "double" }
483+ },
484+ "required": ["x", "y"]
485+ }
486+ },
487+ "required": ["npcName", "npcPosition"]
488+ }
489+ },
490+ "maxProperties": 1,
491+ "minProperties": 1
492+}
493+|]
494+
495+characterInlinedPlayerSchemaJSON :: Value
496+characterInlinedPlayerSchemaJSON = [aesonQQ|
497+{
498+ "type": "object",
499+ "properties":
500+ {
501+ "PC":
502+ {
503+ "type": "object",
504+ "properties":
505+ {
506+ "position":
507+ {
508+ "$ref": "#/definitions/Point"
509+ }
510+ },
511+ "required": ["position"]
512+ },
513+ "NPC":
514+ {
515+ "type": "object",
516+ "properties":
517+ {
518+ "npcName": { "type": "string" },
519+ "npcPosition": { "$ref": "#/definitions/Point" }
520+ },
521+ "required": ["npcName", "npcPosition"]
522+ }
523+ },
524+ "maxProperties": 1,
525+ "minProperties": 1
526+}
527+|]
528+
529+-- ========================================================================
530+-- Light (sum type with unwrapUnaryRecords)
531+-- ========================================================================
532+
533+data Light
534+ = NoLight
535+ | LightFreq Double
536+ | LightColor Color
537+ | LightWaveLength { waveLength :: Double }
538+ deriving (Generic)
539+
540+instance ToSchema Light where
541+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
542+ { unwrapUnaryRecords = True }
543+
544+lightSchemaJSON :: Value
545+lightSchemaJSON = [aesonQQ|
546+{
547+ "type": "object",
548+ "properties":
549+ {
550+ "NoLight": { "type": "array", "items": [] },
551+ "LightFreq": { "type": "number", "format": "double" },
552+ "LightColor": { "$ref": "#/definitions/Color" },
553+ "LightWaveLength": { "type": "number", "format": "double" }
554+ },
555+ "maxProperties": 1,
556+ "minProperties": 1
557+}
558+|]
559+
560+lightInlinedSchemaJSON :: Value
561+lightInlinedSchemaJSON = [aesonQQ|
562+{
563+ "type": "object",
564+ "properties":
565+ {
566+ "NoLight": { "type": "array", "items": [] },
567+ "LightFreq": { "type": "number", "format": "double" },
568+ "LightColor":
569+ {
570+ "type": "string",
571+ "enum": ["Red", "Green", "Blue"]
572+ },
573+ "LightWaveLength": { "type": "number", "format": "double" }
574+ },
575+ "maxProperties": 1,
576+ "minProperties": 1
577+}
578+|]
579+
580+-- ========================================================================
581+-- ResourceId (series of newtypes)
582+-- ========================================================================
583+
584+newtype Id = Id String deriving (Generic, ToSchema)
585+
586+newtype ResourceId = ResourceId Id deriving (Generic, ToSchema)
test/Data/SwaggerSpec.hs+333−427
@@ -4,15 +4,11 @@
44{-# LANGUAGE QuasiQuotes #-}
55module Data.SwaggerSpec where
66
7−import Prelude ()
8−import Prelude.Compat
9−
107import Control.Lens
118
129import Data.Aeson
13−import Data.Aeson.QQ.Simple
10+import Data.Aeson.QQ
1411import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashSet.InsOrd as InsOrdHS
1612import Data.Text (Text)
1713
1814import Data.Swagger
@@ -21,14 +17,6 @@ import Test.Hspec hiding (example)
2117
2218spec :: Spec
2319spec = do
24− describe "host" $ do
25− it "can decode the host port" $ do
26− let h = Just $ Host "localhost" (Just (fromInteger 8000))
27− swagger :: Swagger
28− swagger = swaggerExample
29− & host .~ h
30− parsed :: Swagger = either error id $ eitherDecode' $ encode swagger
31− parsed ^. host `shouldBe` h
3220 describe "License Object" $ licenseExample <=> licenseExampleJSON
3321 describe "Contact Object" $ contactExample <=> contactExampleJSON
3422 describe "Info Object" $ infoExample <=> infoExampleJSON
@@ -37,14 +25,11 @@ spec = do
3725 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
3826 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
3927 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
40− context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON
4128 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
4229 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
4330 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
4431 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
4532 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON
47− describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
4833 describe "Swagger Object" $ do
4934 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
5035 context "PetStore Example" $
@@ -128,7 +113,7 @@ licenseExampleJSON = [aesonQQ|
128113
129114operationExample :: Operation
130115operationExample = mempty
131− & tags .~ InsOrdHS.fromList ["pet"]
116+ & tags .~ ["pet"]
132117 & summary ?~ "Updates a pet in the store with form data"
133118 & description ?~ ""
134119 & operationId ?~ "updatePetWithForm"
@@ -159,7 +144,7 @@ operationExample = mempty
159144 stringSchema :: ParamLocation -> ParamOtherSchema
160145 stringSchema loc = mempty
161146 & in_ .~ loc
162− & type_ ?~ SwaggerString
147+ & type_ .~ SwaggerString
163148
164149operationExampleJSON :: Value
165150operationExampleJSON = [aesonQQ|
@@ -225,7 +210,7 @@ operationExampleJSON = [aesonQQ|
225210
226211schemaPrimitiveExample :: Schema
227212schemaPrimitiveExample = mempty
228− & type_ ?~ SwaggerString
213+ & type_ .~ SwaggerString
229214 & format ?~ "email"
230215
231216schemaPrimitiveExampleJSON :: Value
@@ -238,14 +223,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|
238223
239224schemaSimpleModelExample :: Schema
240225schemaSimpleModelExample = mempty
241− & type_ ?~ SwaggerObject
226+ & type_ .~ SwaggerObject
242227 & required .~ [ "name" ]
243228 & properties .~
244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))
229+ [ ("name", Inline (mempty & type_ .~ SwaggerString))
245230 , ("address", Ref (Reference "Address"))
246231 , ("age", Inline $ mempty
247232 & minimum_ ?~ 0
248− & type_ ?~ SwaggerInteger
233+ & type_ .~ SwaggerInteger
249234 & format ?~ "int32" ) ]
250235
251236schemaSimpleModelExampleJSON :: Value
@@ -273,8 +258,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
273258
274259schemaModelDictExample :: Schema
275260schemaModelDictExample = mempty
276− & type_ ?~ SwaggerObject
277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
261+ & type_ .~ SwaggerObject
262+ & additionalProperties ?~ (mempty & type_ .~ SwaggerString)
278263
279264schemaModelDictExampleJSON :: Value
280265schemaModelDictExampleJSON = [aesonQQ|
@@ -286,28 +271,15 @@ schemaModelDictExampleJSON = [aesonQQ|
286271}
287272|]
288273
289−schemaAdditionalExample :: Schema
290−schemaAdditionalExample = mempty
291− & type_ ?~ SwaggerObject
292− & additionalProperties ?~ AdditionalPropertiesAllowed True
293−
294−schemaAdditionalExampleJSON :: Value
295−schemaAdditionalExampleJSON = [aesonQQ|
296−{
297− "type": "object",
298− "additionalProperties": true
299−}
300−|]
301−
302274schemaWithExampleExample :: Schema
303275schemaWithExampleExample = mempty
304− & type_ ?~ SwaggerObject
276+ & type_ .~ SwaggerObject
305277 & properties .~
306278 [ ("id", Inline $ mempty
307− & type_ ?~ SwaggerInteger
279+ & type_ .~ SwaggerInteger
308280 & format ?~ "int64" )
309281 , ("name", Inline $ mempty
310− & type_ ?~ SwaggerString) ]
282+ & type_ .~ SwaggerString) ]
311283 & required .~ [ "name" ]
312284 & example ?~ [aesonQQ|
313285 {
@@ -346,19 +318,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
346318definitionsExample :: HashMap Text Schema
347319definitionsExample =
348320 [ ("Category", mempty
349− & type_ ?~ SwaggerObject
321+ & type_ .~ SwaggerObject
350322 & properties .~
351323 [ ("id", Inline $ mempty
352− & type_ ?~ SwaggerInteger
324+ & type_ .~ SwaggerInteger
353325 & format ?~ "int64")
354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
326+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )
355327 , ("Tag", mempty
356− & type_ ?~ SwaggerObject
328+ & type_ .~ SwaggerObject
357329 & properties .~
358330 [ ("id", Inline $ mempty
359− & type_ ?~ SwaggerInteger
331+ & type_ .~ SwaggerInteger
360332 & format ?~ "int64")
361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
333+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]
362334
363335definitionsExampleJSON :: Value
364336definitionsExampleJSON = [aesonQQ|
@@ -402,7 +374,7 @@ paramsDefinitionExample =
402374 & required ?~ True
403375 & schema .~ ParamOther (mempty
404376 & in_ .~ ParamQuery
405− & type_ ?~ SwaggerInteger
377+ & type_ .~ SwaggerInteger
406378 & format ?~ "int32" ))
407379 , ("limitParam", mempty
408380 & name .~ "limit"
@@ -410,7 +382,7 @@ paramsDefinitionExample =
410382 & required ?~ True
411383 & schema .~ ParamOther (mempty
412384 & in_ .~ ParamQuery
413− & type_ ?~ SwaggerInteger
385+ & type_ .~ SwaggerInteger
414386 & format ?~ "int32" )) ]
415387
416388paramsDefinitionExampleJSON :: Value
@@ -460,8 +432,8 @@ responsesDefinitionExampleJSON = [aesonQQ|
460432-- Responses Definition object
461433-- =======================================================================
462434
463−securityDefinitionsExample :: SecurityDefinitions
464−securityDefinitionsExample = SecurityDefinitions
435+securityDefinitionsExample :: HashMap Text SecurityScheme
436+securityDefinitionsExample =
465437 [ ("api_key", SecurityScheme
466438 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
467439 , _securitySchemeDescription = Nothing })
@@ -493,46 +465,6 @@ securityDefinitionsExampleJSON = [aesonQQ|
493465}
494466|]
495467
496−oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions
497−oAuth2SecurityDefinitionsReadExample = SecurityDefinitions
498− [ ("petstore_auth", SecurityScheme
499− { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params
500− { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"
501− , _oauth2Scopes =
502− [ ("read:pets", "read your pets") ] } )
503− , _securitySchemeDescription = Nothing })
504− ]
505−
506−oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions
507−oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions
508− [ ("petstore_auth", SecurityScheme
509− { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params
510− { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"
511− , _oauth2Scopes =
512− [ ("write:pets", "modify pets in your account") ] } )
513− , _securitySchemeDescription = Nothing })
514− ]
515−
516−oAuth2SecurityDefinitionsExample :: SecurityDefinitions
517−oAuth2SecurityDefinitionsExample =
518− oAuth2SecurityDefinitionsWriteExample <>
519− oAuth2SecurityDefinitionsReadExample
520−
521−oAuth2SecurityDefinitionsExampleJSON :: Value
522−oAuth2SecurityDefinitionsExampleJSON = [aesonQQ|
523−{
524− "petstore_auth": {
525− "type": "oauth2",
526− "authorizationUrl": "http://swagger.io/api/oauth/dialog",
527− "flow": "implicit",
528− "scopes": {
529− "write:pets": "modify pets in your account",
530− "read:pets": "read your pets"
531− }
532− }
533−}
534−|]
535−
536468-- =======================================================================
537469-- Swagger object
538470-- =======================================================================
@@ -551,18 +483,18 @@ swaggerExample = mempty
551483 & at 200 ?~ Inline (mempty
552484 & description .~ "OK"
553485 & schema ?~ Inline (mempty
554− & type_ ?~ SwaggerObject
486+ & type_ .~ SwaggerObject
555487 & example ?~ [aesonQQ|
556488 {
557489 "created": 100,
558490 "description": "get milk"
559491 } |]
560− & description ?~ "This is some real Todo right here"
492+ & description ?~ "This is some real Todo right here"
561493 & properties .~
562494 [ ("created", Inline $ mempty
563− & type_ ?~ SwaggerInteger
495+ & type_ .~ SwaggerInteger
564496 & format ?~ "int32")
565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))
497+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))
566498 & produces ?~ MimeList [ "application/json" ]
567499 & parameters .~
568500 [ Inline $ mempty
@@ -571,8 +503,8 @@ swaggerExample = mempty
571503 & description ?~ "TodoId param"
572504 & schema .~ ParamOther (mempty
573505 & in_ .~ ParamPath
574− & type_ ?~ SwaggerString ) ]
575− & tags .~ InsOrdHS.fromList [ "todo" ] ))
506+ & type_ .~ SwaggerString ) ]
507+ & tags .~ [ "todo" ] ))
576508
577509swaggerExampleJSON :: Value
578510swaggerExampleJSON = [aesonQQ|
@@ -639,130 +571,130 @@ swaggerExampleJSON = [aesonQQ|
639571
640572petstoreExampleJSON :: Value
641573petstoreExampleJSON = [aesonQQ|
642−{
574+{
643575 "swagger":"2.0",
644− "info":{
576+ "info":{
645577 "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.",
646578 "version":"1.0.0",
647579 "title":"Swagger Petstore",
648580 "termsOfService":"http://swagger.io/terms/",
649− "contact":{
581+ "contact":{
650582 "email":"apiteam@swagger.io"
651583 },
652− "license":{
584+ "license":{
653585 "name":"Apache 2.0",
654586 "url":"http://www.apache.org/licenses/LICENSE-2.0.html"
655587 }
656588 },
657589 "host":"petstore.swagger.io",
658590 "basePath":"/v2",
659− "tags":[
660− {
591+ "tags":[
592+ {
661593 "name":"pet",
662594 "description":"Everything about your Pets",
663− "externalDocs":{
595+ "externalDocs":{
664596 "description":"Find out more",
665597 "url":"http://swagger.io"
666598 }
667599 },
668− {
600+ {
669601 "name":"store",
670602 "description":"Access to Petstore orders"
671603 },
672− {
604+ {
673605 "name":"user",
674606 "description":"Operations about user",
675− "externalDocs":{
607+ "externalDocs":{
676608 "description":"Find out more about our store",
677609 "url":"http://swagger.io"
678610 }
679611 }
680612 ],
681− "schemes":[
613+ "schemes":[
682614 "http"
683615 ],
684− "paths":{
685− "/pet":{
686− "post":{
687− "tags":[
616+ "paths":{
617+ "/pet":{
618+ "post":{
619+ "tags":[
688620 "pet"
689621 ],
690622 "summary":"Add a new pet to the store",
691623 "description":"",
692624 "operationId":"addPet",
693− "consumes":[
625+ "consumes":[
694626 "application/json",
695627 "application/xml"
696628 ],
697− "produces":[
629+ "produces":[
698630 "application/xml",
699631 "application/json"
700632 ],
701− "parameters":[
702− {
633+ "parameters":[
634+ {
703635 "in":"body",
704636 "name":"body",
705637 "description":"Pet object that needs to be added to the store",
706638 "required":true,
707− "schema":{
639+ "schema":{
708640 "$ref":"#/definitions/Pet"
709641 }
710642 }
711643 ],
712− "responses":{
713− "405":{
644+ "responses":{
645+ "405":{
714646 "description":"Invalid input"
715647 }
716648 },
717− "security":[
718− {
719− "petstore_auth":[
649+ "security":[
650+ {
651+ "petstore_auth":[
720652 "write:pets",
721653 "read:pets"
722654 ]
723655 }
724656 ]
725657 },
726− "put":{
727− "tags":[
658+ "put":{
659+ "tags":[
728660 "pet"
729661 ],
730662 "summary":"Update an existing pet",
731663 "description":"",
732664 "operationId":"updatePet",
733− "consumes":[
665+ "consumes":[
734666 "application/json",
735667 "application/xml"
736668 ],
737− "produces":[
669+ "produces":[
738670 "application/xml",
739671 "application/json"
740672 ],
741− "parameters":[
742− {
673+ "parameters":[
674+ {
743675 "in":"body",
744676 "name":"body",
745677 "description":"Pet object that needs to be added to the store",
746678 "required":true,
747− "schema":{
679+ "schema":{
748680 "$ref":"#/definitions/Pet"
749681 }
750682 }
751683 ],
752− "responses":{
753− "400":{
684+ "responses":{
685+ "400":{
754686 "description":"Invalid ID supplied"
755687 },
756− "404":{
688+ "404":{
757689 "description":"Pet not found"
758690 },
759− "405":{
691+ "405":{
760692 "description":"Validation exception"
761693 }
762694 },
763− "security":[
764− {
765− "petstore_auth":[
695+ "security":[
696+ {
697+ "petstore_auth":[
766698 "write:pets",
767699 "read:pets"
768700 ]
@@ -770,28 +702,28 @@ petstoreExampleJSON = [aesonQQ|
770702 ]
771703 }
772704 },
773− "/pet/findByStatus":{
774− "get":{
775− "tags":[
705+ "/pet/findByStatus":{
706+ "get":{
707+ "tags":[
776708 "pet"
777709 ],
778710 "summary":"Finds Pets by status",
779711 "description":"Multiple status values can be provided with comma seperated strings",
780712 "operationId":"findPetsByStatus",
781− "produces":[
713+ "produces":[
782714 "application/xml",
783715 "application/json"
784716 ],
785− "parameters":[
786− {
717+ "parameters":[
718+ {
787719 "name":"status",
788720 "in":"query",
789721 "description":"Status values that need to be considered for filter",
790722 "required":true,
791723 "type":"array",
792− "items":{
724+ "items":{
793725 "type":"string",
794− "enum":[
726+ "enum":[
795727 "available",
796728 "pending",
797729 "sold"
@@ -801,23 +733,23 @@ petstoreExampleJSON = [aesonQQ|
801733 "collectionFormat":"csv"
802734 }
803735 ],
804− "responses":{
805− "200":{
736+ "responses":{
737+ "200":{
806738 "description":"successful operation",
807− "schema":{
739+ "schema":{
808740 "type":"array",
809− "items":{
741+ "items":{
810742 "$ref":"#/definitions/Pet"
811743 }
812744 }
813745 },
814− "400":{
746+ "400":{
815747 "description":"Invalid status value"
816748 }
817749 },
818− "security":[
819− {
820− "petstore_auth":[
750+ "security":[
751+ {
752+ "petstore_auth":[
821753 "write:pets",
822754 "read:pets"
823755 ]
@@ -825,48 +757,48 @@ petstoreExampleJSON = [aesonQQ|
825757 ]
826758 }
827759 },
828− "/pet/findByTags":{
829− "get":{
830− "tags":[
760+ "/pet/findByTags":{
761+ "get":{
762+ "tags":[
831763 "pet"
832764 ],
833765 "summary":"Finds Pets by tags",
834766 "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",
835767 "operationId":"findPetsByTags",
836− "produces":[
768+ "produces":[
837769 "application/xml",
838770 "application/json"
839771 ],
840− "parameters":[
841− {
772+ "parameters":[
773+ {
842774 "name":"tags",
843775 "in":"query",
844776 "description":"Tags to filter by",
845777 "required":true,
846778 "type":"array",
847− "items":{
779+ "items":{
848780 "type":"string"
849781 },
850782 "collectionFormat":"csv"
851783 }
852784 ],
853− "responses":{
854− "200":{
785+ "responses":{
786+ "200":{
855787 "description":"successful operation",
856− "schema":{
788+ "schema":{
857789 "type":"array",
858− "items":{
790+ "items":{
859791 "$ref":"#/definitions/Pet"
860792 }
861793 }
862794 },
863− "400":{
795+ "400":{
864796 "description":"Invalid tag value"
865797 }
866798 },
867− "security":[
868− {
869− "petstore_auth":[
799+ "security":[
800+ {
801+ "petstore_auth":[
870802 "write:pets",
871803 "read:pets"
872804 ]
@@ -874,20 +806,20 @@ petstoreExampleJSON = [aesonQQ|
874806 ]
875807 }
876808 },
877− "/pet/{petId}":{
878− "get":{
879− "tags":[
809+ "/pet/{petId}":{
810+ "get":{
811+ "tags":[
880812 "pet"
881813 ],
882814 "summary":"Find pet by ID",
883815 "description":"Returns a single pet",
884816 "operationId":"getPetById",
885− "produces":[
817+ "produces":[
886818 "application/xml",
887819 "application/json"
888820 ],
889− "parameters":[
890− {
821+ "parameters":[
822+ {
891823 "name":"petId",
892824 "in":"path",
893825 "description":"ID of pet to return",
@@ -896,42 +828,43 @@ petstoreExampleJSON = [aesonQQ|
896828 "format":"int64"
897829 }
898830 ],
899− "responses":{
900− "200":{
831+ "responses":{
832+ "200":{
901833 "description":"successful operation",
902− "schema":{
834+ "schema":{
903835 "$ref":"#/definitions/Pet"
904836 }
905837 },
906− "400":{
838+ "400":{
907839 "description":"Invalid ID supplied"
908840 },
909− "404":{
841+ "404":{
910842 "description":"Pet not found"
911843 }
912844 },
913− "security":[
914− {
915− "api_key": []
845+ "security":[
846+ {
847+ "api_key":[
848+ ]
916849 }
917850 ]
918851 },
919− "post":{
920− "tags":[
852+ "post":{
853+ "tags":[
921854 "pet"
922855 ],
923856 "summary":"Updates a pet in the store with form data",
924857 "description":"",
925858 "operationId":"updatePetWithForm",
926− "consumes":[
859+ "consumes":[
927860 "application/x-www-form-urlencoded"
928861 ],
929− "produces":[
862+ "produces":[
930863 "application/xml",
931864 "application/json"
932865 ],
933− "parameters":[
934− {
866+ "parameters":[
867+ {
935868 "name":"petId",
936869 "in":"path",
937870 "description":"ID of pet that needs to be updated",
@@ -939,14 +872,14 @@ petstoreExampleJSON = [aesonQQ|
939872 "type":"integer",
940873 "format":"int64"
941874 },
942− {
875+ {
943876 "name":"name",
944877 "in":"formData",
945878 "description":"Updated name of the pet",
946879 "required":false,
947880 "type":"string"
948881 },
949− {
882+ {
950883 "name":"status",
951884 "in":"formData",
952885 "description":"Updated status of the pet",
@@ -954,39 +887,39 @@ petstoreExampleJSON = [aesonQQ|
954887 "type":"string"
955888 }
956889 ],
957− "responses":{
958− "405":{
890+ "responses":{
891+ "405":{
959892 "description":"Invalid input"
960893 }
961894 },
962− "security":[
963− {
964− "petstore_auth":[
895+ "security":[
896+ {
897+ "petstore_auth":[
965898 "write:pets",
966899 "read:pets"
967900 ]
968901 }
969902 ]
970903 },
971− "delete":{
972− "tags":[
904+ "delete":{
905+ "tags":[
973906 "pet"
974907 ],
975908 "summary":"Deletes a pet",
976909 "description":"",
977910 "operationId":"deletePet",
978− "produces":[
911+ "produces":[
979912 "application/xml",
980913 "application/json"
981914 ],
982− "parameters":[
983− {
915+ "parameters":[
916+ {
984917 "name":"api_key",
985918 "in":"header",
986919 "required":false,
987920 "type":"string"
988921 },
989− {
922+ {
990923 "name":"petId",
991924 "in":"path",
992925 "description":"Pet id to delete",
@@ -995,14 +928,14 @@ petstoreExampleJSON = [aesonQQ|
995928 "format":"int64"
996929 }
997930 ],
998− "responses":{
999− "400":{
931+ "responses":{
932+ "400":{
1000933 "description":"Invalid pet value"
1001934 }
1002935 },
1003− "security":[
1004− {
1005− "petstore_auth":[
936+ "security":[
937+ {
938+ "petstore_auth":[
1006939 "write:pets",
1007940 "read:pets"
1008941 ]
@@ -1010,22 +943,22 @@ petstoreExampleJSON = [aesonQQ|
1010943 ]
1011944 }
1012945 },
1013− "/pet/{petId}/uploadImage":{
1014− "post":{
1015− "tags":[
946+ "/pet/{petId}/uploadImage":{
947+ "post":{
948+ "tags":[
1016949 "pet"
1017950 ],
1018951 "summary":"uploads an image",
1019952 "description":"",
1020953 "operationId":"uploadFile",
1021− "consumes":[
954+ "consumes":[
1022955 "multipart/form-data"
1023956 ],
1024− "produces":[
957+ "produces":[
1025958 "application/json"
1026959 ],
1027− "parameters":[
1028− {
960+ "parameters":[
961+ {
1029962 "name":"petId",
1030963 "in":"path",
1031964 "description":"ID of pet to update",
@@ -1033,14 +966,14 @@ petstoreExampleJSON = [aesonQQ|
1033966 "type":"integer",
1034967 "format":"int64"
1035968 },
1036− {
969+ {
1037970 "name":"additionalMetadata",
1038971 "in":"formData",
1039972 "description":"Additional data to pass to server",
1040973 "required":false,
1041974 "type":"string"
1042975 },
1043− {
976+ {
1044977 "name":"file",
1045978 "in":"formData",
1046979 "description":"file to upload",
@@ -1048,17 +981,17 @@ petstoreExampleJSON = [aesonQQ|
1048981 "type":"file"
1049982 }
1050983 ],
1051− "responses":{
1052− "200":{
984+ "responses":{
985+ "200":{
1053986 "description":"successful operation",
1054− "schema":{
987+ "schema":{
1055988 "$ref":"#/definitions/ApiResponse"
1056989 }
1057990 }
1058991 },
1059− "security":[
1060− {
1061− "petstore_auth":[
992+ "security":[
993+ {
994+ "petstore_auth":[
1062995 "write:pets",
1063996 "read:pets"
1064997 ]
@@ -1066,87 +999,89 @@ petstoreExampleJSON = [aesonQQ|
1066999 ]
10671000 }
10681001 },
1069− "/store/inventory":{
1070− "get":{
1071− "tags":[
1002+ "/store/inventory":{
1003+ "get":{
1004+ "tags":[
10721005 "store"
10731006 ],
10741007 "summary":"Returns pet inventories by status",
10751008 "description":"Returns a map of status codes to quantities",
10761009 "operationId":"getInventory",
1077− "produces":[
1010+ "produces":[
10781011 "application/json"
10791012 ],
1080− "parameters": [],
1081− "responses":{
1082− "200":{
1013+ "parameters":[
1014+ ],
1015+ "responses":{
1016+ "200":{
10831017 "description":"successful operation",
1084− "schema":{
1018+ "schema":{
10851019 "type":"object",
1086− "additionalProperties":{
1020+ "additionalProperties":{
10871021 "type":"integer",
10881022 "format":"int32"
10891023 }
10901024 }
10911025 }
10921026 },
1093− "security":[
1094− {
1095− "api_key": []
1027+ "security":[
1028+ {
1029+ "api_key":[
1030+ ]
10961031 }
10971032 ]
10981033 }
10991034 },
1100− "/store/order":{
1101− "post":{
1102− "tags":[
1035+ "/store/order":{
1036+ "post":{
1037+ "tags":[
11031038 "store"
11041039 ],
11051040 "summary":"Place an order for a pet",
11061041 "description":"",
11071042 "operationId":"placeOrder",
1108− "produces":[
1043+ "produces":[
11091044 "application/xml",
11101045 "application/json"
11111046 ],
1112− "parameters":[
1113− {
1047+ "parameters":[
1048+ {
11141049 "in":"body",
11151050 "name":"body",
11161051 "description":"order placed for purchasing the pet",
11171052 "required":true,
1118− "schema":{
1053+ "schema":{
11191054 "$ref":"#/definitions/Order"
11201055 }
11211056 }
11221057 ],
1123− "responses":{
1124− "200":{
1058+ "responses":{
1059+ "200":{
11251060 "description":"successful operation",
1126− "schema":{
1061+ "schema":{
11271062 "$ref":"#/definitions/Order"
11281063 }
11291064 },
1130− "400":{
1065+ "400":{
11311066 "description":"Invalid Order"
11321067 }
11331068 }
11341069 }
11351070 },
1136− "/store/order/{orderId}":{
1137− "get":{
1138− "tags":[
1071+ "/store/order/{orderId}":{
1072+ "get":{
1073+ "tags":[
11391074 "store"
11401075 ],
11411076 "summary":"Find purchase order by ID",
11421077 "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",
11431078 "operationId":"getOrderById",
1144− "produces":[
1079+ "produces":[
11451080 "application/xml",
11461081 "application/json"
11471082 ],
1148− "parameters":[
1149− {
1083+ "parameters":[
1084+ {
11501085 "name":"orderId",
11511086 "in":"path",
11521087 "description":"ID of pet that needs to be fetched",
@@ -1157,34 +1092,34 @@ petstoreExampleJSON = [aesonQQ|
11571092 "format":"int64"
11581093 }
11591094 ],
1160− "responses":{
1161− "200":{
1095+ "responses":{
1096+ "200":{
11621097 "description":"successful operation",
1163− "schema":{
1098+ "schema":{
11641099 "$ref":"#/definitions/Order"
11651100 }
11661101 },
1167− "400":{
1102+ "400":{
11681103 "description":"Invalid ID supplied"
11691104 },
1170− "404":{
1105+ "404":{
11711106 "description":"Order not found"
11721107 }
11731108 }
11741109 },
1175− "delete":{
1176− "tags":[
1110+ "delete":{
1111+ "tags":[
11771112 "store"
11781113 ],
11791114 "summary":"Delete purchase order by ID",
11801115 "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",
11811116 "operationId":"deleteOrder",
1182− "produces":[
1117+ "produces":[
11831118 "application/xml",
11841119 "application/json"
11851120 ],
1186− "parameters":[
1187− {
1121+ "parameters":[
1122+ {
11881123 "name":"orderId",
11891124 "in":"path",
11901125 "description":"ID of the order that needs to be deleted",
@@ -1193,133 +1128,133 @@ petstoreExampleJSON = [aesonQQ|
11931128 "minimum":1.0
11941129 }
11951130 ],
1196− "responses":{
1197− "400":{
1131+ "responses":{
1132+ "400":{
11981133 "description":"Invalid ID supplied"
11991134 },
1200− "404":{
1135+ "404":{
12011136 "description":"Order not found"
12021137 }
12031138 }
12041139 }
12051140 },
1206− "/user":{
1207− "post":{
1208− "tags":[
1141+ "/user":{
1142+ "post":{
1143+ "tags":[
12091144 "user"
12101145 ],
12111146 "summary":"Create user",
12121147 "description":"This can only be done by the logged in user.",
12131148 "operationId":"createUser",
1214− "produces":[
1149+ "produces":[
12151150 "application/xml",
12161151 "application/json"
12171152 ],
1218− "parameters":[
1219− {
1153+ "parameters":[
1154+ {
12201155 "in":"body",
12211156 "name":"body",
12221157 "description":"Created user object",
12231158 "required":true,
1224− "schema":{
1159+ "schema":{
12251160 "$ref":"#/definitions/User"
12261161 }
12271162 }
12281163 ],
1229− "responses":{
1230− "default":{
1164+ "responses":{
1165+ "default":{
12311166 "description":"successful operation"
12321167 }
12331168 }
12341169 }
12351170 },
1236− "/user/createWithArray":{
1237− "post":{
1238− "tags":[
1171+ "/user/createWithArray":{
1172+ "post":{
1173+ "tags":[
12391174 "user"
12401175 ],
12411176 "summary":"Creates list of users with given input array",
12421177 "description":"",
12431178 "operationId":"createUsersWithArrayInput",
1244− "produces":[
1179+ "produces":[
12451180 "application/xml",
12461181 "application/json"
12471182 ],
1248− "parameters":[
1249− {
1183+ "parameters":[
1184+ {
12501185 "in":"body",
12511186 "name":"body",
12521187 "description":"List of user object",
12531188 "required":true,
1254− "schema":{
1189+ "schema":{
12551190 "type":"array",
1256− "items":{
1191+ "items":{
12571192 "$ref":"#/definitions/User"
12581193 }
12591194 }
12601195 }
12611196 ],
1262− "responses":{
1263− "default":{
1197+ "responses":{
1198+ "default":{
12641199 "description":"successful operation"
12651200 }
12661201 }
12671202 }
12681203 },
1269− "/user/createWithList":{
1270− "post":{
1271− "tags":[
1204+ "/user/createWithList":{
1205+ "post":{
1206+ "tags":[
12721207 "user"
12731208 ],
12741209 "summary":"Creates list of users with given input array",
12751210 "description":"",
12761211 "operationId":"createUsersWithListInput",
1277− "produces":[
1212+ "produces":[
12781213 "application/xml",
12791214 "application/json"
12801215 ],
1281− "parameters":[
1282− {
1216+ "parameters":[
1217+ {
12831218 "in":"body",
12841219 "name":"body",
12851220 "description":"List of user object",
12861221 "required":true,
1287− "schema":{
1222+ "schema":{
12881223 "type":"array",
1289− "items":{
1224+ "items":{
12901225 "$ref":"#/definitions/User"
12911226 }
12921227 }
12931228 }
12941229 ],
1295− "responses":{
1296− "default":{
1230+ "responses":{
1231+ "default":{
12971232 "description":"successful operation"
12981233 }
12991234 }
13001235 }
13011236 },
1302− "/user/login":{
1303− "get":{
1304− "tags":[
1237+ "/user/login":{
1238+ "get":{
1239+ "tags":[
13051240 "user"
13061241 ],
13071242 "summary":"Logs user into the system",
13081243 "description":"",
13091244 "operationId":"loginUser",
1310− "produces":[
1245+ "produces":[
13111246 "application/xml",
13121247 "application/json"
13131248 ],
1314− "parameters":[
1315− {
1249+ "parameters":[
1250+ {
13161251 "name":"username",
13171252 "in":"query",
13181253 "description":"The user name for login",
13191254 "required":true,
13201255 "type":"string"
13211256 },
1322− {
1257+ {
13231258 "name":"password",
13241259 "in":"query",
13251260 "description":"The password for login in clear text",
@@ -1327,65 +1262,66 @@ petstoreExampleJSON = [aesonQQ|
13271262 "type":"string"
13281263 }
13291264 ],
1330− "responses":{
1331− "200":{
1265+ "responses":{
1266+ "200":{
13321267 "description":"successful operation",
1333− "schema":{
1268+ "schema":{
13341269 "type":"string"
13351270 },
1336− "headers":{
1337− "X-Rate-Limit":{
1271+ "headers":{
1272+ "X-Rate-Limit":{
13381273 "type":"integer",
13391274 "format":"int32",
13401275 "description":"calls per hour allowed by the user"
13411276 },
1342− "X-Expires-After":{
1277+ "X-Expires-After":{
13431278 "type":"string",
13441279 "format":"date-time",
13451280 "description":"date in UTC when toekn expires"
13461281 }
13471282 }
13481283 },
1349− "400":{
1284+ "400":{
13501285 "description":"Invalid username/password supplied"
13511286 }
13521287 }
13531288 }
13541289 },
1355− "/user/logout":{
1356− "get":{
1357− "tags":[
1290+ "/user/logout":{
1291+ "get":{
1292+ "tags":[
13581293 "user"
13591294 ],
13601295 "summary":"Logs out current logged in user session",
13611296 "description":"",
13621297 "operationId":"logoutUser",
1363− "produces":[
1298+ "produces":[
13641299 "application/xml",
13651300 "application/json"
13661301 ],
1367− "parameters": [],
1368− "responses":{
1369− "default":{
1302+ "parameters":[
1303+ ],
1304+ "responses":{
1305+ "default":{
13701306 "description":"successful operation"
13711307 }
13721308 }
13731309 }
13741310 },
1375− "/user/{username}":{
1376− "get":{
1377− "tags":[
1311+ "/user/{username}":{
1312+ "get":{
1313+ "tags":[
13781314 "user"
13791315 ],
13801316 "summary":"Get user by user name",
13811317 "description":"",
13821318 "operationId":"getUserByName",
1383− "produces":[
1319+ "produces":[
13841320 "application/xml",
13851321 "application/json"
13861322 ],
1387− "parameters":[
1388− {
1323+ "parameters":[
1324+ {
13891325 "name":"username",
13901326 "in":"path",
13911327 "description":"The name that needs to be fetched. Use user1 for testing. ",
@@ -1393,72 +1329,72 @@ petstoreExampleJSON = [aesonQQ|
13931329 "type":"string"
13941330 }
13951331 ],
1396− "responses":{
1397− "200":{
1332+ "responses":{
1333+ "200":{
13981334 "description":"successful operation",
1399− "schema":{
1335+ "schema":{
14001336 "$ref":"#/definitions/User"
14011337 }
14021338 },
1403− "400":{
1339+ "400":{
14041340 "description":"Invalid username supplied"
14051341 },
1406− "404":{
1342+ "404":{
14071343 "description":"User not found"
14081344 }
14091345 }
14101346 },
1411− "put":{
1412− "tags":[
1347+ "put":{
1348+ "tags":[
14131349 "user"
14141350 ],
14151351 "summary":"Updated user",
14161352 "description":"This can only be done by the logged in user.",
14171353 "operationId":"updateUser",
1418− "produces":[
1354+ "produces":[
14191355 "application/xml",
14201356 "application/json"
14211357 ],
1422− "parameters":[
1423− {
1358+ "parameters":[
1359+ {
14241360 "name":"username",
14251361 "in":"path",
14261362 "description":"name that need to be deleted",
14271363 "required":true,
14281364 "type":"string"
14291365 },
1430− {
1366+ {
14311367 "in":"body",
14321368 "name":"body",
14331369 "description":"Updated user object",
14341370 "required":true,
1435− "schema":{
1371+ "schema":{
14361372 "$ref":"#/definitions/User"
14371373 }
14381374 }
14391375 ],
1440− "responses":{
1441− "400":{
1376+ "responses":{
1377+ "400":{
14421378 "description":"Invalid user supplied"
14431379 },
1444− "404":{
1380+ "404":{
14451381 "description":"User not found"
14461382 }
14471383 }
14481384 },
1449− "delete":{
1450− "tags":[
1385+ "delete":{
1386+ "tags":[
14511387 "user"
14521388 ],
14531389 "summary":"Delete user",
14541390 "description":"This can only be done by the logged in user.",
14551391 "operationId":"deleteUser",
1456− "produces":[
1392+ "produces":[
14571393 "application/xml",
14581394 "application/json"
14591395 ],
1460− "parameters":[
1461− {
1396+ "parameters":[
1397+ {
14621398 "name":"username",
14631399 "in":"path",
14641400 "description":"The name that needs to be deleted",
@@ -1466,237 +1402,207 @@ petstoreExampleJSON = [aesonQQ|
14661402 "type":"string"
14671403 }
14681404 ],
1469− "responses":{
1470− "400":{
1405+ "responses":{
1406+ "400":{
14711407 "description":"Invalid username supplied"
14721408 },
1473− "404":{
1409+ "404":{
14741410 "description":"User not found"
14751411 }
14761412 }
14771413 }
14781414 }
14791415 },
1480− "securityDefinitions":{
1481− "petstore_auth":{
1416+ "securityDefinitions":{
1417+ "petstore_auth":{
14821418 "type":"oauth2",
14831419 "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",
14841420 "flow":"implicit",
1485− "scopes":{
1421+ "scopes":{
14861422 "write:pets":"modify pets in your account",
14871423 "read:pets":"read your pets"
14881424 }
14891425 },
1490− "api_key":{
1426+ "api_key":{
14911427 "type":"apiKey",
14921428 "name":"api_key",
14931429 "in":"header"
14941430 }
14951431 },
1496− "definitions":{
1497− "Order":{
1432+ "definitions":{
1433+ "Order":{
14981434 "type":"object",
1499− "properties":{
1500− "id":{
1435+ "properties":{
1436+ "id":{
15011437 "type":"integer",
15021438 "format":"int64"
15031439 },
1504− "petId":{
1440+ "petId":{
15051441 "type":"integer",
15061442 "format":"int64"
15071443 },
1508− "quantity":{
1444+ "quantity":{
15091445 "type":"integer",
15101446 "format":"int32"
15111447 },
1512− "shipDate":{
1448+ "shipDate":{
15131449 "type":"string",
15141450 "format":"date-time"
15151451 },
1516− "status":{
1452+ "status":{
15171453 "type":"string",
15181454 "description":"Order Status",
1519− "enum":[
1455+ "enum":[
15201456 "placed",
15211457 "approved",
15221458 "delivered"
15231459 ]
15241460 },
1525− "complete":{
1461+ "complete":{
15261462 "type":"boolean",
15271463 "default":false
15281464 }
15291465 },
1530− "xml":{
1466+ "xml":{
15311467 "name":"Order"
15321468 }
15331469 },
1534− "Category":{
1470+ "Category":{
15351471 "type":"object",
1536− "properties":{
1537− "id":{
1472+ "properties":{
1473+ "id":{
15381474 "type":"integer",
15391475 "format":"int64"
15401476 },
1541− "name":{
1477+ "name":{
15421478 "type":"string"
15431479 }
15441480 },
1545− "xml":{
1481+ "xml":{
15461482 "name":"Category"
15471483 }
15481484 },
1549− "User":{
1485+ "User":{
15501486 "type":"object",
1551− "properties":{
1552− "id":{
1487+ "properties":{
1488+ "id":{
15531489 "type":"integer",
15541490 "format":"int64"
15551491 },
1556− "username":{
1492+ "username":{
15571493 "type":"string"
15581494 },
1559− "firstName":{
1495+ "firstName":{
15601496 "type":"string"
15611497 },
1562− "lastName":{
1498+ "lastName":{
15631499 "type":"string"
15641500 },
1565− "email":{
1501+ "email":{
15661502 "type":"string"
15671503 },
1568− "password":{
1504+ "password":{
15691505 "type":"string"
15701506 },
1571− "phone":{
1507+ "phone":{
15721508 "type":"string"
15731509 },
1574− "userStatus":{
1510+ "userStatus":{
15751511 "type":"integer",
15761512 "format":"int32",
15771513 "description":"User Status"
15781514 }
15791515 },
1580− "xml":{
1516+ "xml":{
15811517 "name":"User"
15821518 }
15831519 },
1584− "Tag":{
1520+ "Tag":{
15851521 "type":"object",
1586− "properties":{
1587− "id":{
1522+ "properties":{
1523+ "id":{
15881524 "type":"integer",
15891525 "format":"int64"
15901526 },
1591− "name":{
1527+ "name":{
15921528 "type":"string"
15931529 }
15941530 },
1595− "xml":{
1531+ "xml":{
15961532 "name":"Tag"
15971533 }
15981534 },
1599− "Pet":{
1535+ "Pet":{
16001536 "type":"object",
1601− "required":[
1537+ "required":[
16021538 "name",
16031539 "photoUrls"
16041540 ],
1605− "properties":{
1606− "id":{
1541+ "properties":{
1542+ "id":{
16071543 "type":"integer",
16081544 "format":"int64"
16091545 },
1610− "category":{
1546+ "category":{
16111547 "$ref":"#/definitions/Category"
16121548 },
1613− "name":{
1549+ "name":{
16141550 "type":"string",
16151551 "example":"doggie"
16161552 },
1617− "photoUrls":{
1553+ "photoUrls":{
16181554 "type":"array",
1619− "xml":{
1555+ "xml":{
16201556 "name":"photoUrl",
16211557 "wrapped":true
16221558 },
1623− "items":{
1559+ "items":{
16241560 "type":"string"
16251561 }
16261562 },
1627− "tags":{
1563+ "tags":{
16281564 "type":"array",
1629− "xml":{
1565+ "xml":{
16301566 "name":"tag",
16311567 "wrapped":true
16321568 },
1633− "items":{
1569+ "items":{
16341570 "$ref":"#/definitions/Tag"
16351571 }
16361572 },
1637− "status":{
1573+ "status":{
16381574 "type":"string",
16391575 "description":"pet status in the store",
1640− "enum":[
1576+ "enum":[
16411577 "available",
16421578 "pending",
16431579 "sold"
16441580 ]
16451581 }
16461582 },
1647− "xml":{
1583+ "xml":{
16481584 "name":"Pet"
16491585 }
16501586 },
1651− "ApiResponse":{
1587+ "ApiResponse":{
16521588 "type":"object",
1653− "properties":{
1654− "code":{
1589+ "properties":{
1590+ "code":{
16551591 "type":"integer",
16561592 "format":"int32"
16571593 },
1658− "type":{
1594+ "type":{
16591595 "type":"string"
16601596 },
1661− "message":{
1597+ "message":{
16621598 "type":"string"
16631599 }
16641600 }
16651601 }
16661602 },
1667− "externalDocs":{
1603+ "externalDocs":{
16681604 "description":"Find out more about Swagger",
16691605 "url":"http://swagger.io"
16701606 }
16711607}
16721608|]
1673−
1674−compositionSchemaExample :: Schema
1675−compositionSchemaExample = mempty
1676− & type_ ?~ SwaggerObject
1677− & Data.Swagger.allOf ?~ [
1678− Ref (Reference "Other")
1679− , Inline (mempty
1680− & type_ ?~ SwaggerObject
1681− & properties .~
1682− [ ("greet", Inline $ mempty
1683− & type_ ?~ SwaggerString) ])
1684− ]
1685−
1686−compositionSchemaExampleJSON :: Value
1687−compositionSchemaExampleJSON = [aesonQQ|
1688−{
1689− "type": "object",
1690− "allOf": [
1691− {
1692− "$ref": "#/definitions/Other"
1693− },
1694− {
1695− "type": "object",
1696− "properties": {
1697− "greet": { "type": "string" }
1698− }
1699− }
1700− ]
1701−}
1702−|]
test/DocTest.hsnew file+7
@@ -0,0 +1,7 @@
1+module Main (main) where
2+
3+import System.FilePath.Glob (glob)
4+import Test.DocTest (doctest)
5+
6+main :: IO ()
7+main = glob "src/**/*.hs" >>= doctest
test/SpecCommon.hs+2−7
@@ -1,7 +1,6 @@
11module SpecCommon where
22
33import Data.Aeson
4−import Data.ByteString.Builder (toLazyByteString)
54import qualified Data.Foldable as F
65import qualified Data.HashMap.Strict as HashMap
76import qualified Data.Vector as Vector
@@ -22,9 +21,5 @@ x <=> js = do
2221 toJSON x `shouldBe` js
2322 it "decodes correctly" $ do
2423 fromJSON js `shouldBe` Success x
25− it "roundtrips: eitherDecode . encode" $ do
26− eitherDecode (encode x) `shouldBe` Right x
27− it "roundtrips with toJSON" $ do
28− eitherDecode (encode $ toJSON x) `shouldBe` Right x
29− it "roundtrips with toEncoding" $ do
30− eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x
24+
25+
test/doctests.hsdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−import Build_doctests (flags, pkgs, module_sources)
4−import Data.Foldable (traverse_)
5−import Test.DocTest
6−
7−main :: IO ()
8−main = do
9− traverse_ putStrLn args
10− doctest args
11− where
12− args = flags ++ pkgs ++ module_sources