git.iko.soy/typeable/swagger2
on dac4eef help sign in
5470313
swap
0 ahead, 255 behind
.ghcideleted−2
since splitsnapshots
unifiedsplit
@@ -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 @@
1dist
1dist
2−dist-newstyle
3−.ghc.environment.*
4cabal-dev
2cabal-dev
5*.o
3*.o
6*.hi
4*.hi
.travis.yml+67−150
@@ -1,162 +1,79 @@
1−# This Travis job script has been generated by a script via
1+# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
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−#
9language: c
2language: c
10−dist: xenial
11−git:
12− # whether to recursively clone submodules
13− submodules: false
3+sudo: false
14−branches:
4+
15− only:
16− - master
17cache:
5cache:
18 directories:
6 directories:
7+ - $HOME/.cabsnap
19 - $HOME/.cabal/packages
8 - $HOME/.cabal/packages
20− - $HOME/.cabal/store
9+
21before_cache:
10before_cache:
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
11+ - rm -fv $HOME/.cabal/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.*
12+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
13+
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
30matrix:
14matrix:
31 include:
15 include:
32− - compiler: ghc-8.8.1
16+ - env: CABALVER=1.18 GHCVER=7.8.4
33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
17+ compiler: ": #GHC 7.8.4"
34− - compiler: ghc-8.6.5
35− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
18+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5], sources: [hvr-ghc]}}
36− - compiler: ghc-8.4.4
19+ - env: CABALVER=1.22 GHCVER=7.10.3
37− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
20+ compiler: ": #GHC 7.10.3"
38− - compiler: ghc-8.2.2
21+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5], sources: [hvr-ghc]}}
39− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
22+
40− - compiler: ghc-8.0.2
41− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
42before_install:
23before_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
24+ - unset CC
48− - CABAL=/opt/ghc/bin/cabal
25+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/1.19.5/bin:$PATH
49− - CABALHOME=$HOME/.cabal
26+
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
74install:
27install:
75− - ${CABAL} --version
28+ - cabal --version
76− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
29+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
77− - TEST=--enable-tests
30+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
78− - BENCH=--enable-benchmarks
31+ then
79− - HEADHACKAGE=false
32+ zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
80− - rm -f $CABALHOME/config
33+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
81− - |
34+ fi
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
35+ - travis_retry cabal update -v
111− # Generate cabal.project
36+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
112− - rm -rf cabal.project cabal.project.local cabal.project.freeze
37+ - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
113− - touch cabal.project
38+ - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
114− - |
39+
115− echo "packages: ." >> cabal.project
40+# check whether current requested install-plan matches cached package-db snapshot
116− - |
41+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
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"
42+ then
118− - cat cabal.project || true
43+ echo "cabal build-cache HIT";
119− - cat cabal.project.local || true
44+ rm -rfv .ghc;
120− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
45+ cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
121− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
46+ cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
122− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
47+ else
123− - rm cabal.project.freeze
48+ echo "cabal build-cache MISS";
124− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output
49+ rm -rf $HOME/.cabsnap;
125− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
50+ mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
51+ cabal install --only-dependencies --enable-tests --enable-benchmarks;
52+ fi
53+
54+# snapshot package-db on cache miss
55+ - if [ ! -d $HOME/.cabsnap ];
56+ then
57+ echo "snapshotting package-db to build-cache";
58+ mkdir $HOME/.cabsnap;
59+ cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
60+ cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
61+ fi
62+
63+# Here starts the actual work to be performed for the package under test;
64+# any command which exits with a non-zero exit code causes the build to fail.
126script:
65script:
127− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
66+ - if [ -f configure.ac ]; then autoreconf -i; fi
128− # Packaging...
67+ - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
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)
68+ - cabal build # this builds all libraries and executables (including tests/benchmarks)
147− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
69+ - cabal test
148− # Building with tests and benchmarks...
70+ - cabal check
149− # build & run tests, build benchmarks
71+ - cabal sdist # tests that a source-distribution can be generated
150− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
72+
151− # Testing...
73+# Check that the resulting source distribution can be built & installed.
152− - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
74+# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
153− # cabal check...
75+# `cabal install --force-reinstalls dist/*-*.tar.gz`
154− - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check)
76+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
155− # haddock...
77+ (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
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
160
78
161−# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])
162# EOF
79# EOF
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−
1861.2.1
11.2.1
187---
2---
188
3
189−* Minor changes:
4+* Minor change:
190 * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.
5 * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.
191
6
192* Fixes:
7* Fixes:
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015-2017, GetShopTV
1+Copyright (c) 2015, GetShopTV
2All rights reserved.
2All rights reserved.
3
3
4Redistribution and use in source and binary forms, with or without
4Redistribution and use in source and binary forms, with or without
README.md+1−3
@@ -1,7 +1,5 @@
1# swagger2
1# swagger2
2
2
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−
5[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
3[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
6[![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)
4[![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)
7[![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2)
5[![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
13
11
14## Usage
12## Usage
15
13
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.
17
15
18Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2).
16Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2).
19
17
Setup.hs−31
@@ -1,33 +1,2 @@
1−{-# LANGUAGE CPP #-}
2−{-# OPTIONS_GHC -Wall #-}
3−module Main (main) where
4−
5−#ifndef MIN_VERSION_cabal_doctest
6−#define MIN_VERSION_cabal_doctest(x,y,z) 0
7−#endif
8−
9−#if MIN_VERSION_cabal_doctest(1,0,0)
10−
11−import Distribution.Extra.Doctest ( defaultMainWithDoctests )
12−main :: IO ()
13−main = defaultMainWithDoctests "doctests"
14−
15−#else
16−
17−#ifdef MIN_VERSION_Cabal
18−-- If the macro is defined, we have new cabal-install,
19−-- but for some reason we don't have cabal-doctest in package-db
20−--
21−-- Probably we are running cabal sdist, when otherwise using new-build
22−-- workflow
23−#warning You are configuring this package without cabal-doctest installed. \
24− The doctests test-suite will not work as a result. \
25− To fix this, install cabal-doctest before configuring.
26−#endif
27−
28import Distribution.Simple
1import Distribution.Simple
29−
30−main :: IO ()
31main = defaultMain
2main = defaultMain
32−
33−#endif
cabal.projectdeleted−2
@@ -1,2 +0,0 @@
1−packages: .
2−tests: true
examples/hackage.hs+1−15
@@ -20,21 +20,7 @@ type Username = Text
20data UserSummary = UserSummary
20data UserSummary = UserSummary
21 { summaryUsername :: Username
21 { summaryUsername :: Username
22 , summaryUserid :: Int
22 , summaryUserid :: Int
23− } deriving (Generic)
23+ } deriving (Generic, ToSchema)
24−
25−instance ToSchema UserSummary where
26− declareNamedSchema _ = do
27− usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
28− useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
29− return $ NamedSchema (Just "UserSummary") $ mempty
30− & type_ ?~ SwaggerObject
31− & properties .~
32− [ ("summaryUsername", usernameSchema )
33− , ("summaryUserid" , useridSchema )
34− ]
35− & required .~ [ "summaryUsername"
36− , "summaryUserid" ]
37−
38
24
39type Group = Text
25type Group = Text
40
26
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"
src/Data/Swagger.hs+7−96
@@ -1,9 +1,4 @@
1−{-# LANGUAGE CPP #-}
2-- |
1-- |
3−-- Module: Data.Swagger
4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5−-- Stability: experimental
6−--
7-- Swagger™ is a project used to describe and document RESTful APIs.
2-- Swagger™ is a project used to describe and document RESTful APIs.
8--
3--
9-- The Swagger specification defines a set of files required to describe such an API.
4-- The Swagger specification defines a set of files required to describe such an API.
@@ -23,19 +18,10 @@ module Data.Swagger (
23 -- ** Schema specification
18 -- ** Schema specification
24 -- $schema
19 -- $schema
25
20
26− -- ** Manipulation
27− -- $manipulation
28−
29− -- ** Validation
30− -- $validation
31−
32 -- * Re-exports
21 -- * Re-exports
33 module Data.Swagger.Lens,
22 module Data.Swagger.Lens,
34− module Data.Swagger.Optics,
35− module Data.Swagger.Operation,
36 module Data.Swagger.ParamSchema,
23 module Data.Swagger.ParamSchema,
37 module Data.Swagger.Schema,
24 module Data.Swagger.Schema,
38− module Data.Swagger.Schema.Validation,
39
25
40 -- * Swagger specification
26 -- * Swagger specification
41 Swagger(..),
27 Swagger(..),
@@ -77,8 +63,6 @@ module Data.Swagger (
77 NamedSchema(..),
63 NamedSchema(..),
78 SwaggerItems(..),
64 SwaggerItems(..),
79 Xml(..),
65 Xml(..),
80− Pattern,
81− AdditionalProperties(..),
82
66
83 -- ** Responses
67 -- ** Responses
84 Responses(..),
68 Responses(..),
@@ -89,7 +73,6 @@ module Data.Swagger (
89 SecurityScheme(..),
73 SecurityScheme(..),
90 SecuritySchemeType(..),
74 SecuritySchemeType(..),
91 SecurityRequirement(..),
75 SecurityRequirement(..),
92− SecurityDefinitions(..),
93
76
94 -- *** API key
77 -- *** API key
95 ApiKeyParams(..),
78 ApiKeyParams(..),
@@ -114,11 +97,8 @@ module Data.Swagger (
114) where
97) where
115
98
116import Data.Swagger.Lens
99import Data.Swagger.Lens
117−import Data.Swagger.Optics ()
118−import Data.Swagger.Operation
119import Data.Swagger.ParamSchema
100import Data.Swagger.ParamSchema
120import Data.Swagger.Schema
101import Data.Swagger.Schema
121−import Data.Swagger.Schema.Validation
122
102
123import Data.Swagger.Internal
103import Data.Swagger.Internal
124
104
@@ -178,22 +158,20 @@ import Data.Swagger.Internal
178
158
179-- $lens
159-- $lens
180--
160--
181−-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics".
182−--
183-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
161-- 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 comfortably with it. In combination with @'Monoid'@ instances, lenses
185-- make it fairly simple to construct/modify any part of the specification:
163-- make it fairly simple to construct/modify any part of the specification:
186--
164--
187-- >>> :{
165-- >>> :{
188-- encode $ (mempty :: Swagger)
166-- encode $ (mempty :: Swagger)
189−-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
167+-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]
190-- & paths .~
168-- & paths .~
191-- [ ("/user", mempty & get ?~ (mempty
169-- [ ("/user", mempty & get ?~ (mempty
192-- & produces ?~ MimeList ["application/json"]
170-- & produces ?~ MimeList ["application/json"]
193-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))
171-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))
194-- & at 404 ?~ "User info not found")) ]
172-- & at 404 ?~ "User info not found")) ]
195-- :}
173-- :}
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\"]}}}}"
197--
175--
198-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
176-- 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
177-- which produces @application/json@ output. It should respond with code @200@ and body specified
@@ -209,16 +187,16 @@ import Data.Swagger.Internal
209-- "{\"description\":\"No content\"}"
187-- "{\"description\":\"No content\"}"
210-- >>> :{
188-- >>> :{
211-- encode $ (mempty :: Schema)
189-- encode $ (mempty :: Schema)
212−-- & type_ ?~ SwaggerBoolean
190+-- & type_ .~ SwaggerBoolean
213-- & description ?~ "To be or not to be"
191-- & description ?~ "To be or not to be"
214-- :}
192-- :}
215−-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
193+-- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}"
216--
194--
217-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).
195-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).
218-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
196-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
219-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
197-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
220--
198--
221−-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber
199+-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber
222-- "{\"type\":\"number\"}"
200-- "{\"type\":\"number\"}"
223--
201--
224-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
202-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
@@ -236,7 +214,7 @@ import Data.Swagger.Internal
236-- A few other field accessors are modified in this way:
214-- A few other field accessors are modified in this way:
237--
215--
238-- - @'in_'@, @'type_'@, @'default_'@ (as keywords);
216-- - @'in_'@, @'type_'@, @'default_'@ (as keywords);
239−-- - @'maximum_'@, @'minimum_'@, @'head_'@ (as conflicting with @Prelude@);
217+-- - @'maximum_'@ and @'minimum_'@ (as conflicting with @Prelude@);
240-- - @'enum_'@ (as conflicting with @Control.Lens@).
218-- - @'enum_'@ (as conflicting with @Control.Lens@).
241
219
242-- $schema
220-- $schema
@@ -278,73 +256,6 @@ import Data.Swagger.Internal
278-- >>> encode (Person "David" 28)
256-- >>> encode (Person "David" 28)
279-- "{\"age\":28,\"name\":\"David\"}"
257-- "{\"age\":28,\"name\":\"David\"}"
280-- >>> encode $ toSchema (Proxy :: Proxy Person)
258-- >>> encode $ toSchema (Proxy :: Proxy Person)
281−-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
259+-- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}"
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
336--
260--
337
261
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+5−83
@@ -2,33 +2,15 @@
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FunctionalDependencies #-}
3{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE UndecidableInstances #-}
6−-- |
7−-- Module: Data.Swagger.Declare
8−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
9−-- Stability: experimental
10−--
11−-- Declare monad transformer and associated functions.
12module Data.Swagger.Declare where
5module Data.Swagger.Declare where
13
6
14import Prelude ()
7import Prelude ()
15import Prelude.Compat
8import Prelude.Compat
16
9
17import Control.Monad
10import Control.Monad
18−import Control.Monad.Cont (ContT)
19−import Control.Monad.List (ListT)
20−import Control.Monad.Reader (ReaderT)
21import Control.Monad.Trans
11import Control.Monad.Trans
22−import Control.Monad.Trans.Except (ExceptT)
23−import Control.Monad.Trans.Identity (IdentityT)
24−import Control.Monad.Trans.Maybe (MaybeT)
25−import Control.Monad.Trans.State.Lazy as Lazy
26−import Control.Monad.Trans.State.Strict as Strict
27−import Control.Monad.Trans.RWS.Lazy as Lazy
28−import Control.Monad.Trans.RWS.Strict as Strict
29−import Control.Monad.Trans.Writer.Lazy as Lazy
30−import Control.Monad.Trans.Writer.Strict as Strict
31import Data.Functor.Identity
12import Data.Functor.Identity
13+import Data.Monoid
32
14
33-- | A declare monad transformer parametrized by:
15-- | A declare monad transformer parametrized by:
34--
16--
@@ -49,15 +31,15 @@ instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
49 pure x = DeclareT (\_ -> pure (mempty, x))
31 pure x = DeclareT (\_ -> pure (mempty, x))
50 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
32 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
51 ~(d', f) <- df d
33 ~(d', f) <- df d
52− ~(d'', x) <- dx (mappend d d')
34+ ~(d'', x) <- dx (d <> d')
53− return (mappend d' d'', f x)
35+ return (d' <> d'', f x)
54
36
55instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
37instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
56 return x = DeclareT (\_ -> pure (mempty, x))
38 return x = DeclareT (\_ -> pure (mempty, x))
57 DeclareT dx >>= f = DeclareT $ \d -> do
39 DeclareT dx >>= f = DeclareT $ \d -> do
58 ~(d', x) <- dx d
40 ~(d', x) <- dx d
59− ~(d'', y) <- runDeclareT (f x) (mappend d d')
41+ ~(d'', y) <- runDeclareT (f x) (d <> d')
60− return (mappend d' d'', y)
42+ return (d' <> d'', y)
61
43
62instance Monoid d => MonadTrans (DeclareT d) where
44instance Monoid d => MonadTrans (DeclareT d) where
63 lift m = DeclareT (\_ -> (,) mempty `liftM` m)
45 lift m = DeclareT (\_ -> (,) mempty `liftM` m)
@@ -89,13 +71,6 @@ instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) whe
89 declare d = DeclareT (\_ -> return (d, ()))
71 declare d = DeclareT (\_ -> return (d, ()))
90 look = DeclareT (\d -> return (mempty, d))
72 look = DeclareT (\d -> return (mempty, d))
91
73
92−-- | Lift a computation from the simple Declare monad.
93−liftDeclare :: MonadDeclare d m => Declare d a -> m a
94−liftDeclare da = do
95− (d', a) <- looks (runDeclare da)
96− declare d'
97− pure a
98−
99-- | Retrieve a function of all the output so far.
74-- | Retrieve a function of all the output so far.
100looks :: MonadDeclare d m => (d -> a) -> m a
75looks :: MonadDeclare d m => (d -> a) -> m a
101looks f = f <$> look
76looks f = f <$> look
@@ -144,56 +119,3 @@ execDeclare m = runIdentity . execDeclareT m
144undeclare :: Monoid d => Declare d a -> a
119undeclare :: Monoid d => Declare d a -> a
145undeclare = runIdentity . undeclareT
120undeclare = runIdentity . undeclareT
146
121
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+140−379
@@ -1,5 +1,4 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveFunctor #-}
5{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE DeriveGeneric #-}
@@ -12,66 +11,37 @@
12{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE RecordWildCards #-}
13{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
13{-# LANGUAGE StandaloneDeriving #-}
15−{-# LANGUAGE TemplateHaskell #-}
16−{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
18−#if __GLASGOW_HASKELL__ <710
19−{-# LANGUAGE PolyKinds #-}
20−#endif
21#include "overlapping-compat.h"
15#include "overlapping-compat.h"
22module Data.Swagger.Internal where
16module Data.Swagger.Internal where
23
17
24import Prelude ()
18import Prelude ()
25import Prelude.Compat
19import Prelude.Compat
26
20
27−import Control.Lens ((&), (.~), (?~))
28import Control.Applicative
21import Control.Applicative
22+import Control.Monad
29import Data.Aeson
23import Data.Aeson
30import qualified Data.Aeson.Types as JSON
24import qualified Data.Aeson.Types as JSON
31import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
25import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
32−import Data.Hashable (Hashable)
26+import Data.HashMap.Strict (HashMap)
33import qualified Data.HashMap.Strict as HashMap
27import qualified Data.HashMap.Strict as HashMap
34−import Data.HashSet.InsOrd (InsOrdHashSet)
35import Data.Map (Map)
28import Data.Map (Map)
36import qualified Data.Map as Map
29import qualified Data.Map as Map
37−import Data.Monoid (Monoid (..))
30+import Data.Monoid
38−import Data.Semigroup.Compat (Semigroup (..))
39import Data.Scientific (Scientific)
31import Data.Scientific (Scientific)
32+import Data.Set (Set)
40import Data.String (IsString(..))
33import Data.String (IsString(..))
41import Data.Text (Text)
34import Data.Text (Text)
42import qualified Data.Text as Text
35import qualified Data.Text as Text
43import GHC.Generics (Generic)
36import GHC.Generics (Generic)
44−import Network.Socket (HostName, PortNumber)
37+import Network (HostName, PortNumber)
45import Network.HTTP.Media (MediaType)
38import Network.HTTP.Media (MediaType)
46import Text.Read (readMaybe)
39import Text.Read (readMaybe)
47
40
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)
60import Data.Swagger.Internal.Utils
41import Data.Swagger.Internal.Utils
61
42
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−
73-- | A list of definitions that can be used in references.
43-- | A list of definitions that can be used in references.
74−type Definitions = InsOrdHashMap Text
44+type Definitions = HashMap Text
75
45
76-- | This is the root document object for the API specification.
46-- | This is the root document object for the API specification.
77data Swagger = Swagger
47data Swagger = Swagger
@@ -103,7 +73,7 @@ data Swagger = Swagger
103 -- | The available paths and operations for the API.
73 -- | The available paths and operations for the API.
104 -- Holds the relative paths to the individual endpoints.
74 -- Holds the relative paths to the individual endpoints.
105 -- The path is appended to the @'basePath'@ in order to construct the full URL.
75 -- The path is appended to the @'basePath'@ in order to construct the full URL.
106− , _swaggerPaths :: InsOrdHashMap FilePath PathItem
76+ , _swaggerPaths :: HashMap FilePath PathItem
107
77
108 -- | An object to hold data types produced and consumed by operations.
78 -- | An object to hold data types produced and consumed by operations.
109 , _swaggerDefinitions :: Definitions Schema
79 , _swaggerDefinitions :: Definitions Schema
@@ -117,7 +87,7 @@ data Swagger = Swagger
117 , _swaggerResponses :: Definitions Response
87 , _swaggerResponses :: Definitions Response
118
88
119 -- | Security scheme definitions that can be used across the specification.
89 -- | Security scheme definitions that can be used across the specification.
120− , _swaggerSecurityDefinitions :: SecurityDefinitions
90+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme
121
91
122 -- | A declaration of which security schemes are applied for the API as a whole.
92 -- | A declaration of which security schemes are applied for the API as a whole.
123 -- The list of values describes alternative security schemes that can be used
93 -- The list of values describes alternative security schemes that can be used
@@ -130,7 +100,7 @@ data Swagger = Swagger
130 -- Not all tags that are used by the Operation Object must be declared.
100 -- Not all tags that are used by the Operation Object must be declared.
131 -- The tags that are not declared may be organized randomly or based on the tools' logic.
101 -- The tags that are not declared may be organized randomly or based on the tools' logic.
132 -- Each tag name in the list MUST be unique.
102 -- Each tag name in the list MUST be unique.
133− , _swaggerTags :: InsOrdHashSet Tag
103+ , _swaggerTags :: Set Tag
134
104
135 -- | Additional external documentation.
105 -- | Additional external documentation.
136 , _swaggerExternalDocs :: Maybe ExternalDocs
106 , _swaggerExternalDocs :: Maybe ExternalDocs
@@ -252,7 +222,7 @@ data PathItem = PathItem
252data Operation = Operation
222data Operation = Operation
253 { -- | A list of tags for API documentation control.
223 { -- | A list of tags for API documentation control.
254 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
224 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
255− _operationTags :: InsOrdHashSet TagName
225+ _operationTags :: Set TagName
256
226
257 -- | A short summary of what the operation does.
227 -- | A short summary of what the operation does.
258 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
228 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -309,7 +279,7 @@ data Operation = Operation
309 } deriving (Eq, Show, Generic, Data, Typeable)
279 } deriving (Eq, Show, Generic, Data, Typeable)
310
280
311newtype MimeList = MimeList { getMimeList :: [MediaType] }
281newtype MimeList = MimeList { getMimeList :: [MediaType] }
312− deriving (Eq, Show, Semigroup, Monoid, Typeable)
282+ deriving (Eq, Show, Monoid, Typeable)
313
283
314mimeListConstr :: Constr
284mimeListConstr :: Constr
315mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
285mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
@@ -360,8 +330,8 @@ data ParamOtherSchema = ParamOtherSchema
360 -- Default value is @False@.
330 -- Default value is @False@.
361 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
331 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
362
332
363− , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
333+ , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
364− } deriving (Eq, Show, Generic, Typeable, Data)
334+ } deriving (Eq, Show, Generic, Data, Typeable)
365
335
366-- | Items for @'SwaggerArray'@ schemas.
336-- | Items for @'SwaggerArray'@ schemas.
367--
337--
@@ -374,9 +344,9 @@ data ParamOtherSchema = ParamOtherSchema
374--
344--
375-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
345-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
376data SwaggerItems t where
346data SwaggerItems t where
377− SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k
347+ SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t
378− SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema
348+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema
379− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
349+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema
380 deriving (Typeable)
350 deriving (Typeable)
381
351
382deriving instance Eq (SwaggerItems t)
352deriving instance Eq (SwaggerItems t)
@@ -386,66 +356,17 @@ deriving instance Show (SwaggerItems t)
386swaggerItemsPrimitiveConstr :: Constr
356swaggerItemsPrimitiveConstr :: Constr
387swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
357swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
388
358
389−swaggerItemsObjectConstr :: Constr
390−swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix
391−
392−swaggerItemsArrayConstr :: Constr
393−swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix
394−
395swaggerItemsDataType :: DataType
359swaggerItemsDataType :: DataType
396swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
360swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
397
361
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
362+instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where
402− -- TODO: define gfoldl
403 gunfold k z c = case constrIndex c of
363 gunfold k z c = case constrIndex c of
404 1 -> k (k (z SwaggerItemsPrimitive))
364 1 -> k (k (z SwaggerItemsPrimitive))
405 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
365 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
406 toConstr _ = swaggerItemsPrimitiveConstr
366 toConstr _ = swaggerItemsPrimitiveConstr
407 dataTypeOf _ = swaggerItemsDataType
367 dataTypeOf _ = swaggerItemsDataType
408
368
409−-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only
410−instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where
369+deriving instance Data (SwaggerItems Schema)
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
449
370
450data SwaggerType t where
371data SwaggerType t where
451 SwaggerString :: SwaggerType t
372 SwaggerString :: SwaggerType t
@@ -453,9 +374,9 @@ data SwaggerType t where
453 SwaggerInteger :: SwaggerType t
374 SwaggerInteger :: SwaggerType t
454 SwaggerBoolean :: SwaggerType t
375 SwaggerBoolean :: SwaggerType t
455 SwaggerArray :: SwaggerType t
376 SwaggerArray :: SwaggerType t
456− SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema
377+ SwaggerFile :: SwaggerType ParamOtherSchema
457− SwaggerNull :: SwaggerType 'SwaggerKindSchema
378+ SwaggerNull :: SwaggerType Schema
458− SwaggerObject :: SwaggerType 'SwaggerKindSchema
379+ SwaggerObject :: SwaggerType Schema
459 deriving (Typeable)
380 deriving (Typeable)
460
381
461deriving instance Eq (SwaggerType t)
382deriving instance Eq (SwaggerType t)
@@ -464,33 +385,33 @@ deriving instance Show (SwaggerType t)
464swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
385swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
465swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
386swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
466
387
467−swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType
388+swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
468swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
389swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
469
390
470−swaggerCommonTypes :: [SwaggerType k]
391+swaggerCommonTypes :: [SwaggerType t]
471swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
392swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
472
393
473−swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]
394+swaggerParamTypes :: [SwaggerType ParamOtherSchema]
474swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
395swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
475
396
476−swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]
397+swaggerSchemaTypes :: [SwaggerType Schema]
477swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
398swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
478
399
479swaggerTypeConstrs :: [Constr]
400swaggerTypeConstrs :: [Constr]
480−swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema])
401+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])
481 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
402 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
482
403
483−instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where
404+instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where
484 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
405 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
485 toConstr = swaggerTypeConstr
406 toConstr = swaggerTypeConstr
486 dataTypeOf = swaggerTypeDataType
407 dataTypeOf = swaggerTypeDataType
487
408
488−instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where
409+instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where
489 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
410 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
490 toConstr = swaggerTypeConstr
411 toConstr = swaggerTypeConstr
491 dataTypeOf = swaggerTypeDataType
412 dataTypeOf = swaggerTypeDataType
492
413
493−instance Data (SwaggerType 'SwaggerKindSchema) where
414+instance OVERLAPPABLE_ Data (SwaggerType Schema) where
494 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
415 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
495 toConstr = swaggerTypeConstr
416 toConstr = swaggerTypeConstr
496 dataTypeOf = swaggerTypeDataType
417 dataTypeOf = swaggerTypeDataType
@@ -530,7 +451,7 @@ data CollectionFormat t where
530 -- Corresponds to multiple parameter instances
451 -- Corresponds to multiple parameter instances
531 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
452 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
532 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
453 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
533− CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema
454+ CollectionMulti :: CollectionFormat ParamOtherSchema
534 deriving (Typeable)
455 deriving (Typeable)
535
456
536deriving instance Eq (CollectionFormat t)
457deriving instance Eq (CollectionFormat t)
@@ -546,12 +467,12 @@ collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
546collectionCommonFormats :: [CollectionFormat t]
467collectionCommonFormats :: [CollectionFormat t]
547collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
468collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
548
469
549−instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where
470+instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where
550 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
471 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
551 toConstr = collectionFormatConstr
472 toConstr = collectionFormatConstr
552 dataTypeOf _ = collectionFormatDataType
473 dataTypeOf _ = collectionFormatDataType
553
474
554−deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)
475+deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)
555
476
556type ParamName = Text
477type ParamName = Text
557
478
@@ -560,9 +481,9 @@ data Schema = Schema
560 , _schemaDescription :: Maybe Text
481 , _schemaDescription :: Maybe Text
561 , _schemaRequired :: [ParamName]
482 , _schemaRequired :: [ParamName]
562
483
563− , _schemaAllOf :: Maybe [Referenced Schema]
484+ , _schemaAllOf :: Maybe [Schema]
564− , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
485+ , _schemaProperties :: HashMap Text (Referenced Schema)
565− , _schemaAdditionalProperties :: Maybe AdditionalProperties
486+ , _schemaAdditionalProperties :: Maybe Schema
566
487
567 , _schemaDiscriminator :: Maybe Text
488 , _schemaDiscriminator :: Maybe Text
568 , _schemaReadOnly :: Maybe Bool
489 , _schemaReadOnly :: Maybe Bool
@@ -573,7 +494,7 @@ data Schema = Schema
573 , _schemaMaxProperties :: Maybe Integer
494 , _schemaMaxProperties :: Maybe Integer
574 , _schemaMinProperties :: Maybe Integer
495 , _schemaMinProperties :: Maybe Integer
575
496
576− , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema
497+ , _schemaParamSchema :: ParamSchema Schema
577 } deriving (Eq, Show, Generic, Data, Typeable)
498 } deriving (Eq, Show, Generic, Data, Typeable)
578
499
579-- | A @'Schema'@ with an optional name.
500-- | A @'Schema'@ with an optional name.
@@ -586,7 +507,7 @@ data NamedSchema = NamedSchema
586-- | Regex pattern for @string@ type.
507-- | Regex pattern for @string@ type.
587type Pattern = Text
508type Pattern = Text
588
509
589−data ParamSchema (t :: SwaggerKind *) = ParamSchema
510+data ParamSchema t = ParamSchema
590 { -- | Declares the value of the parameter that the server will use if none is provided,
511 { -- | Declares the value of the parameter that the server will use if none is provided,
591 -- for example a @"count"@ to control the number of results per page might default to @100@
512 -- for example a @"count"@ to control the number of results per page might default to @100@
592 -- if not supplied by the client in the request.
513 -- if not supplied by the client in the request.
@@ -594,7 +515,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
594 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
515 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
595 _paramSchemaDefault :: Maybe Value
516 _paramSchemaDefault :: Maybe Value
596
517
597− , _paramSchemaType :: Maybe (SwaggerType t)
518+ , _paramSchemaType :: SwaggerType t
598 , _paramSchemaFormat :: Maybe Format
519 , _paramSchemaFormat :: Maybe Format
599 , _paramSchemaItems :: Maybe (SwaggerItems t)
520 , _paramSchemaItems :: Maybe (SwaggerItems t)
600 , _paramSchemaMaximum :: Maybe Scientific
521 , _paramSchemaMaximum :: Maybe Scientific
@@ -611,7 +532,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
611 , _paramSchemaMultipleOf :: Maybe Scientific
532 , _paramSchemaMultipleOf :: Maybe Scientific
612 } deriving (Eq, Show, Generic, Typeable)
533 } deriving (Eq, Show, Generic, Typeable)
613
534
614−deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)
535+deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)
615
536
616data Xml = Xml
537data Xml = Xml
617 { -- | Replaces the name of the element/attribute used for the described schema property.
538 { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -653,7 +574,7 @@ data Responses = Responses
653
574
654 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
575 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
655 -- Describes the expected response for those HTTP status codes.
576 -- Describes the expected response for those HTTP status codes.
656− , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)
577+ , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
657 } deriving (Eq, Show, Generic, Data, Typeable)
578 } deriving (Eq, Show, Generic, Data, Typeable)
658
579
659type HttpStatusCode = Int
580type HttpStatusCode = Int
@@ -672,7 +593,7 @@ data Response = Response
672 , _responseSchema :: Maybe (Referenced Schema)
593 , _responseSchema :: Maybe (Referenced Schema)
673
594
674 -- | A list of headers that are sent with the response.
595 -- | A list of headers that are sent with the response.
675− , _responseHeaders :: InsOrdHashMap HeaderName Header
596+ , _responseHeaders :: HashMap HeaderName Header
676
597
677 -- | An example of the response message.
598 -- | An example of the response message.
678 , _responseExamples :: Maybe Example
599 , _responseExamples :: Maybe Example
@@ -687,7 +608,7 @@ data Header = Header
687 { -- | A short description of the header.
608 { -- | A short description of the header.
688 _headerDescription :: Maybe Text
609 _headerDescription :: Maybe Text
689
610
690− , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)
611+ , _headerParamSchema :: ParamSchema Header
691 } deriving (Eq, Show, Generic, Data, Typeable)
612 } deriving (Eq, Show, Generic, Data, Typeable)
692
613
693data Example = Example { getExample :: Map MediaType Value }
614data Example = Example { getExample :: Map MediaType Value }
@@ -738,7 +659,7 @@ data OAuth2Params = OAuth2Params
738 _oauth2Flow :: OAuth2Flow
659 _oauth2Flow :: OAuth2Flow
739
660
740 -- | The available scopes for the OAuth2 security scheme.
661 -- | The available scopes for the OAuth2 security scheme.
741− , _oauth2Scopes :: InsOrdHashMap Text Text
662+ , _oauth2Scopes :: HashMap Text Text
742 } deriving (Eq, Show, Generic, Data, Typeable)
663 } deriving (Eq, Show, Generic, Data, Typeable)
743
664
744data SecuritySchemeType
665data SecuritySchemeType
@@ -755,28 +676,12 @@ data SecurityScheme = SecurityScheme
755 , _securitySchemeDescription :: Maybe Text
676 , _securitySchemeDescription :: Maybe Text
756 } deriving (Eq, Show, Generic, Data, Typeable)
677 } deriving (Eq, Show, Generic, Data, Typeable)
757
678
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−
774-- | Lists the required security schemes to execute this operation.
679-- | Lists the required security schemes to execute this operation.
775-- The object can have multiple security schemes declared in it which are all required
680-- The object can have multiple security schemes declared in it which are all required
776-- (that is, there is a logical AND between the schemes).
681-- (that is, there is a logical AND between the schemes).
777newtype SecurityRequirement = SecurityRequirement
682newtype SecurityRequirement = SecurityRequirement
778− { getSecurityRequirement :: InsOrdHashMap Text [Text]
683+ { getSecurityRequirement :: HashMap Text [Text]
779− } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
684+ } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
780
685
781-- | Tag name.
686-- | Tag name.
782type TagName = Text
687type TagName = Text
@@ -795,8 +700,6 @@ data Tag = Tag
795 , _tagExternalDocs :: Maybe ExternalDocs
700 , _tagExternalDocs :: Maybe ExternalDocs
796 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
701 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
797
702
798−instance Hashable Tag
799−
800instance IsString Tag where
703instance IsString Tag where
801 fromString s = Tag (fromString s) Nothing Nothing
704 fromString s = Tag (fromString s) Nothing Nothing
802
705
@@ -810,8 +713,6 @@ data ExternalDocs = ExternalDocs
810 , _externalDocsUrl :: URL
713 , _externalDocsUrl :: URL
811 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
714 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
812
715
813−instance Hashable ExternalDocs
814−
815-- | A simple object to allow referencing other definitions in the specification.
716-- | A simple object to allow referencing other definitions in the specification.
816-- It can be used to reference parameters and responses that are defined at the top level for reuse.
717-- It can be used to reference parameters and responses that are defined at the top level for reuse.
817newtype Reference = Reference { getReference :: Text }
718newtype Reference = Reference { getReference :: Text }
@@ -825,111 +726,67 @@ data Referenced a
825instance IsString a => IsString (Referenced a) where
726instance IsString a => IsString (Referenced a) where
826 fromString = Inline . fromString
727 fromString = Inline . fromString
827
728
828−newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable)
729+newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)
829−
830−data AdditionalProperties
831− = AdditionalPropertiesAllowed Bool
832− | AdditionalPropertiesSchema (Referenced Schema)
833− deriving (Eq, Show, Data, Typeable)
834
730
835-- =======================================================================
731-- =======================================================================
836-- Monoid instances
732-- Monoid instances
837-- =======================================================================
733-- =======================================================================
838
734
839−instance Semigroup Swagger where
840− (<>) = genericMappend
841instance Monoid Swagger where
735instance Monoid Swagger where
842 mempty = genericMempty
736 mempty = genericMempty
843− mappend = (<>)
737+ mappend = genericMappend
844
738
845−instance Semigroup Info where
846− (<>) = genericMappend
847instance Monoid Info where
739instance Monoid Info where
848 mempty = genericMempty
740 mempty = genericMempty
849− mappend = (<>)
741+ mappend = genericMappend
850
742
851−instance Semigroup Contact where
852− (<>) = genericMappend
853instance Monoid Contact where
743instance Monoid Contact where
854 mempty = genericMempty
744 mempty = genericMempty
855− mappend = (<>)
745+ mappend = genericMappend
856
746
857−instance Semigroup PathItem where
858− (<>) = genericMappend
859instance Monoid PathItem where
747instance Monoid PathItem where
860 mempty = genericMempty
748 mempty = genericMempty
861− mappend = (<>)
749+ mappend = genericMappend
862
750
863−instance Semigroup Schema where
864− (<>) = genericMappend
865instance Monoid Schema where
751instance Monoid Schema where
866 mempty = genericMempty
752 mempty = genericMempty
867− mappend = (<>)
753+ mappend = genericMappend
868
754
869−instance Semigroup (ParamSchema t) where
870− (<>) = genericMappend
871instance Monoid (ParamSchema t) where
755instance Monoid (ParamSchema t) where
872 mempty = genericMempty
756 mempty = genericMempty
873− mappend = (<>)
757+ mappend = genericMappend
874
758
875−instance Semigroup Param where
876− (<>) = genericMappend
877instance Monoid Param where
759instance Monoid Param where
878 mempty = genericMempty
760 mempty = genericMempty
879− mappend = (<>)
761+ mappend = genericMappend
880
762
881−instance Semigroup ParamOtherSchema where
882− (<>) = genericMappend
883instance Monoid ParamOtherSchema where
763instance Monoid ParamOtherSchema where
884 mempty = genericMempty
764 mempty = genericMempty
885− mappend = (<>)
765+ mappend = genericMappend
886
766
887−instance Semigroup Header where
888− (<>) = genericMappend
889instance Monoid Header where
767instance Monoid Header where
890 mempty = genericMempty
768 mempty = genericMempty
891− mappend = (<>)
769+ mappend = genericMappend
892
770
893−instance Semigroup Responses where
894− (<>) = genericMappend
895instance Monoid Responses where
771instance Monoid Responses where
896 mempty = genericMempty
772 mempty = genericMempty
897− mappend = (<>)
773+ mappend = genericMappend
898
774
899−instance Semigroup Response where
900− (<>) = genericMappend
901instance Monoid Response where
775instance Monoid Response where
902 mempty = genericMempty
776 mempty = genericMempty
903− mappend = (<>)
777+ mappend = genericMappend
904
778
905−instance Semigroup ExternalDocs where
906− (<>) = genericMappend
907instance Monoid ExternalDocs where
779instance Monoid ExternalDocs where
908 mempty = genericMempty
780 mempty = genericMempty
909− mappend = (<>)
781+ mappend = genericMappend
910
782
911−instance Semigroup Operation where
912− (<>) = genericMappend
913instance Monoid Operation where
783instance Monoid Operation where
914 mempty = genericMempty
784 mempty = genericMempty
915− mappend = (<>)
785+ mappend = genericMappend
916
786
917−instance Semigroup Example where
918− (<>) = genericMappend
919instance Monoid Example where
787instance Monoid Example where
920 mempty = genericMempty
788 mempty = genericMempty
921− mappend = (<>)
789+ mappend = genericMappend
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 = (<>)
933
790
934-- =======================================================================
791-- =======================================================================
935-- SwaggerMonoid helper instances
792-- SwaggerMonoid helper instances
@@ -945,8 +802,6 @@ instance SwaggerMonoid Responses
945instance SwaggerMonoid Response
802instance SwaggerMonoid Response
946instance SwaggerMonoid ExternalDocs
803instance SwaggerMonoid ExternalDocs
947instance SwaggerMonoid Operation
804instance SwaggerMonoid Operation
948−instance SwaggerMonoid SecurityDefinitions
949−instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
950
805
951instance SwaggerMonoid MimeList
806instance SwaggerMonoid MimeList
952deriving instance SwaggerMonoid URL
807deriving instance SwaggerMonoid URL
@@ -959,13 +814,13 @@ instance SwaggerMonoid ParamLocation where
959 swaggerMempty = ParamQuery
814 swaggerMempty = ParamQuery
960 swaggerMappend _ y = y
815 swaggerMappend _ y = y
961
816
962−instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
817+instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where
963− swaggerMempty = InsOrdHashMap.empty
818+ swaggerMempty = HashMap.empty
964− swaggerMappend = InsOrdHashMap.unionWith mappend
819+ swaggerMappend = HashMap.unionWith mappend
965
820
966instance Monoid a => SwaggerMonoid (Referenced a) where
821instance Monoid a => SwaggerMonoid (Referenced a) where
967 swaggerMempty = Inline mempty
822 swaggerMempty = Inline mempty
968− swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
823+ swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
969 swaggerMappend _ y = y
824 swaggerMappend _ y = y
970
825
971instance SwaggerMonoid ParamAnySchema where
826instance SwaggerMonoid ParamAnySchema where
@@ -1059,8 +914,7 @@ instance ToJSON OAuth2Flow where
1059 , "tokenUrl" .= tokenUrl ]
914 , "tokenUrl" .= tokenUrl ]
1060
915
1061instance ToJSON OAuth2Params where
916instance ToJSON OAuth2Params where
1062− toJSON = sopSwaggerGenericToJSON
917+ toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")
1063− DEFINE_TOENCODING
1064
918
1065instance ToJSON SecuritySchemeType where
919instance ToJSON SecuritySchemeType where
1066 toJSON SecuritySchemeBasic
920 toJSON SecuritySchemeBasic
@@ -1073,37 +927,28 @@ instance ToJSON SecuritySchemeType where
1073 <+> object [ "type" .= ("oauth2" :: Text) ]
927 <+> object [ "type" .= ("oauth2" :: Text) ]
1074
928
1075instance ToJSON Swagger where
929instance ToJSON Swagger where
1076− toJSON = sopSwaggerGenericToJSON
930+ toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")
1077− DEFINE_TOENCODING
931+ where
932+ addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
933+ addVersion _ = error "impossible"
1078
934
1079instance ToJSON SecurityScheme where
935instance ToJSON SecurityScheme where
1080− toJSON = sopSwaggerGenericToJSON
936+ toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
1081− DEFINE_TOENCODING
1082
937
1083instance ToJSON Schema where
938instance ToJSON Schema where
1084− toJSON = sopSwaggerGenericToJSON
939+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
1085− DEFINE_TOENCODING
940+ where
941+ f "items" (Array _) = True
942+ f _ _ = False
1086
943
1087instance ToJSON Header where
944instance ToJSON Header where
1088− toJSON = sopSwaggerGenericToJSON
945+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
1089− DEFINE_TOENCODING
1090
946
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
947+instance ToJSON (SwaggerItems t) where
1098 toJSON (SwaggerItemsPrimitive fmt schema) = object
948 toJSON (SwaggerItemsPrimitive fmt schema) = object
1099 [ "collectionFormat" .= fmt
949 [ "collectionFormat" .= fmt
1100 , "items" .= schema ]
950 , "items" .= schema ]
1101 toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
951 toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1102− toJSON (SwaggerItemsArray []) = object
1103− [ "items" .= object []
1104− , "maxItems" .= (0 :: Int)
1105− , "example" .= Array mempty
1106− ]
1107 toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
952 toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
1108
953
1109instance ToJSON Host where
954instance ToJSON Host where
@@ -1116,39 +961,31 @@ instance ToJSON MimeList where
1116 toJSON (MimeList xs) = toJSON (map show xs)
961 toJSON (MimeList xs) = toJSON (map show xs)
1117
962
1118instance ToJSON Param where
963instance ToJSON Param where
1119− toJSON = sopSwaggerGenericToJSON
964+ toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
1120− DEFINE_TOENCODING
1121
965
1122instance ToJSON ParamAnySchema where
966instance ToJSON ParamAnySchema where
1123 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
967 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
1124 toJSON (ParamOther s) = toJSON s
968 toJSON (ParamOther s) = toJSON s
1125
969
1126instance ToJSON ParamOtherSchema where
970instance ToJSON ParamOtherSchema where
1127− toJSON = sopSwaggerGenericToJSON
971+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1128− DEFINE_TOENCODING
1129
972
1130instance ToJSON Responses where
973instance ToJSON Responses where
1131− toJSON = sopSwaggerGenericToJSON
974+ toJSON (Responses def rs) = omitEmpties $
1132− DEFINE_TOENCODING
975+ toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
1133
976
1134instance ToJSON Response where
977instance ToJSON Response where
1135− toJSON = sopSwaggerGenericToJSON
978+ toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
1136− DEFINE_TOENCODING
1137
979
1138instance ToJSON Operation where
980instance ToJSON Operation where
1139− toJSON = sopSwaggerGenericToJSON
981+ toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")
1140− DEFINE_TOENCODING
1141
982
1142instance ToJSON PathItem where
983instance ToJSON PathItem where
1143− toJSON = sopSwaggerGenericToJSON
984+ toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")
1144− DEFINE_TOENCODING
1145
985
1146instance ToJSON Example where
986instance ToJSON Example where
1147 toJSON = toJSON . Map.mapKeys show . getExample
987 toJSON = toJSON . Map.mapKeys show . getExample
1148
988
1149−instance ToJSON SecurityDefinitions where
1150− toJSON (SecurityDefinitions sd) = toJSON sd
1151−
1152instance ToJSON Reference where
989instance ToJSON Reference where
1153 toJSON (Reference ref) = object [ "$ref" .= ref ]
990 toJSON (Reference ref) = object [ "$ref" .= ref ]
1154
991
@@ -1177,14 +1014,11 @@ instance ToJSON (CollectionFormat t) where
1177 toJSON CollectionPipes = "pipes"
1014 toJSON CollectionPipes = "pipes"
1178 toJSON CollectionMulti = "multi"
1015 toJSON CollectionMulti = "multi"
1179
1016
1180−instance ToJSON (ParamSchema k) where
1017+instance ToJSON (ParamSchema t) where
1181− -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`?
1018+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
1182− toJSON = sopSwaggerGenericToJSONWithOpts $
1019+ where
1183− mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1020+ f "items" (Array _) = True
1184−
1021+ f _ _ = False
1185−instance ToJSON AdditionalProperties where
1186− toJSON (AdditionalPropertiesAllowed b) = toJSON b
1187− toJSON (AdditionalPropertiesSchema s) = toJSON s
1188
1022
1189-- =======================================================================
1023-- =======================================================================
1190-- Manual FromJSON instances
1024-- Manual FromJSON instances
@@ -1204,7 +1038,7 @@ instance FromJSON OAuth2Flow where
1204 parseJSON _ = empty
1038 parseJSON _ = empty
1205
1039
1206instance FromJSON OAuth2Params where
1040instance FromJSON OAuth2Params where
1207− parseJSON = sopSwaggerGenericParseJSON
1041+ parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
1208
1042
1209instance FromJSON SecuritySchemeType where
1043instance FromJSON SecuritySchemeType where
1210 parseJSON js@(Object o) = do
1044 parseJSON js@(Object o) = do
@@ -1217,65 +1051,57 @@ instance FromJSON SecuritySchemeType where
1217 parseJSON _ = empty
1051 parseJSON _ = empty
1218
1052
1219instance FromJSON Swagger where
1053instance FromJSON Swagger where
1220− parseJSON = sopSwaggerGenericParseJSON
1054+ parseJSON js@(Object o) = do
1055+ (version :: Text) <- o .: "swagger"
1056+ when (version /= "2.0") empty
1057+ (genericParseJSON (jsonPrefix "swagger")
1058+ `withDefaults` [ "consumes" .= (mempty :: MimeList)
1059+ , "produces" .= (mempty :: MimeList)
1060+ , "security" .= ([] :: [SecurityRequirement])
1061+ , "tags" .= ([] :: [Tag])
1062+ , "definitions" .= (mempty :: Definitions Schema)
1063+ , "parameters" .= (mempty :: Definitions Param)
1064+ , "responses" .= (mempty :: Definitions Response)
1065+ , "securityDefinitions" .= (mempty :: Definitions SecurityScheme)
1066+ ] ) js
1067+ parseJSON _ = empty
1221
1068
1222instance FromJSON SecurityScheme where
1069instance FromJSON SecurityScheme where
1223− parseJSON = sopSwaggerGenericParseJSON
1070+ parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
1224
1071
1225instance FromJSON Schema where
1072instance FromJSON Schema where
1226− parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
1073+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
1227− where nullaryCleanup :: Schema -> Schema
1074+ `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
1228− nullaryCleanup s@Schema{_schemaParamSchema=ps} =
1075+ , "required" .= ([] :: [ParamName]) ]
1229− if _paramSchemaItems ps == Just (SwaggerItemsArray [])
1230− then s { _schemaExample = Nothing
1231− , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } }
1232− else s
1233
1076
1234instance FromJSON Header where
1077instance FromJSON Header where
1235− parseJSON = sopSwaggerGenericParseJSON
1078+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
1236
1079
1237−instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where
1080+instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where
1238 parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1081 parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1239 <$> o .:? "collectionFormat"
1082 <$> o .:? "collectionFormat"
1240 <*> (o .: "items" >>= parseJSON)
1083 <*> (o .: "items" >>= parseJSON)
1241
1084
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
1085+instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where
1259− parseJSON js@(Object obj)
1260− | null obj = pure $ SwaggerItemsArray [] -- Nullary schema.
1261− | otherwise = SwaggerItemsObject <$> parseJSON js
1086+ parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
1262 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1087 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1263 parseJSON _ = empty
1088 parseJSON _ = empty
1264
1089
1265instance FromJSON Host where
1090instance FromJSON Host where
1266− parseJSON (String s) = case map Text.unpack $ Text.split (== ':') s of
1091+ parseJSON (String s) =
1267− [host] -> return $ Host host Nothing
1092+ case fromInteger <$> readMaybe portStr of
1268− [host, port] -> case readMaybe port of
1093+ Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'"
1269− Nothing -> fail $ "Invalid port `" ++ port ++ "'"
1094+ mport -> pure $ Host host mport
1270− Just p -> return $ Host host (Just (fromInteger p))
1095+ where
1271− _ -> fail $ "Invalid host `" ++ Text.unpack s ++ "'"
1096+ (hostText, portText) = Text.breakOn ":" s
1097+ [host, portStr] = map Text.unpack [hostText, portText]
1272 parseJSON _ = empty
1098 parseJSON _ = empty
1273
1099
1274instance FromJSON MimeList where
1100instance FromJSON MimeList where
1275 parseJSON js = (MimeList . map fromString) <$> parseJSON js
1101 parseJSON js = (MimeList . map fromString) <$> parseJSON js
1276
1102
1277instance FromJSON Param where
1103instance FromJSON Param where
1278− parseJSON = sopSwaggerGenericParseJSON
1104+ parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
1279
1105
1280instance FromJSON ParamAnySchema where
1106instance FromJSON ParamAnySchema where
1281 parseJSON js@(Object o) = do
1107 parseJSON js@(Object o) = do
@@ -1288,12 +1114,12 @@ instance FromJSON ParamAnySchema where
1288 parseJSON _ = empty
1114 parseJSON _ = empty
1289
1115
1290instance FromJSON ParamOtherSchema where
1116instance FromJSON ParamOtherSchema where
1291− parseJSON = sopSwaggerGenericParseJSON
1117+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1292
1118
1293instance FromJSON Responses where
1119instance FromJSON Responses where
1294 parseJSON (Object o) = Responses
1120 parseJSON (Object o) = Responses
1295 <$> o .:? "default"
1121 <$> o .:? "default"
1296− <*> (parseJSON (Object (HashMap.delete "default" o)))
1122+ <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
1297 parseJSON _ = empty
1123 parseJSON _ = empty
1298
1124
1299instance FromJSON Example where
1125instance FromJSON Example where
@@ -1302,16 +1128,16 @@ instance FromJSON Example where
1302 pure $ Example (Map.mapKeys fromString m)
1128 pure $ Example (Map.mapKeys fromString m)
1303
1129
1304instance FromJSON Response where
1130instance FromJSON Response where
1305− parseJSON = sopSwaggerGenericParseJSON
1131+ parseJSON = genericParseJSON (jsonPrefix "response")
1132+ `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
1306
1133
1307instance FromJSON Operation where
1134instance FromJSON Operation where
1308− parseJSON = sopSwaggerGenericParseJSON
1135+ parseJSON = genericParseJSON (jsonPrefix "operation")
1136+ `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) ]
1309
1137
1310instance FromJSON PathItem where
1138instance FromJSON PathItem where
1311− parseJSON = sopSwaggerGenericParseJSON
1139+ parseJSON = genericParseJSON (jsonPrefix "pathItem")
1312−
1140+ `withDefaults` [ "parameters" .= ([] :: [Param]) ]
1313−instance FromJSON SecurityDefinitions where
1314− parseJSON js = SecurityDefinitions <$> parseJSON js
1315
1141
1316instance FromJSON Reference where
1142instance FromJSON Reference where
1317 parseJSON (Object o) = Reference <$> o .: "$ref"
1143 parseJSON (Object o) = Reference <$> o .: "$ref"
@@ -1337,91 +1163,26 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#
1337instance FromJSON Xml where
1163instance FromJSON Xml where
1338 parseJSON = genericParseJSON (jsonPrefix "xml")
1164 parseJSON = genericParseJSON (jsonPrefix "xml")
1339
1165
1340−instance FromJSON (SwaggerType 'SwaggerKindSchema) where
1166+instance FromJSON (SwaggerType Schema) where
1341 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1167 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1342
1168
1343−instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where
1169+instance FromJSON (SwaggerType ParamOtherSchema) where
1344 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1170 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1345
1171
1346−instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where
1172+instance OVERLAPPABLE_ FromJSON (SwaggerType t) where
1347 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1173 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1348
1174
1349−instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where
1175+instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where
1350 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1176 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1351
1177
1352−-- NOTE: There aren't collections of 'Schema'
1353−--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where
1178+instance FromJSON (CollectionFormat ParamOtherSchema) where
1354−-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1355−
1356−instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where
1357 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1179 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1358
1180
1359−instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where
1181+-- NOTE: The constraints @FromJSON (SwaggerType t)@ and
1360− parseJSON = sopSwaggerGenericParseJSON
1182+-- @FromJSON (SwaggerItems t)@ are necessary here!
1361−instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where
1183+-- Without the constraint the general instance will be used
1362− parseJSON = sopSwaggerGenericParseJSON
1184+-- that only accepts common types (i.e. NOT object, null or file)
1363−instance FromJSON (ParamSchema 'SwaggerKindSchema) where
1185+-- and primitive array items.
1364− parseJSON = sopSwaggerGenericParseJSON
1186+instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
1365−
1187+ parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
1366−instance FromJSON AdditionalProperties where
1188+
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
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+26−95
@@ -1,5 +1,4 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
@@ -8,21 +7,13 @@
8{-# LANGUAGE PackageImports #-}
7{-# LANGUAGE PackageImports #-}
9{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE TypeSynonymInstances #-}
11{-# 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"
12#include "overlapping-compat.h"
22module Data.Swagger.Internal.ParamSchema where
13module Data.Swagger.Internal.ParamSchema where
23
14
24import Control.Lens
15import Control.Lens
25−import Data.Aeson (ToJSON (..))
16+import Data.Aeson
26import Data.Proxy
17import Data.Proxy
27import GHC.Generics
18import GHC.Generics
28
19
@@ -31,7 +22,6 @@ import "unordered-containers" Data.HashSet (HashSet)
31import Data.Monoid
22import Data.Monoid
32import Data.Set (Set)
23import Data.Set (Set)
33import Data.Scientific
24import Data.Scientific
34−import Data.Fixed (HasResolution(..), Fixed, Pico)
35import qualified Data.Text as T
25import qualified Data.Text as T
36import qualified Data.Text.Lazy as TL
26import qualified Data.Text.Lazy as TL
37import Data.Time
27import Data.Time
@@ -39,40 +29,29 @@ import qualified Data.Vector as V
39import qualified Data.Vector.Primitive as VP
29import qualified Data.Vector.Primitive as VP
40import qualified Data.Vector.Storable as VS
30import qualified Data.Vector.Storable as VS
41import qualified Data.Vector.Unboxed as VU
31import qualified Data.Vector.Unboxed as VU
42−import Data.Version (Version)
43−import Numeric.Natural.Compat (Natural)
44import Data.Word
32import Data.Word
45−import Data.UUID.Types (UUID)
46−import Web.Cookie (SetCookie)
47
33
48import Data.Swagger.Internal
34import Data.Swagger.Internal
49import Data.Swagger.Lens
35import Data.Swagger.Lens
50import Data.Swagger.SchemaOptions
36import Data.Swagger.SchemaOptions
51
37
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).
38-- | Default schema for binary data (any sequence of octets).
60binaryParamSchema :: ParamSchema t
39binaryParamSchema :: ParamSchema t
61binaryParamSchema = mempty
40binaryParamSchema = mempty
62− & type_ ?~ SwaggerString
41+ & type_ .~ SwaggerString
63 & format ?~ "binary"
42 & format ?~ "binary"
64
43
65-- | Default schema for binary data (base64 encoded).
44-- | Default schema for binary data (base64 encoded).
66byteParamSchema :: ParamSchema t
45byteParamSchema :: ParamSchema t
67byteParamSchema = mempty
46byteParamSchema = mempty
68− & type_ ?~ SwaggerString
47+ & type_ .~ SwaggerString
69 & format ?~ "byte"
48 & format ?~ "byte"
70
49
71-- | Default schema for password string.
50-- | Default schema for password string.
72-- @"password"@ format is used to hint UIs the input needs to be obscured.
51-- @"password"@ format is used to hint UIs the input needs to be obscured.
73passwordParamSchema :: ParamSchema t
52passwordParamSchema :: ParamSchema t
74passwordParamSchema = mempty
53passwordParamSchema = mempty
75− & type_ ?~ SwaggerString
54+ & type_ .~ SwaggerString
76 & format ?~ "password"
55 & format ?~ "password"
77
56
78-- | Convert a type into a plain @'ParamSchema'@.
57-- | Convert a type into a plain @'ParamSchema'@.
@@ -87,9 +66,9 @@ passwordParamSchema = mempty
87-- data Direction = Up | Down
66-- data Direction = Up | Down
88--
67--
89-- instance ToParamSchema Direction where
68-- instance ToParamSchema Direction where
90−-- toParamSchema _ = mempty
69+-- toParamSchema = mempty
91−-- & type_ ?~ SwaggerString
70+-- & type_ .~ SwaggerString
92−-- & enum_ ?~ [ \"Up\", \"Down\" ]
71+-- & enum_ .~ [ \"Up\", \"Down\" ]
93-- @
72-- @
94--
73--
95-- Instead of manually writing your @'ToParamSchema'@ instance you can
74-- Instead of manually writing your @'ToParamSchema'@ instance you can
@@ -115,24 +94,18 @@ class ToParamSchema a where
115 --
94 --
116 -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
95 -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
117 -- "{\"type\":\"integer\"}"
96 -- "{\"type\":\"integer\"}"
118− toParamSchema :: Proxy a -> ParamSchema t
97+ toParamSchema :: proxy a -> ParamSchema t
119− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t
98+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t
120 toParamSchema = genericToParamSchema defaultSchemaOptions
99 toParamSchema = genericToParamSchema defaultSchemaOptions
121
100
122instance OVERLAPPING_ ToParamSchema String where
101instance OVERLAPPING_ ToParamSchema String where
123− toParamSchema _ = mempty & type_ ?~ SwaggerString
102+ toParamSchema _ = mempty & type_ .~ SwaggerString
124
103
125instance ToParamSchema Bool where
104instance ToParamSchema Bool where
126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
105+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean
127
106
128instance ToParamSchema Integer where
107instance ToParamSchema Integer where
129− toParamSchema _ = mempty & type_ ?~ SwaggerInteger
108+ toParamSchema _ = mempty & type_ .~ SwaggerInteger
130−
131−instance ToParamSchema Natural where
132− toParamSchema _ = mempty
133− & type_ ?~ SwaggerInteger
134− & minimum_ ?~ 0
135− & exclusiveMinimum ?~ False
136
109
137instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
110instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
138instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
111instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
@@ -154,51 +127,40 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
154--
127--
155-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
128-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
156-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
129-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
157−toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
130+toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t
158toParamSchemaBoundedIntegral _ = mempty
131toParamSchemaBoundedIntegral _ = mempty
159− & type_ ?~ SwaggerInteger
132+ & type_ .~ SwaggerInteger
160 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
133 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
161 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
134 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
162
135
163instance ToParamSchema Char where
136instance ToParamSchema Char where
164 toParamSchema _ = mempty
137 toParamSchema _ = mempty
165− & type_ ?~ SwaggerString
138+ & type_ .~ SwaggerString
166 & maxLength ?~ 1
139 & maxLength ?~ 1
167 & minLength ?~ 1
140 & minLength ?~ 1
168
141
169instance ToParamSchema Scientific where
142instance ToParamSchema Scientific where
170− toParamSchema _ = mempty & type_ ?~ SwaggerNumber
143+ 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))
176
144
177instance ToParamSchema Double where
145instance ToParamSchema Double where
178 toParamSchema _ = mempty
146 toParamSchema _ = mempty
179− & type_ ?~ SwaggerNumber
147+ & type_ .~ SwaggerNumber
180 & format ?~ "double"
148 & format ?~ "double"
181
149
182instance ToParamSchema Float where
150instance ToParamSchema Float where
183 toParamSchema _ = mempty
151 toParamSchema _ = mempty
184− & type_ ?~ SwaggerNumber
152+ & type_ .~ SwaggerNumber
185 & format ?~ "float"
153 & format ?~ "float"
186
154
187timeParamSchema :: String -> ParamSchema t
155timeParamSchema :: String -> ParamSchema t
188timeParamSchema fmt = mempty
156timeParamSchema fmt = mempty
189− & type_ ?~ SwaggerString
157+ & type_ .~ SwaggerString
190 & format ?~ T.pack fmt
158 & format ?~ T.pack fmt
191
159
192-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
160-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
193instance ToParamSchema Day where
161instance ToParamSchema Day where
194 toParamSchema _ = timeParamSchema "date"
162 toParamSchema _ = timeParamSchema "date"
195
163
196−-- |
197−-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
198−-- Just "hh:MM:ss"
199−instance ToParamSchema TimeOfDay where
200− toParamSchema _ = timeParamSchema "hh:MM:ss"
201−
202-- |
164-- |
203-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
165-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
204-- Just "yyyy-mm-ddThh:MM:ss"
166-- Just "yyyy-mm-ddThh:MM:ss"
@@ -218,7 +180,7 @@ instance ToParamSchema UTCTime where
218 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
180 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
219
181
220instance ToParamSchema NominalDiffTime where
182instance ToParamSchema NominalDiffTime where
221− toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
183+ toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)
222
184
223instance ToParamSchema T.Text where
185instance ToParamSchema T.Text where
224 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
186 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
@@ -226,28 +188,6 @@ instance ToParamSchema T.Text where
226instance ToParamSchema TL.Text where
188instance ToParamSchema TL.Text where
227 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
189 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
228
190
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−
251instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
191instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
252instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
192instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
253instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
193instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
@@ -256,11 +196,9 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to
256instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
196instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
257instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
197instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
258
198
259−instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
260−
261instance ToParamSchema a => ToParamSchema [a] where
199instance ToParamSchema a => ToParamSchema [a] where
262 toParamSchema _ = mempty
200 toParamSchema _ = mempty
263− & type_ ?~ SwaggerArray
201+ & type_ .~ SwaggerArray
264 & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
202 & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
265
203
266instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
204instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
@@ -280,25 +218,20 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
280-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
218-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
281instance ToParamSchema () where
219instance ToParamSchema () where
282 toParamSchema _ = mempty
220 toParamSchema _ = mempty
283− & type_ ?~ SwaggerString
221+ & type_ .~ SwaggerString
284 & enum_ ?~ ["_"]
222 & enum_ ?~ ["_"]
285
223
286−instance ToParamSchema UUID where
287− toParamSchema _ = mempty
288− & type_ ?~ SwaggerString
289− & format ?~ "uuid"
290−
291-- | A configurable generic @'ParamSchema'@ creator.
224-- | A configurable generic @'ParamSchema'@ creator.
292--
225--
293-- >>> :set -XDeriveGeneric
226-- >>> :set -XDeriveGeneric
294-- >>> data Color = Red | Blue deriving Generic
227-- >>> data Color = Red | Blue deriving Generic
295-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
228-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
296-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
229-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
297−genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t
230+genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t
298genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
231genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
299
232
300class GToParamSchema (f :: * -> *) where
233class GToParamSchema (f :: * -> *) where
301− gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
234+ gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
302
235
303instance GToParamSchema f => GToParamSchema (D1 d f) where
236instance GToParamSchema f => GToParamSchema (D1 d f) where
304 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
237 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
@@ -316,14 +249,14 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
316 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
249 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
317
250
318class GEnumParamSchema (f :: * -> *) where
251class GEnumParamSchema (f :: * -> *) where
319− genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
252+ genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
320
253
321instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
254instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
322 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
255 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
323
256
324instance Constructor c => GEnumParamSchema (C1 c U1) where
257instance Constructor c => GEnumParamSchema (C1 c U1) where
325 genumParamSchema opts _ s = s
258 genumParamSchema opts _ s = s
326− & type_ ?~ SwaggerString
259+ & type_ .~ SwaggerString
327 & enum_ %~ addEnumValue tag
260 & enum_ %~ addEnumValue tag
328 where
261 where
329 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
262 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
@@ -333,5 +266,3 @@ instance Constructor c => GEnumParamSchema (C1 c U1) where
333
266
334data Proxy3 a b c = Proxy3
267data Proxy3 a b c = Proxy3
335
268
336−-- $setup
337−-- >>> import Data.Aeson (encode)
src/Data/Swagger/Internal/Schema.hs+105−280
@@ -1,10 +1,8 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE DataKinds #-}
8{-# LANGUAGE OverloadedLists #-}
6{-# LANGUAGE OverloadedLists #-}
9{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE OverloadedStrings #-}
10{-# LANGUAGE PackageImports #-}
8{-# LANGUAGE PackageImports #-}
@@ -14,13 +12,6 @@
14{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE TypeOperators #-}
16{-# LANGUAGE TypeSynonymInstances #-}
14{-# 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"
15#include "overlapping-compat.h"
25module Data.Swagger.Internal.Schema where
16module Data.Swagger.Internal.Schema where
26
17
@@ -30,25 +21,24 @@ import Prelude.Compat
30import Control.Lens
21import Control.Lens
31import Data.Data.Lens (template)
22import Data.Data.Lens (template)
32
23
24+import Control.Applicative
33import Control.Monad
25import Control.Monad
34import Control.Monad.Writer
26import Control.Monad.Writer
35−import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
27+import Data.Aeson
36import Data.Char
28import Data.Char
37import Data.Data (Data)
29import Data.Data (Data)
38import Data.Foldable (traverse_)
30import Data.Foldable (traverse_)
31+import Data.Function (on)
39import Data.HashMap.Strict (HashMap)
32import Data.HashMap.Strict (HashMap)
40import qualified Data.HashMap.Strict as HashMap
33import qualified Data.HashMap.Strict as HashMap
41import "unordered-containers" Data.HashSet (HashSet)
34import "unordered-containers" Data.HashSet (HashSet)
42import qualified "unordered-containers" Data.HashSet as HashSet
35import qualified "unordered-containers" Data.HashSet as HashSet
43−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
44import Data.Int
36import Data.Int
45import Data.IntSet (IntSet)
37import Data.IntSet (IntSet)
46import Data.IntMap (IntMap)
38import Data.IntMap (IntMap)
47−import Data.List.NonEmpty.Compat (NonEmpty)
48import Data.Map (Map)
39import Data.Map (Map)
49import Data.Proxy
40import Data.Proxy
50import Data.Scientific (Scientific)
41import Data.Scientific (Scientific)
51−import Data.Fixed (Fixed, HasResolution, Pico)
52import Data.Set (Set)
42import Data.Set (Set)
53import qualified Data.Text as T
43import qualified Data.Text as T
54import qualified Data.Text.Lazy as TL
44import qualified Data.Text.Lazy as TL
@@ -57,25 +47,17 @@ import qualified Data.Vector as V
57import qualified Data.Vector.Primitive as VP
47import qualified Data.Vector.Primitive as VP
58import qualified Data.Vector.Storable as VS
48import qualified Data.Vector.Storable as VS
59import qualified Data.Vector.Unboxed as VU
49import qualified Data.Vector.Unboxed as VU
60−import Data.Version (Version)
61−import Numeric.Natural.Compat (Natural)
62import Data.Word
50import Data.Word
63import GHC.Generics
51import GHC.Generics
64−import qualified Data.UUID.Types as UUID
65
52
66import Data.Swagger.Declare
53import Data.Swagger.Declare
67import Data.Swagger.Internal
54import Data.Swagger.Internal
68import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
55import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
69import Data.Swagger.Lens hiding (name, schema)
56import Data.Swagger.Lens hiding (name, schema)
70−import qualified Data.Swagger.Lens as Swagger
71import Data.Swagger.SchemaOptions
57import Data.Swagger.SchemaOptions
72−import Data.Swagger.Internal.TypeShape
73
58
74−#if __GLASGOW_HASKELL__ < 800
59+#ifdef __DOCTEST__
75−#else
60+import Data.Swagger.Lens (name, schema)
76−import qualified Data.ByteString as BS
77−import qualified Data.ByteString.Lazy as BSL
78−import GHC.TypeLits (TypeError, ErrorMessage(..))
79#endif
61#endif
80
62
81unnamed :: Schema -> NamedSchema
63unnamed :: Schema -> NamedSchema
@@ -102,21 +84,19 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
102-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
84-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
103--
85--
104-- import Control.Lens
86-- import Control.Lens
105−-- import Data.Proxy
106−-- import Data.Swagger
107--
87--
108-- data Coord = Coord { x :: Double, y :: Double }
88-- data Coord = Coord { x :: Double, y :: Double }
109--
89--
110-- instance ToSchema Coord where
90-- instance ToSchema Coord where
111−-- declareNamedSchema _ = do
91+-- declareNamedSchema = pure (Just \"Coord\", schema)
112−-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
92+-- where
113−-- return $ NamedSchema (Just \"Coord\") $ mempty
93+-- schema = mempty
114−-- & type_ ?~ SwaggerObject
94+-- & type_ .~ SwaggerObject
115−-- & properties .~
95+-- & properties .~
116−-- [ (\"x\", doubleSchema)
96+-- [ (\"x\", toSchemaRef (Proxy :: Proxy Double))
117−-- , (\"y\", doubleSchema)
97+-- , (\"y\", toSchemaRef (Proxy :: Proxy Double))
118−-- ]
98+-- ]
119−-- & required .~ [ \"x\", \"y\" ]
99+-- & required .~ [ \"x\", \"y\" ]
120-- @
100-- @
121--
101--
122-- Instead of manually writing your @'ToSchema'@ instance you can
102-- Instead of manually writing your @'ToSchema'@ instance you can
@@ -142,17 +122,12 @@ class ToSchema a where
142 -- together with all used definitions.
122 -- together with all used definitions.
143 -- Note that the schema itself is included in definitions
123 -- Note that the schema itself is included in definitions
144 -- only if it is recursive (and thus needs its definition in scope).
124 -- only if it is recursive (and thus needs its definition in scope).
145− declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
125+ 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
126+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
127 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
149
128
150−instance ToSchema TimeOfDay where
151− declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152− & example ?~ toJSON (TimeOfDay 12 33 15)
153−
154-- | Convert a type into a schema and declare all used schema definitions.
129-- | Convert a type into a schema and declare all used schema definitions.
155−declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
130+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
156declareSchema = fmap _namedSchemaSchema . declareNamedSchema
131declareSchema = fmap _namedSchemaSchema . declareNamedSchema
157
132
158-- | Convert a type into an optionally named schema.
133-- | Convert a type into an optionally named schema.
@@ -165,8 +140,8 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
165-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
140-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
166-- Just "Day"
141-- Just "Day"
167-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
142-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
168−-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
143+-- "{\"format\":\"date\",\"type\":\"string\"}"
169−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
144+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
170toNamedSchema = undeclare . declareNamedSchema
145toNamedSchema = undeclare . declareNamedSchema
171
146
172-- | Get type's schema name according to its @'ToSchema'@ instance.
147-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -176,7 +151,7 @@ toNamedSchema = undeclare . declareNamedSchema
176--
151--
177-- >>> schemaName (Proxy :: Proxy UTCTime)
152-- >>> schemaName (Proxy :: Proxy UTCTime)
178-- Just "UTCTime"
153-- Just "UTCTime"
179−schemaName :: ToSchema a => Proxy a -> Maybe T.Text
154+schemaName :: ToSchema a => proxy a -> Maybe T.Text
180schemaName = _namedSchemaName . toNamedSchema
155schemaName = _namedSchemaName . toNamedSchema
181
156
182-- | Convert a type into a schema.
157-- | Convert a type into a schema.
@@ -186,7 +161,7 @@ schemaName = _namedSchemaName . toNamedSchema
186--
161--
187-- >>> encode $ toSchema (Proxy :: Proxy [Day])
162-- >>> encode $ toSchema (Proxy :: Proxy [Day])
188-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
163-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
189−toSchema :: ToSchema a => Proxy a -> Schema
164+toSchema :: ToSchema a => proxy a -> Schema
190toSchema = _namedSchemaSchema . toNamedSchema
165toSchema = _namedSchemaSchema . toNamedSchema
191
166
192-- | Convert a type into a referenced schema if possible.
167-- | Convert a type into a referenced schema if possible.
@@ -197,7 +172,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
197--
172--
198-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
173-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
199-- "{\"$ref\":\"#/definitions/Day\"}"
174-- "{\"$ref\":\"#/definitions/Day\"}"
200−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
175+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
201toSchemaRef = undeclare . declareSchemaRef
176toSchemaRef = undeclare . declareSchemaRef
202
177
203-- | Convert a type into a referenced schema if possible
178-- | Convert a type into a referenced schema if possible
@@ -207,7 +182,7 @@ toSchemaRef = undeclare . declareSchemaRef
207-- Schema definitions are typically declared for every referenced schema.
182-- Schema definitions are typically declared for every referenced schema.
208-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
183-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
209-- will be declared (regardless of whether it is recusive or not).
184-- will be declared (regardless of whether it is recusive or not).
210−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
185+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
211declareSchemaRef proxy = do
186declareSchemaRef proxy = do
212 case toNamedSchema proxy of
187 case toNamedSchema proxy of
213 NamedSchema (Just name) schema -> do
188 NamedSchema (Just name) schema -> do
@@ -219,7 +194,7 @@ declareSchemaRef proxy = do
219 -- have already declared it.
194 -- have already declared it.
220 -- If we have, we don't need to declare anything for
195 -- If we have, we don't need to declare anything for
221 -- this schema this time and thus simply return the reference.
196 -- this schema this time and thus simply return the reference.
222− known <- looks (InsOrdHashMap.member name)
197+ known <- looks (HashMap.member name)
223 when (not known) $ do
198 when (not known) $ do
224 declare [(name, schema)]
199 declare [(name, schema)]
225 void $ declareNamedSchema proxy
200 void $ declareNamedSchema proxy
@@ -238,7 +213,7 @@ inlineSchemasWhen p defs = template %~ deref
238 where
213 where
239 deref r@(Ref (Reference name))
214 deref r@(Ref (Reference name))
240 | p name =
215 | p name =
241− case InsOrdHashMap.lookup name defs of
216+ case HashMap.lookup name defs of
242 Just schema -> Inline (inlineSchemasWhen p defs schema)
217 Just schema -> Inline (inlineSchemasWhen p defs schema)
243 Nothing -> r
218 Nothing -> r
244 | otherwise = r
219 | otherwise = r
@@ -265,11 +240,11 @@ inlineAllSchemas = inlineSchemasWhen (const True)
265-- | Convert a type into a schema without references.
240-- | Convert a type into a schema without references.
266--
241--
267-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
242-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
268−-- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
243+-- "{\"items\":{\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
269--
244--
270-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
245-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
271-- when inlining recursive schemas.
246-- when inlining recursive schemas.
272−toInlinedSchema :: ToSchema a => Proxy a -> Schema
247+toInlinedSchema :: ToSchema a => proxy a -> Schema
273toInlinedSchema proxy = inlineAllSchemas defs schema
248toInlinedSchema proxy = inlineAllSchemas defs schema
274 where
249 where
275 (defs, schema) = runDeclare (declareSchema proxy) mempty
250 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -280,7 +255,7 @@ inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
280inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
255inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
281 where
256 where
282 nonRecursive name =
257 nonRecursive name =
283− case InsOrdHashMap.lookup name defs of
258+ case HashMap.lookup name defs of
284 Just schema -> name `notElem` execDeclare (usedNames schema) mempty
259 Just schema -> name `notElem` execDeclare (usedNames schema) mempty
285 Nothing -> False
260 Nothing -> False
286
261
@@ -292,26 +267,26 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
292 seen <- looks (name `elem`)
267 seen <- looks (name `elem`)
293 when (not seen) $ do
268 when (not seen) $ do
294 declare [name]
269 declare [name]
295− traverse_ usedNames (InsOrdHashMap.lookup name defs)
270+ traverse_ usedNames (HashMap.lookup name defs)
296 Inline subschema -> usedNames subschema
271 Inline subschema -> usedNames subschema
297
272
298-- | Default schema for binary data (any sequence of octets).
273-- | Default schema for binary data (any sequence of octets).
299binarySchema :: Schema
274binarySchema :: Schema
300binarySchema = mempty
275binarySchema = mempty
301− & type_ ?~ SwaggerString
276+ & type_ .~ SwaggerString
302 & format ?~ "binary"
277 & format ?~ "binary"
303
278
304-- | Default schema for binary data (base64 encoded).
279-- | Default schema for binary data (base64 encoded).
305byteSchema :: Schema
280byteSchema :: Schema
306byteSchema = mempty
281byteSchema = mempty
307− & type_ ?~ SwaggerString
282+ & type_ .~ SwaggerString
308 & format ?~ "byte"
283 & format ?~ "byte"
309
284
310-- | Default schema for password string.
285-- | Default schema for password string.
311-- @"password"@ format is used to hint UIs the input needs to be obscured.
286-- @"password"@ format is used to hint UIs the input needs to be obscured.
312passwordSchema :: Schema
287passwordSchema :: Schema
313passwordSchema = mempty
288passwordSchema = mempty
314− & type_ ?~ SwaggerString
289+ & type_ .~ SwaggerString
315 & format ?~ "password"
290 & format ?~ "password"
316
291
317-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
292-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
@@ -329,7 +304,7 @@ passwordSchema = mempty
329-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
304-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
330-- >>> instance ToJSON Person
305-- >>> instance ToJSON Person
331-- >>> encode $ sketchSchema (Person "Jack" 25)
306-- >>> encode $ sketchSchema (Person "Jack" 25)
332−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"
307+-- "{\"example\":{\"age\":25,\"name\":\"Jack\"},\"required\":[\"age\",\"name\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}}}"
333sketchSchema :: ToJSON a => a -> Schema
308sketchSchema :: ToJSON a => a -> Schema
334sketchSchema = sketch . toJSON
309sketchSchema = sketch . toJSON
335 where
310 where
@@ -337,12 +312,12 @@ sketchSchema = sketch . toJSON
337 sketch js@(Bool _) = go js
312 sketch js@(Bool _) = go js
338 sketch js = go js & example ?~ js
313 sketch js = go js & example ?~ js
339
314
340− go Null = mempty & type_ ?~ SwaggerNull
315+ go Null = mempty & type_ .~ SwaggerNull
341− go (Bool _) = mempty & type_ ?~ SwaggerBoolean
316+ go js@(Bool _) = mempty & type_ .~ SwaggerBoolean
342− go (String _) = mempty & type_ ?~ SwaggerString
317+ go js@(String s) = mempty & type_ .~ SwaggerString
343− go (Number _) = mempty & type_ ?~ SwaggerNumber
318+ go js@(Number n) = mempty & type_ .~ SwaggerNumber
344− go (Array xs) = mempty
319+ go js@(Array xs) = mempty
345− & type_ ?~ SwaggerArray
320+ & type_ .~ SwaggerArray
346 & items ?~ case ischema of
321 & items ?~ case ischema of
347 Just s -> SwaggerItemsObject (Inline s)
322 Just s -> SwaggerItemsObject (Inline s)
348 _ -> SwaggerItemsArray (map Inline ys)
323 _ -> SwaggerItemsArray (map Inline ys)
@@ -351,12 +326,12 @@ sketchSchema = sketch . toJSON
351 allSame = and ((zipWith (==)) ys (tail ys))
326 allSame = and ((zipWith (==)) ys (tail ys))
352
327
353 ischema = case ys of
328 ischema = case ys of
354− (z:_) | allSame -> Just z
329+ (z:zs) | allSame -> Just z
355− _ -> Nothing
330+ _ -> Nothing
356− go (Object o) = mempty
331+ go js@(Object o) = mempty
357− & type_ ?~ SwaggerObject
332+ & type_ .~ SwaggerObject
358 & required .~ HashMap.keys o
333 & required .~ HashMap.keys o
359− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
334+ & properties .~ fmap (Inline . go) o
360
335
361-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
336-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
362-- Produced schema uses as much constraints as possible.
337-- Produced schema uses as much constraints as possible.
@@ -373,28 +348,28 @@ sketchSchema = sketch . toJSON
373-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
348-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
374-- >>> instance ToJSON Person
349-- >>> instance ToJSON Person
375-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
350-- >>> 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\"}]}"
351+-- "{\"minProperties\":2,\"required\":[\"age\",\"name\"],\"maxProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}}}"
377sketchStrictSchema :: ToJSON a => a -> Schema
352sketchStrictSchema :: ToJSON a => a -> Schema
378sketchStrictSchema = go . toJSON
353sketchStrictSchema = go . toJSON
379 where
354 where
380− go Null = mempty & type_ ?~ SwaggerNull
355+ go Null = mempty & type_ .~ SwaggerNull
381 go js@(Bool _) = mempty
356 go js@(Bool _) = mempty
382− & type_ ?~ SwaggerBoolean
357+ & type_ .~ SwaggerBoolean
383 & enum_ ?~ [js]
358 & enum_ ?~ [js]
384 go js@(String s) = mempty
359 go js@(String s) = mempty
385− & type_ ?~ SwaggerString
360+ & type_ .~ SwaggerString
386 & maxLength ?~ fromIntegral (T.length s)
361 & maxLength ?~ fromIntegral (T.length s)
387 & minLength ?~ fromIntegral (T.length s)
362 & minLength ?~ fromIntegral (T.length s)
388 & pattern ?~ s
363 & pattern ?~ s
389 & enum_ ?~ [js]
364 & enum_ ?~ [js]
390 go js@(Number n) = mempty
365 go js@(Number n) = mempty
391− & type_ ?~ SwaggerNumber
366+ & type_ .~ SwaggerNumber
392 & maximum_ ?~ n
367 & maximum_ ?~ n
393 & minimum_ ?~ n
368 & minimum_ ?~ n
394 & multipleOf ?~ n
369 & multipleOf ?~ n
395 & enum_ ?~ [js]
370 & enum_ ?~ [js]
396 go js@(Array xs) = mempty
371 go js@(Array xs) = mempty
397− & type_ ?~ SwaggerArray
372+ & type_ .~ SwaggerArray
398 & maxItems ?~ fromIntegral sz
373 & maxItems ?~ fromIntegral sz
399 & minItems ?~ fromIntegral sz
374 & minItems ?~ fromIntegral sz
400 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
375 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -404,9 +379,9 @@ sketchStrictSchema = go . toJSON
404 sz = length xs
379 sz = length xs
405 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
380 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
406 go js@(Object o) = mempty
381 go js@(Object o) = mempty
407− & type_ ?~ SwaggerObject
382+ & type_ .~ SwaggerObject
408 & required .~ names
383 & required .~ names
409− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
384+ & properties .~ fmap (Inline . go) o
410 & maxProperties ?~ fromIntegral (length names)
385 & maxProperties ?~ fromIntegral (length names)
411 & minProperties ?~ fromIntegral (length names)
386 & minProperties ?~ fromIntegral (length names)
412 & enum_ ?~ [js]
387 & enum_ ?~ [js]
@@ -414,19 +389,18 @@ sketchStrictSchema = go . toJSON
414 names = HashMap.keys o
389 names = HashMap.keys o
415
390
416class GToSchema (f :: * -> *) where
391class GToSchema (f :: * -> *) where
417− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
392+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
418
393
419instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
394instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
420 declareNamedSchema _ = do
395 declareNamedSchema _ = do
421 ref <- declareSchemaRef (Proxy :: Proxy a)
396 ref <- declareSchemaRef (Proxy :: Proxy a)
422 return $ unnamed $ mempty
397 return $ unnamed $ mempty
423− & type_ ?~ SwaggerArray
398+ & type_ .~ SwaggerArray
424 & items ?~ SwaggerItemsObject ref
399 & items ?~ SwaggerItemsObject ref
425
400
426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
401instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
427instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
402instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
428instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
403instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
430instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
404instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
431instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
405instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
432instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
406instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
@@ -438,16 +412,11 @@ instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
438instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
412instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
439instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
413instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
440
414
441−instance ToSchema Char where
442− declareNamedSchema proxy = plain (paramSchemaToSchema proxy)
415+instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema
443− & mapped.Swagger.schema.example ?~ toJSON '?'
444−
445instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
416instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
446instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
417instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
447instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
418instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
448
419
449−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
450−
451instance ToSchema a => ToSchema (Maybe a) where
420instance ToSchema a => ToSchema (Maybe a) where
452 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
421 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
453
422
@@ -456,11 +425,6 @@ instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
456instance ToSchema () where
425instance ToSchema () where
457 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
426 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
458
427
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−
464instance (ToSchema a, ToSchema b) => ToSchema (a, b)
428instance (ToSchema a, ToSchema b) => ToSchema (a, b)
465instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
429instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
466instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
430instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
@@ -470,81 +434,46 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
470
434
471timeSchema :: T.Text -> Schema
435timeSchema :: T.Text -> Schema
472timeSchema fmt = mempty
436timeSchema fmt = mempty
473− & type_ ?~ SwaggerString
437+ & type_ .~ SwaggerString
474 & format ?~ fmt
438 & format ?~ fmt
475
439
476-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
440-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
477instance ToSchema Day where
441instance ToSchema Day where
478− declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"
442+ declareNamedSchema _ = pure $ named "Day" (timeSchema "date")
479− & example ?~ toJSON (fromGregorian 2016 7 22)
480
443
481-- |
444-- |
482-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
445-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
483-- Just "yyyy-mm-ddThh:MM:ss"
446-- Just "yyyy-mm-ddThh:MM:ss"
484instance ToSchema LocalTime where
447instance ToSchema LocalTime where
485− declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
448+ declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")
486− & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
487
449
488-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
450-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
489instance ToSchema ZonedTime where
451instance ToSchema ZonedTime where
490 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
452 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
491− & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
492
453
493instance ToSchema NominalDiffTime where
454instance ToSchema NominalDiffTime where
494− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
455+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
495
456
496-- |
457-- |
497-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
458-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
498-- Just "yyyy-mm-ddThh:MM:ssZ"
459-- Just "yyyy-mm-ddThh:MM:ssZ"
499instance ToSchema UTCTime where
460instance ToSchema UTCTime where
500− declareNamedSchema _ = pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"
461+ declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")
501− & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)
502
462
503instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
463instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
504instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
464instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
505
465
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−
520instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
466instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
521
467
522-- | NOTE: This schema does not account for the uniqueness of keys.
468-- | NOTE: This schema does not account for the uniqueness of keys.
523instance ToSchema a => ToSchema (IntMap a) where
469instance ToSchema a => ToSchema (IntMap a) where
524 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
470 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
525
471
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−
543instance ToSchema a => ToSchema (Map String a) where
472instance ToSchema a => ToSchema (Map String a) where
544 declareNamedSchema _ = do
473 declareNamedSchema _ = do
545− schema <- declareSchemaRef (Proxy :: Proxy a)
474+ schema <- declareSchema (Proxy :: Proxy a)
546 return $ unnamed $ mempty
475 return $ unnamed $ mempty
547− & type_ ?~ SwaggerObject
476+ & type_ .~ SwaggerObject
548 & additionalProperties ?~ schema
477 & additionalProperties ?~ schema
549
478
550instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
479instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -554,14 +483,6 @@ instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ =
554instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
483instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
555instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
484instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
556
485
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−
565instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
486instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
566instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
487instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
567instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
488instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
@@ -575,13 +496,6 @@ instance ToSchema a => ToSchema (Set a) where
575
496
576instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
497instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
577
498
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−
585instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
499instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
586instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
500instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
587
501
@@ -591,147 +505,67 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname
591instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
505instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
592instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
506instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
593
507
594−instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
595−
596-- | Default schema for @'Bounded'@, @'Integral'@ types.
508-- | Default schema for @'Bounded'@, @'Integral'@ types.
597--
509--
598-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
510-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
599-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
511-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
600−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
512+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
601toSchemaBoundedIntegral _ = mempty
513toSchemaBoundedIntegral _ = mempty
602− & type_ ?~ SwaggerInteger
514+ & type_ .~ SwaggerInteger
603 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
515 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
604 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
516 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
605
517
606-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
518-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
607−genericToNamedSchemaBoundedIntegral :: forall a d f.
519+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
608 ( Bounded a, Integral a
520 ( Bounded a, Integral a
609 , Generic a, Rep a ~ D1 d f, Datatype d)
521 , Generic a, Rep a ~ D1 d f, Datatype d)
610− => SchemaOptions -> Proxy a -> NamedSchema
522+ => SchemaOptions -> proxy a -> NamedSchema
611genericToNamedSchemaBoundedIntegral opts proxy
523genericToNamedSchemaBoundedIntegral opts proxy
612− = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
524+ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (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
668
525
669-- | A configurable generic @'Schema'@ creator.
526-- | A configurable generic @'Schema'@ creator.
670−genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
671− SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
527+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
672−genericDeclareSchema = genericDeclareSchemaUnrestricted
528+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
673
529
674-- | A configurable generic @'NamedSchema'@ creator.
530-- | A configurable generic @'NamedSchema'@ creator.
675-- This function applied to @'defaultSchemaOptions'@
531-- This function applied to @'defaultSchemaOptions'@
676-- is used as the default for @'declareNamedSchema'@
532-- is used as the default for @'declareNamedSchema'@
677-- when the type is an instance of @'Generic'@.
533-- 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
681−
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
534+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
695−genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
535+genericDeclareNamedSchema 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
536
703−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
537+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
704−gdatatypeSchemaName opts _ = case orig of
538+gdatatypeSchemaName opts _ = case name of
705 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
539 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
706 _ -> Nothing
540 _ -> Nothing
707 where
541 where
708− orig = datatypeName (Proxy3 :: Proxy3 d f a)
542+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
709− name = datatypeNameModifier opts orig
710
543
711-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
544-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
545+paramSchemaToNamedSchema :: forall a d f proxy.
712−paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
546+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
713− SchemaOptions -> Proxy a -> NamedSchema
547+ => SchemaOptions -> proxy a -> NamedSchema
714−paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
548+paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
715
549
716-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
550-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
717−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
551+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
718−paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
552+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
719
553
720nullarySchema :: Schema
554nullarySchema :: Schema
721nullarySchema = mempty
555nullarySchema = mempty
722− & type_ ?~ SwaggerArray
556+ & type_ .~ SwaggerArray
723 & items ?~ SwaggerItemsArray []
557 & items ?~ SwaggerItemsArray []
724
558
725−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
559+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
560gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
727
561
728−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
562+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
729gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
563gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
730
564
731instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
565instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
732 gdeclareNamedSchema opts _ schema = do
566 gdeclareNamedSchema opts _ schema = do
733− NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema
567+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema
734− gdeclareNamedSchema opts (Proxy :: Proxy g) gschema
568+ gdeclareNamedSchema opts (Proxy :: Proxy f) gschema
735
569
736instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
570instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
737 gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
571 gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
@@ -745,7 +579,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
745 gdeclareNamedSchema = gdeclareNamedSumSchema
579 gdeclareNamedSchema = gdeclareNamedSumSchema
746
580
747-- | Single field constructor.
581-- | Single field constructor.
748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
582+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
749 gdeclareNamedSchema opts _ s
583 gdeclareNamedSchema opts _ s
750 | unwrapUnaryRecords opts = fieldSchema
584 | unwrapUnaryRecords opts = fieldSchema
751 | otherwise =
585 | otherwise =
@@ -759,7 +593,7 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
759 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
593 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
760 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
594 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
761
595
762−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
596+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
763gdeclareSchemaRef opts proxy = do
597gdeclareSchemaRef opts proxy = do
764 case gtoNamedSchema opts proxy of
598 case gtoNamedSchema opts proxy of
765 NamedSchema (Just name) schema -> do
599 NamedSchema (Just name) schema -> do
@@ -771,16 +605,16 @@ gdeclareSchemaRef opts proxy = do
771 -- have already declared it.
605 -- have already declared it.
772 -- If we have, we don't need to declare anything for
606 -- If we have, we don't need to declare anything for
773 -- this schema this time and thus simply return the reference.
607 -- this schema this time and thus simply return the reference.
774− known <- looks (InsOrdHashMap.member name)
608+ known <- looks (HashMap.member name)
775 when (not known) $ do
609 when (not known) $ do
776 declare [(name, schema)]
610 declare [(name, schema)]
777 void $ gdeclareNamedSchema opts proxy mempty
611 void $ gdeclareNamedSchema opts proxy mempty
778 return $ Ref (Reference name)
612 return $ Ref (Reference name)
779 _ -> Inline <$> gdeclareSchema opts proxy
613 _ -> Inline <$> gdeclareSchema opts proxy
780
614
781−appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
615+appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)
782appendItem x Nothing = Just (SwaggerItemsArray [x])
616appendItem x Nothing = Just (SwaggerItemsArray [x])
783−appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
617+appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs))
784appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
618appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
785
619
786withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
620withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
@@ -790,15 +624,13 @@ withFieldSchema opts _ isRequiredField schema = do
790 return $
624 return $
791 if T.null fname
625 if T.null fname
792 then schema
626 then schema
793− & type_ ?~ SwaggerArray
627+ & type_ .~ SwaggerArray
794 & items %~ appendItem ref
628 & items %~ appendItem ref
795− & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796− & minItems %~ Just . maybe 1 (+1) -- increment minItems
797 else schema
629 else schema
798− & type_ ?~ SwaggerObject
630+ & type_ .~ SwaggerObject
799 & properties . at fname ?~ ref
631 & properties . at fname ?~ ref
800 & if isRequiredField
632 & if isRequiredField
801− then required %~ (++ [fname])
633+ then required %~ (fname :)
802 else id
634 else id
803 where
635 where
804 fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
636 fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
@@ -817,13 +649,10 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
817instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
649instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
818 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
650 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
819
651
820−instance ( GSumToSchema f
652+instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
821− , GSumToSchema g
822− ) => GToSchema (f :+: g)
823− where
824 gdeclareNamedSchema = gdeclareNamedSumSchema
653 gdeclareNamedSchema = gdeclareNamedSumSchema
825
654
826−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
655+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
827gdeclareNamedSumSchema opts proxy s
656gdeclareNamedSumSchema opts proxy s
828 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
657 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
829 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
658 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -832,29 +661,29 @@ gdeclareNamedSumSchema opts proxy s
832 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
661 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
833
662
834 toStringTag schema = mempty
663 toStringTag schema = mempty
835− & type_ ?~ SwaggerString
664+ & type_ .~ SwaggerString
836− & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
665+ & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
837
666
838type AllNullary = All
667type AllNullary = All
839
668
840−class GSumToSchema (f :: * -> *) where
669+class GSumToSchema f where
841− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
670+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
842
671
843instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
672instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
844− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
673+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)
845
674
846−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
675+gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
847− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
676+ Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
848gsumConToSchemaWith ref opts _ schema = schema
677gsumConToSchemaWith ref opts _ schema = schema
849− & type_ ?~ SwaggerObject
678+ & type_ .~ SwaggerObject
850 & properties . at tag ?~ ref
679 & properties . at tag ?~ ref
851 & maxProperties ?~ 1
680 & maxProperties ?~ 1
852 & minProperties ?~ 1
681 & minProperties ?~ 1
853 where
682 where
854 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
683 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
855
684
856−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
685+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
857− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
686+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
858gsumConToSchema opts proxy schema = do
687gsumConToSchema opts proxy schema = do
859 ref <- gdeclareSchemaRef opts proxy
688 ref <- gdeclareSchemaRef opts proxy
860 return $ gsumConToSchemaWith ref opts proxy schema
689 return $ gsumConToSchemaWith ref opts proxy schema
@@ -876,7 +705,3 @@ data Proxy2 a b = Proxy2
876
705
877data Proxy3 a b c = Proxy3
706data Proxy3 a b c = Proxy3
878
707
879−-- $setup
880−-- >>> import Data.Swagger
881−-- >>> import Data.Aeson (encode)
882−-- >>> import Data.Aeson.Types (toJSONKeyText)
src/Data/Swagger/Internal/Schema/Validation.hs+77−264
@@ -1,17 +1,15 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveFunctor #-}
1+{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
3+{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE PackageImports #-}
8+{-# LANGUAGE PackageImports #-}
11−{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE RankNTypes #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TemplateHaskell #-}
11+{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE UndecidableInstances #-}
12+{-# LANGUAGE UndecidableInstances #-}
15-- |
13-- |
16-- Module: Data.Swagger.Internal.Schema.Validation
14-- Module: Data.Swagger.Internal.Schema.Validation
17-- Copyright: (c) 2015 GetShopTV
15-- Copyright: (c) 2015 GetShopTV
@@ -22,34 +20,28 @@
22-- Validate JSON values with Swagger Schema.
20-- Validate JSON values with Swagger Schema.
23module Data.Swagger.Internal.Schema.Validation where
21module Data.Swagger.Internal.Schema.Validation where
24
22
25−import Prelude ()
23+import Control.Applicative
26−import Prelude.Compat
24+import Control.Lens
25+import Control.Lens.TH
26+import Control.Monad (when)
27
27
28−import Control.Applicative
29−import Control.Lens
30−import Control.Monad (when)
31−
32−import Data.Aeson hiding (Result)
28+import Data.Aeson hiding (Result)
33−import Data.Aeson.Encode.Pretty (encodePretty)
34−import Data.Foldable (for_, sequenceA_,
29+import Data.Foldable (traverse_, for_, sequenceA_)
35− traverse_)
36−import Data.HashMap.Strict (HashMap)
30+import Data.HashMap.Strict (HashMap)
37−import qualified Data.HashMap.Strict as HashMap
31+import qualified Data.HashMap.Strict as HashMap
38−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
39import qualified "unordered-containers" Data.HashSet as HashSet
32import qualified "unordered-containers" Data.HashSet as HashSet
33+import Data.Monoid
40−import Data.Proxy
34+import Data.Proxy
41−import Data.Scientific (Scientific, isInteger)
35+import Data.Scientific (Scientific, isInteger)
42−import Data.Text (Text)
36+import Data.Text (Text)
43−import qualified Data.Text as Text
37+import qualified Data.Text as Text
44−import qualified Data.Text.Lazy as TL
38+import Data.Vector (Vector)
45−import qualified Data.Text.Lazy.Encoding as TL
46−import Data.Vector (Vector)
47−import qualified Data.Vector as Vector
39+import qualified Data.Vector as Vector
48−
40+
49−import Data.Swagger.Declare
41+import Data.Swagger.Declare
50−import Data.Swagger.Internal
42+import Data.Swagger.Internal
51−import Data.Swagger.Internal.Schema
43+import Data.Swagger.Internal.Schema
52−import Data.Swagger.Lens
44+import Data.Swagger.Lens
53
45
54-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
46-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
55-- This can be used with QuickCheck to ensure those instances are coherent:
47-- This can be used with QuickCheck to ensure those instances are coherent:
@@ -58,119 +50,21 @@ import Data.Swagger.Lens
58--
50--
59-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
51-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
60-- See @'validateToJSONWithPatternChecker'@.
52-- 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.
67validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
53validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
68validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
54validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
69
55
70-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
56-- | 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.
57-- This can be used with QuickCheck to ensure those instances are coherent.
72--
58--
73−-- For validation without patterns see @'validateToJSON'@. See also:
59+-- For validation without patterns see @'validateToJSON'@.
74−-- 'renderValidationErrors'.
75−validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]
60+validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>
76−validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON
61+ (Pattern -> Text -> Bool) -> a -> [ValidationError]
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
62+validateToJSONWithPatternChecker checker x = case runValidation (validateWithSchema js) cfg schema of
171 Failed xs -> xs
63 Failed xs -> xs
172 Passed _ -> mempty
64 Passed _ -> mempty
173 where
65 where
66+ (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
67+ js = toJSON x
174 cfg = defaultConfig
68 cfg = defaultConfig
175 { configPatternChecker = checker
69 { configPatternChecker = checker
176 , configDefinitions = defs }
70 , configDefinitions = defs }
@@ -199,7 +93,7 @@ instance Alternative Result where
199instance Monad Result where
93instance Monad Result where
200 return = pure
94 return = pure
201 Passed x >>= f = f x
95 Passed x >>= f = f x
202− Failed xs >>= _ = Failed xs
96+ Failed xs >>= f = Failed xs
203
97
204-- | Validation configuration.
98-- | Validation configuration.
205data Config = Config
99data Config = Config
@@ -244,7 +138,7 @@ instance Choice Validation where
244
138
245instance Monad (Validation s) where
139instance Monad (Validation s) where
246 return = pure
140 return = pure
247− Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)
141+ Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)
248 (>>) = (*>)
142 (>>) = (*>)
249
143
250withConfig :: (Config -> Validation s a) -> Validation s a
144withConfig :: (Config -> Validation s a) -> Validation s a
@@ -263,17 +157,11 @@ valid = pure ()
263
157
264-- | Validate schema's property given a lens into that property
158-- | Validate schema's property given a lens into that property
265-- and property checker.
159-- 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.
275check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
160check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
276−check = checkMissing valid
161+check l g = withSchema $ \schema ->
162+ case schema ^. l of
163+ Nothing -> valid
164+ Just x -> g x
277
165
278-- | Validate same value with different schema.
166-- | Validate same value with different schema.
279sub :: t -> Validation t a -> Validation s a
167sub :: t -> Validation t a -> Validation s a
@@ -286,12 +174,12 @@ sub_ = lmap . view
286-- | Validate value against a schema given schema reference and validation function.
174-- | Validate value against a schema given schema reference and validation function.
287withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
175withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
288withRef (Reference ref) f = withConfig $ \cfg ->
176withRef (Reference ref) f = withConfig $ \cfg ->
289− case InsOrdHashMap.lookup ref (configDefinitions cfg) of
177+ case HashMap.lookup ref (configDefinitions cfg) of
290 Nothing -> invalid $ "unknown schema " ++ show ref
178 Nothing -> invalid $ "unknown schema " ++ show ref
291 Just s -> f s
179 Just s -> f s
292
180
293validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
181validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
294−validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)
182+validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)
295validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
183validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
296
184
297-- | Validate JSON @'Value'@ with Swagger @'Schema'@.
185-- | Validate JSON @'Value'@ with Swagger @'Schema'@.
@@ -313,9 +201,9 @@ validateInteger n = do
313 validateNumber n
201 validateNumber n
314
202
315validateNumber :: Scientific -> Validation (ParamSchema t) ()
203validateNumber :: Scientific -> Validation (ParamSchema t) ()
316−validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do
204+validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do
317− let exMax = Just True == sch ^. exclusiveMaximum
205+ let exMax = Just True == schema ^. exclusiveMaximum
318− exMin = Just True == sch ^. exclusiveMinimum
206+ exMin = Just True == schema ^. exclusiveMinimum
319
207
320 check maximum_ $ \m ->
208 check maximum_ $ \m ->
321 when (if exMax then (n >= m) else (n > m)) $
209 when (if exMax then (n >= m) else (n > m)) $
@@ -372,8 +260,8 @@ validateArray xs = do
372 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
260 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
373
261
374validateObject :: HashMap Text Value -> Validation Schema ()
262validateObject :: HashMap Text Value -> Validation Schema ()
375−validateObject o = withSchema $ \sch ->
263+validateObject o = withSchema $ \schema ->
376− case sch ^. discriminator of
264+ case schema ^. discriminator of
377 Just pname -> case fromJSON <$> HashMap.lookup pname o of
265 Just pname -> case fromJSON <$> HashMap.lookup pname o of
378 Just (Success ref) -> validateWithSchemaRef ref (Object o)
266 Just (Success ref) -> validateWithSchemaRef ref (Object o)
379 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)
267 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)
@@ -392,120 +280,45 @@ validateObject o = withSchema $ \sch ->
392 where
280 where
393 size = fromIntegral (HashMap.size o)
281 size = fromIntegral (HashMap.size o)
394
282
395− validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)
283+ validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)
396− validateReq n =
284+ validateReq name =
397− when (not (HashMap.member n o)) $
285+ when (not (HashMap.member name o)) $
398− invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))
286+ invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))
399
287
400− validateProps = withSchema $ \sch -> do
288+ validateProps = withSchema $ \schema -> do
401 for_ (HashMap.toList o) $ \(k, v) ->
289 for_ (HashMap.toList o) $ \(k, v) ->
402 case v of
290 case v of
403− Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
291+ Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property
404 _ ->
292 _ ->
405− case InsOrdHashMap.lookup k (sch ^. properties) of
293+ case HashMap.lookup k (schema ^. properties) of
406− Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
294+ Nothing -> check additionalProperties $ \s -> sub s $ validateWithSchema v
407 Just s -> validateWithSchemaRef s v
295 Just s -> validateWithSchemaRef s v
408
296
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−
417validateEnum :: Value -> Validation (ParamSchema t) ()
297validateEnum :: Value -> Validation (ParamSchema t) ()
418validateEnum value = do
298validateEnum value = do
419 check enum_ $ \xs ->
299 check enum_ $ \xs ->
420 when (value `notElem` xs) $
300 when (value `notElem` xs) $
421 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
301 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
422
302
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−
470validateSchemaType :: Value -> Validation Schema ()
303validateSchemaType :: Value -> Validation Schema ()
471−validateSchemaType value = withSchema $ \sch ->
304+validateSchemaType value = withSchema $ \schema ->
472− case (sch ^. type_, value) of
305+ case (schema ^. type_, value) of
473− (Just SwaggerNull, Null) -> valid
306+ (SwaggerNull, Null) -> valid
474− (Just SwaggerBoolean, Bool _) -> valid
307+ (SwaggerBoolean, Bool _) -> valid
475− (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
308+ (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
476− (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
309+ (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
477− (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)
310+ (SwaggerString, String s) -> sub_ paramSchema (validateString s)
478− (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
311+ (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
479− (Just SwaggerObject, Object o) -> validateObject o
312+ (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
313+ (t, _) -> invalid $ "expected JSON value of type " ++ show t
488
314
489validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
315validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
490−validateParamSchemaType value = withSchema $ \sch ->
316+validateParamSchemaType value = withSchema $ \schema ->
491− case (sch ^. type_, value) of
317+ case (schema ^. type_, value) of
492− (Just SwaggerBoolean, Bool _) -> valid
318+ (SwaggerBoolean, Bool _) -> valid
493− (Just SwaggerInteger, Number n) -> validateInteger n
319+ (SwaggerInteger, Number n) -> validateInteger n
494− (Just SwaggerNumber, Number n) -> validateNumber n
320+ (SwaggerNumber, Number n) -> validateNumber n
495− (Just SwaggerString, String s) -> validateString s
321+ (SwaggerString, String s) -> validateString s
496− (Just SwaggerArray, Array xs) -> validateArray xs
322+ (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
323+ (t, _) -> invalid $ "expected JSON value of type " ++ show t
503−
324+
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+46−7
@@ -9,6 +9,8 @@ module Data.Swagger.Internal.Utils where
9import Prelude ()
9import Prelude ()
10import Prelude.Compat
10import Prelude.Compat
11
11
12+import Control.Arrow (first)
13+import Control.Applicative
12import Control.Lens ((&), (%~))
14import Control.Lens ((&), (%~))
13import Control.Lens.TH
15import Control.Lens.TH
14import Data.Aeson
16import Data.Aeson
@@ -18,13 +20,13 @@ import Data.Data
18import Data.Hashable (Hashable)
20import Data.Hashable (Hashable)
19import Data.HashMap.Strict (HashMap)
21import Data.HashMap.Strict (HashMap)
20import qualified Data.HashMap.Strict as HashMap
22import qualified Data.HashMap.Strict as HashMap
21−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
22−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
23import Data.Map (Map)
23import Data.Map (Map)
24+import Data.Monoid
24import Data.Set (Set)
25import Data.Set (Set)
25import Data.Text (Text)
26import Data.Text (Text)
26import GHC.Generics
27import GHC.Generics
27import Language.Haskell.TH (mkName)
28import Language.Haskell.TH (mkName)
29+import Text.Read (readMaybe)
28
30
29swaggerFieldRules :: LensRules
31swaggerFieldRules :: LensRules
30swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
32swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
@@ -43,7 +45,6 @@ swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
43 fixName' "minimum" = "minimum_" -- Prelude conflict
45 fixName' "minimum" = "minimum_" -- Prelude conflict
44 fixName' "maximum" = "maximum_" -- Prelude conflict
46 fixName' "maximum" = "maximum_" -- Prelude conflict
45 fixName' "enum" = "enum_" -- Control.Lens conflict
47 fixName' "enum" = "enum_" -- Control.Lens conflict
46− fixName' "head" = "head_" -- Prelude conflict
47 fixName' n = n
48 fixName' n = n
48
49
49gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
50gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
@@ -51,6 +52,17 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of
51 Just x -> z x
52 Just x -> z x
52 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
53 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
53
54
55+hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v
56+hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList
57+
58+hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)
59+hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList
60+ where
61+ g (x, y) = (\a -> (a, y)) <$> f x
62+
63+hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)
64+hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)
65+
54jsonPrefix :: String -> Options
66jsonPrefix :: String -> Options
55jsonPrefix prefix = defaultOptions
67jsonPrefix prefix = defaultOptions
56 { fieldLabelModifier = modifier . drop 1
68 { fieldLabelModifier = modifier . drop 1
@@ -72,10 +84,40 @@ parseOneOf xs js =
72 where
84 where
73 ys = zip (map toJSON xs) xs
85 ys = zip (map toJSON xs) xs
74
86
87+omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value
88+omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o)
89+ where
90+ nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
91+omitEmptiesExcept _ js = js
92+
93+omitEmpties :: Value -> Value
94+omitEmpties = omitEmptiesExcept (\_ _ -> False)
95+
96+genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
97+genericToJSONWithSub sub opts x =
98+ case genericToJSON opts x of
99+ Object o ->
100+ case HashMap.lookup sub o of
101+ Just so -> Object (HashMap.delete sub o) <+> so
102+ Nothing -> Object o -- no subjson, leaving object as is
103+ _ -> error "genericToJSONWithSub: subjson is not an object"
104+
105+genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
106+genericParseJSONWithSub sub opts js@(Object o)
107+ = genericParseJSON opts js -- try without subjson
108+ <|> genericParseJSON opts js' -- try with subjson
109+ where
110+ js' = Object (HashMap.insert sub (Object o) o)
111+genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"
112+
75(<+>) :: Value -> Value -> Value
113(<+>) :: Value -> Value -> Value
76Object x <+> Object y = Object (x <> y)
114Object x <+> Object y = Object (x <> y)
77_ <+> _ = error "<+>: merging non-objects"
115_ <+> _ = error "<+>: merging non-objects"
78
116
117+withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
118+withDefaults parser defs js@(Object _) = parser (js <+> object defs)
119+withDefaults _ _ _ = empty
120+
79genericMempty :: (Generic a, GMonoid (Rep a)) => a
121genericMempty :: (Generic a, GMonoid (Rep a)) => a
80genericMempty = to gmempty
122genericMempty = to gmempty
81
123
@@ -118,10 +160,6 @@ instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
118 swaggerMempty = mempty
160 swaggerMempty = mempty
119 swaggerMappend = HashMap.unionWith (\_old new -> new)
161 swaggerMappend = HashMap.unionWith (\_old new -> new)
120
162
121−instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where
122− swaggerMempty = mempty
123− swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)
124−
125instance SwaggerMonoid Text where
163instance SwaggerMonoid Text where
126 swaggerMempty = mempty
164 swaggerMempty = mempty
127 swaggerMappend x "" = x
165 swaggerMappend x "" = x
@@ -131,3 +169,4 @@ instance SwaggerMonoid (Maybe a) where
131 swaggerMempty = Nothing
169 swaggerMempty = Nothing
132 swaggerMappend x Nothing = x
170 swaggerMappend x Nothing = x
133 swaggerMappend _ y = y
171 swaggerMappend _ y = y
172+
src/Data/Swagger/Lens.hs+10−27
@@ -7,16 +7,9 @@
7{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE TemplateHaskell #-}
8{-# LANGUAGE TemplateHaskell #-}
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE DataKinds #-}
11{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
12{-# OPTIONS_GHC -fno-warn-orphans #-}
11{-# OPTIONS_GHC -fno-warn-orphans #-}
13#include "overlapping-compat.h"
12#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.
20module Data.Swagger.Lens where
13module Data.Swagger.Lens where
21
14
22import Control.Lens
15import Control.Lens
@@ -33,7 +26,7 @@ makeFields ''Host
33makeFields ''Info
26makeFields ''Info
34makeFields ''Contact
27makeFields ''Contact
35makeFields ''License
28makeFields ''License
36−makeLensesWith swaggerFieldRules ''PathItem
29+makeFields ''PathItem
37makeFields ''Tag
30makeFields ''Tag
38makeFields ''Operation
31makeFields ''Operation
39makeFields ''Param
32makeFields ''Param
@@ -60,23 +53,19 @@ makePrisms ''Referenced
60
53
61-- ** 'SwaggerItems' prisms
54-- ** 'SwaggerItems' prisms
62
55
63−_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]
56+_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema]
64_SwaggerItemsArray
57_SwaggerItemsArray
65− = unto (\x -> SwaggerItemsArray x)
58+ = prism (\x -> SwaggerItemsArray x) $ \x -> case x of
66−{- \x -> case x of
67 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
59 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
68 SwaggerItemsObject o -> Left (SwaggerItemsObject o)
60 SwaggerItemsObject o -> Left (SwaggerItemsObject o)
69 SwaggerItemsArray a -> Right a
61 SwaggerItemsArray a -> Right a
70−-}
71
62
72−_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)
63+_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema)
73_SwaggerItemsObject
64_SwaggerItemsObject
74− = unto (\x -> SwaggerItemsObject x)
65+ = prism (\x -> SwaggerItemsObject x) $ \x -> case x of
75−{- \x -> case x of
76 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
66 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
77 SwaggerItemsObject o -> Right o
67 SwaggerItemsObject o -> Right o
78 SwaggerItemsArray a -> Left (SwaggerItemsArray a)
68 SwaggerItemsArray a -> Left (SwaggerItemsArray a)
79−-}
80
69
81_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)
70_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)
82_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)
71_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)
@@ -96,19 +85,13 @@ instance At Responses where at n = responses . at n
96instance Ixed Operation where ix n = responses . ix n
85instance Ixed Operation where ix n = responses . ix n
97instance At Operation where at n = responses . at n
86instance At Operation where at n = responses . at n
98
87
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
88+instance HasParamSchema NamedSchema (ParamSchema Schema) where paramSchema = schema.paramSchema
106
89
107-- HasType instances
90-- HasType instances
108−instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_
91+instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_
109−instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
92+instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_
110−instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
93+instance HasType NamedSchema (SwaggerType Schema) where type_ = paramSchema.type_
111−instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_
94+instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_
112
95
113-- HasDefault instances
96-- HasDefault instances
114instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
97instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
src/Data/Swagger/Operation.hs+21−18
@@ -1,6 +1,8 @@
1{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
2-- |
2-- |
3-- Module: Data.Swagger.Operation
3-- Module: Data.Swagger.Operation
4+-- Copyright: (c) 2015 GetShopTV
5+-- License: BSD3
4-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
6-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5-- Stability: experimental
7-- Stability: experimental
6--
8--
@@ -30,24 +32,22 @@ module Data.Swagger.Operation (
30 declareResponse,
32 declareResponse,
31) where
33) where
32
34
33−import Prelude ()
35+import Control.Applicative
34−import Prelude.Compat
36+import Control.Arrow
35−
36import Control.Lens
37import Control.Lens
37import Data.Data.Lens
38import Data.Data.Lens
39+import qualified Data.HashMap.Strict as HashMap
38−import Data.List.Compat
40+import Data.List
39import Data.Maybe (mapMaybe)
41import Data.Maybe (mapMaybe)
40−import Data.Proxy
42+import Data.Monoid
41import qualified Data.Set as Set
43import qualified Data.Set as Set
44+import Data.Traversable
42
45
43import Data.Swagger.Declare
46import Data.Swagger.Declare
44import Data.Swagger.Internal
47import Data.Swagger.Internal
45import Data.Swagger.Lens
48import Data.Swagger.Lens
46import Data.Swagger.Schema
49import Data.Swagger.Schema
47
50
48−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
49−import qualified Data.HashSet.InsOrd as InsOrdHS
50−
51-- $setup
51-- $setup
52-- >>> import Data.Aeson
52-- >>> import Data.Aeson
53-- >>> import Data.Proxy
53-- >>> import Data.Proxy
@@ -60,8 +60,10 @@ import qualified Data.HashSet.InsOrd as InsOrdHS
60-- >>> encode $ prependPath "user/{user_id}" api ^. paths
60-- >>> encode $ prependPath "user/{user_id}" api ^. paths
61-- "{\"/user/{user_id}/info\":{}}"
61-- "{\"/user/{user_id}/info\":{}}"
62prependPath :: FilePath -> Swagger -> Swagger
62prependPath :: FilePath -> Swagger -> Swagger
63−prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)
63+prependPath path = paths %~ mapKeys (path </>)
64 where
64 where
65+ mapKeys f = HashMap.fromList . map (first f) . HashMap.toList
66+
65 x </> y = case trim y of
67 x </> y = case trim y of
66 "" -> "/" <> trim x
68 "" -> "/" <> trim x
67 y' -> "/" <> trim x <> "/" <> y'
69 y' -> "/" <> trim x <> "/" <> y'
@@ -80,15 +82,15 @@ allOperations = paths.traverse.template
80-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
82-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
81-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
83-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
82-- >>> encode api
84-- >>> encode api
83−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
85+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
84-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"
86-- >>> 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\"}}}}}}"
87+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}"
86operationsOf :: Swagger -> Traversal' Swagger Operation
88operationsOf :: Swagger -> Traversal' Swagger Operation
87operationsOf sub = paths.itraversed.withIndex.subops
89operationsOf sub = paths.itraversed.withIndex.subops
88 where
90 where
89 -- | Traverse operations that correspond to paths and methods of the sub API.
91 -- | Traverse operations that correspond to paths and methods of the sub API.
90 subops :: Traversal' (FilePath, PathItem) Operation
92 subops :: Traversal' (FilePath, PathItem) Operation
91− subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of
93+ subops f (path, item) = case HashMap.lookup path (sub ^. paths) of
92 Just subitem -> (,) path <$> methodsOf subitem f item
94 Just subitem -> (,) path <$> methodsOf subitem f item
93 Nothing -> pure (path, item)
95 Nothing -> pure (path, item)
94
96
@@ -112,15 +114,15 @@ applyTags = applyTagsFor allOperations
112-- list of tags.
114-- list of tags.
113applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
115applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
114applyTagsFor ops ts swag = swag
116applyTagsFor ops ts swag = swag
115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
117+ & ops . tags %~ (<> Set.fromList (map _tagName ts))
116− & tags %~ (<> InsOrdHS.fromList ts)
118+ & tags %~ (<> Set.fromList ts)
117
119
118-- | Construct a response with @'Schema'@ while declaring all
120-- | Construct a response with @'Schema'@ while declaring all
119-- necessary schema definitions.
121-- necessary schema definitions.
120--
122--
121-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
123-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
122−-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"
124+-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]"
123−declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response
125+declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response
124declareResponse proxy = do
126declareResponse proxy = do
125 s <- declareSchemaRef proxy
127 s <- declareSchemaRef proxy
126 return (mempty & schema ?~ s)
128 return (mempty & schema ?~ s)
@@ -139,7 +141,7 @@ declareResponse proxy = do
139-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
141-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
140-- >>> let res = declareResponse (Proxy :: Proxy Day)
142-- >>> let res = declareResponse (Proxy :: Proxy Day)
141-- >>> encode $ api & setResponse 200 res
143-- >>> 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\"}}}"
144+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}"
143--
145--
144-- See also @'setResponseWith'@.
146-- See also @'setResponseWith'@.
145setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
147setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
@@ -186,8 +188,9 @@ setResponseForWith ops f code dres swag = swag
186 where
188 where
187 (defs, new) = runDeclare dres mempty
189 (defs, new) = runDeclare dres mempty
188
190
189− combine (Just (Ref (Reference n))) = case swag ^. responses.at n of
191+ combine (Just (Ref (Reference name))) = case swag ^. responses.at name of
190 Just old -> f old new
192 Just old -> f old new
191 Nothing -> new -- response name can't be dereferenced, replacing with new response
193 Nothing -> new -- response name can't be dereferenced, replacing with new response
192 combine (Just (Inline old)) = f old new
194 combine (Just (Inline old)) = f old new
193 combine Nothing = new
195 combine Nothing = new
196+
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
@@ -1,5 +1,7 @@
1-- |
1-- |
2-- Module: Data.Swagger.ParamSchema
2-- Module: Data.Swagger.ParamSchema
3+-- Copyright: (c) 2015 GetShopTV
4+-- License: BSD3
3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4-- Stability: experimental
6-- Stability: experimental
5--
7--
src/Data/Swagger/Schema.hs+2−15
@@ -1,5 +1,7 @@
1-- |
1-- |
2-- Module: Data.Swagger.Schema
2-- Module: Data.Swagger.Schema
3+-- Copyright: (c) 2015 GetShopTV
4+-- License: BSD3
3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4-- Stability: experimental
6-- Stability: experimental
5--
7--
@@ -17,25 +19,11 @@ module Data.Swagger.Schema (
17 -- * Generic schema encoding
19 -- * Generic schema encoding
18 genericDeclareNamedSchema,
20 genericDeclareNamedSchema,
19 genericDeclareSchema,
21 genericDeclareSchema,
20− genericDeclareNamedSchemaNewtype,
21− genericNameSchema,
22−
23− -- ** 'Bounded' 'Integral'
24 genericToNamedSchemaBoundedIntegral,
22 genericToNamedSchemaBoundedIntegral,
25 toSchemaBoundedIntegral,
23 toSchemaBoundedIntegral,
26−
27− -- ** 'Bounded' 'Enum' key mappings
28− declareSchemaBoundedEnumKeyMapping,
29− toSchemaBoundedEnumKeyMapping,
30−
31− -- ** Reusing 'ToParamSchema'
32 paramSchemaToNamedSchema,
24 paramSchemaToNamedSchema,
33 paramSchemaToSchema,
25 paramSchemaToSchema,
34
26
35− -- ** Unrestricted versions
36− genericDeclareNamedSchemaUnrestricted,
37− genericDeclareSchemaUnrestricted,
38−
39 -- * Schema templates
27 -- * Schema templates
40 passwordSchema,
28 passwordSchema,
41 binarySchema,
29 binarySchema,
@@ -54,7 +42,6 @@ module Data.Swagger.Schema (
54 -- * Generic encoding configuration
42 -- * Generic encoding configuration
55 SchemaOptions(..),
43 SchemaOptions(..),
56 defaultSchemaOptions,
44 defaultSchemaOptions,
57− fromAesonOptions,
58) where
45) where
59
46
60import Data.Swagger.Internal.Schema
47import 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.hs+3−10
@@ -1,5 +1,7 @@
1-- |
1-- |
2-- Module: Data.Swagger.Schema.Validation
2-- Module: Data.Swagger.Schema.Validation
3+-- Copyright: (c) 2015 GetShopTV
4+-- License: BSD3
3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4-- Stability: experimental
6-- Stability: experimental
5--
7--
@@ -15,18 +17,9 @@ module Data.Swagger.Schema.Validation (
15 -- $maybe
17 -- $maybe
16
18
17 -- * JSON validation
19 -- * JSON validation
18−
19− ValidationError,
20−
21− -- ** Using 'ToJSON' and 'ToSchema'
22− validatePrettyToJSON,
23 validateToJSON,
20 validateToJSON,
24 validateToJSONWithPatternChecker,
21 validateToJSONWithPatternChecker,
25− renderValidationErrors,
22+ ValidationError,
26−
27− -- ** Using 'Value' and 'Schema'
28− validateJSON,
29− validateJSONWithPatternChecker,
30) where
23) where
31
24
32import Data.Swagger.Internal.Schema.Validation
25import Data.Swagger.Internal.Schema.Validation
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'@.
8module Data.Swagger.SchemaOptions where
1module Data.Swagger.SchemaOptions where
9
2
10−import qualified Data.Aeson.Types as Aeson
11−
12-- | Options that specify how to encode your type to Swagger schema.
3-- | Options that specify how to encode your type to Swagger schema.
13data SchemaOptions = SchemaOptions
4data SchemaOptions = SchemaOptions
14 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
5 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
@@ -44,29 +35,3 @@ defaultSchemaOptions = SchemaOptions
44 , unwrapUnaryRecords = False
35 , unwrapUnaryRecords = False
45 }
36 }
46
37
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-lts-2.yamlnew file+5
@@ -0,0 +1,5 @@
1+flags: {}
2+packages:
3+- '.'
4+extra-deps: []
5+resolver: lts-2.22
stack.yaml+3−7
@@ -1,9 +1,5 @@
1−resolver: lts-14.3
1+flags: {}
2packages:
2packages:
3- '.'
3- '.'
4−extra-deps:
4+extra-deps: []
5−- optics-core-0.2
5+resolver: nightly-2016-01-26
6−- optics-th-0.2
7−- optics-extra-0.2
8−- indexed-profunctors-0.1
9−- insert-ordered-containers-0.2.3
swagger2.cabal+42−100
@@ -1,38 +1,23 @@
1−cabal-version: >=1.10
2name: swagger2
1name: swagger2
3−version: 2.5
2+version: 1.2.1
4−
5synopsis: Swagger 2.0 data model
3synopsis: Swagger 2.0 data model
6−category: Web, Swagger
7−description:
4+description: Please see README.md
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−
13homepage: https://github.com/GetShopTV/swagger2
5homepage: https://github.com/GetShopTV/swagger2
14bug-reports: https://github.com/GetShopTV/swagger2/issues
6bug-reports: https://github.com/GetShopTV/swagger2/issues
15license: BSD3
7license: BSD3
16license-file: LICENSE
8license-file: LICENSE
17author: Nickolay Kudasov
9author: Nickolay Kudasov
18maintainer: nickolay@getshoptv.com
10maintainer: nickolay@getshoptv.com
19−copyright: (c) 2015-2016, GetShopTV
11+copyright: (c) 2015, GetShopTV
12+category: Web
20−build-type: Custom
13+build-type: Simple
21extra-source-files:
14extra-source-files:
22 README.md
15 README.md
23 , CHANGELOG.md
16 , CHANGELOG.md
24 , examples/*.hs
17 , examples/*.hs
25 , include/overlapping-compat.h
18 , include/overlapping-compat.h
19+cabal-version: >=1.10
26−tested-with:
20+tested-with: GHC==7.8.4, GHC==7.10.3
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
36
21
37library
22library
38 hs-source-dirs: src
23 hs-source-dirs: src
@@ -42,10 +27,8 @@ library
42 Data.Swagger.Declare
27 Data.Swagger.Declare
43 Data.Swagger.Lens
28 Data.Swagger.Lens
44 Data.Swagger.Operation
29 Data.Swagger.Operation
45− Data.Swagger.Optics
46 Data.Swagger.ParamSchema
30 Data.Swagger.ParamSchema
47 Data.Swagger.Schema
31 Data.Swagger.Schema
48− Data.Swagger.Schema.Generator
49 Data.Swagger.Schema.Validation
32 Data.Swagger.Schema.Validation
50 Data.Swagger.SchemaOptions
33 Data.Swagger.SchemaOptions
51
34
@@ -55,98 +38,57 @@ library
55 Data.Swagger.Internal.Schema.Validation
38 Data.Swagger.Internal.Schema.Validation
56 Data.Swagger.Internal.ParamSchema
39 Data.Swagger.Internal.ParamSchema
57 Data.Swagger.Internal.Utils
40 Data.Swagger.Internal.Utils
58− Data.Swagger.Internal.AesonUtils
59− Data.Swagger.Internal.TypeShape
60−
61− -- GHC boot libraries
62− build-depends:
41+ build-depends: base >=4.7 && <4.10
63− base >=4.9 && <4.14
42+ , base-compat >=0.6.0 && <0.10
64− , aeson-pretty >=0.8.7 && <0.9
43+ , aeson
65− , bytestring >=0.10.4.0 && <0.11
44+ , containers
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
45+ , hashable
83− , http-media >=0.7.1.2 && <0.9
46+ , http-media
84− , insert-ordered-containers >=0.2.3 && <0.3
85− , lens >=4.16.1 && <4.19
47+ , lens
48+ , mtl
86− , network >=2.6.3.5 && <3.2
49+ , network
87− , optics-core >=0.2 && <0.3
88− , optics-th >=0.2 && <0.3
89− , scientific >=0.3.6.2 && <0.4
50+ , scientific
90− , transformers-compat >=0.3 && <0.7
51+ , text
52+ , template-haskell
53+ , time
54+ , transformers
91− , unordered-containers >=0.2.9.0 && <0.3
55+ , unordered-containers
92− , uuid-types >=1.0.3 && <1.1
93− , vector >=0.12.0.1 && <0.13
56+ , vector
94− , QuickCheck >=2.10.1 && <2.14
95−
96 default-language: Haskell2010
57 default-language: Haskell2010
97
58
98test-suite spec
59test-suite spec
99 type: exitcode-stdio-1.0
60 type: exitcode-stdio-1.0
100 hs-source-dirs: test
61 hs-source-dirs: test
101 main-is: Spec.hs
62 main-is: Spec.hs
102−
103− -- From library parat
104− -- We need aeson's toEncoding for doctests too
105− build-depends:
63+ build-depends: base
106− base
107− , swagger2
108− , aeson
109− , base-compat-batteries
64+ , base-compat
110− , bytestring
65+ , aeson
66+ , aeson-qq
111− , containers
67+ , containers
112− , hashable
68+ , hashable
113− , insert-ordered-containers
69+ , hspec
114− , lens
70+ , HUnit
115− , mtl
71+ , mtl
116− , template-haskell
72+ , QuickCheck
73+ , swagger2
117− , text
74+ , text
118− , time
75+ , time
119− , unordered-containers
76+ , unordered-containers
120− , vector
77+ , vector
121− , QuickCheck
78+ , lens
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−
134 other-modules:
79 other-modules:
135 SpecCommon
80 SpecCommon
136 Data.SwaggerSpec
81 Data.SwaggerSpec
137− Data.Swagger.CommonTestTypes
138 Data.Swagger.ParamSchemaSpec
82 Data.Swagger.ParamSchemaSpec
139 Data.Swagger.SchemaSpec
83 Data.Swagger.SchemaSpec
140 Data.Swagger.Schema.ValidationSpec
84 Data.Swagger.Schema.ValidationSpec
141− Data.Swagger.Schema.GeneratorSpec
142 default-language: Haskell2010
85 default-language: Haskell2010
143
86
144−test-suite doctests
87+test-suite doctest
145− -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes
146− build-depends: base, doctest, Glob, QuickCheck
88+ build-depends: base, doctest, Glob
147 default-language: Haskell2010
89 default-language: Haskell2010
148 hs-source-dirs: test
90 hs-source-dirs: test
149− main-is: doctests.hs
91+ main-is: DocTest.hs
150 type: exitcode-stdio-1.0
92 type: exitcode-stdio-1.0
151
93
152source-repository head
94source-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+84−10
@@ -1,29 +1,22 @@
1{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE QuasiQuotes #-}
4{-# LANGUAGE QuasiQuotes #-}
6−{-# LANGUAGE OverloadedStrings #-}
7module Data.Swagger.ParamSchemaSpec where
5module Data.Swagger.ParamSchemaSpec where
8
6
9import Data.Aeson
7import Data.Aeson
10−import Data.Aeson.QQ.Simple
8+import Data.Aeson.QQ
11import Data.Char
9import Data.Char
12import Data.Proxy
10import Data.Proxy
13import GHC.Generics
11import GHC.Generics
14
12
15import Data.Swagger
13import Data.Swagger
16−import Data.Swagger.Internal (SwaggerKind(..))
17
14
18−import Data.Swagger.CommonTestTypes
19import SpecCommon
15import SpecCommon
20import Test.Hspec
16import Test.Hspec
21−import Data.Time.LocalTime
22−
23−import qualified Data.HashMap.Strict as HM
24
17
25checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
18checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
26−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
19+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js
27
20
28spec :: Spec
21spec :: Spec
29spec = do
22spec = do
@@ -34,7 +27,88 @@ spec = do
34 context "Unary records" $ do
27 context "Unary records" $ do
35 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
28 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
36 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
29 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
38
30
39main :: IO ()
31main :: IO ()
40main = hspec spec
32main = hspec spec
33+
34+-- ========================================================================
35+-- Unit type
36+-- ========================================================================
37+
38+data Unit = Unit deriving (Generic)
39+instance ToParamSchema Unit
40+
41+unitSchemaJSON :: Value
42+unitSchemaJSON = [aesonQQ|
43+{
44+ "type": "string",
45+ "enum": ["Unit"]
46+}
47+|]
48+
49+-- ========================================================================
50+-- Color (enum)
51+-- ========================================================================
52+data Color
53+ = Red
54+ | Green
55+ | Blue
56+ deriving (Generic)
57+instance ToParamSchema Color
58+
59+colorSchemaJSON :: Value
60+colorSchemaJSON = [aesonQQ|
61+{
62+ "type": "string",
63+ "enum": ["Red", "Green", "Blue"]
64+}
65+|]
66+
67+-- ========================================================================
68+-- Status (constructorTagModifier)
69+-- ========================================================================
70+
71+data Status = StatusOk | StatusError deriving (Generic)
72+
73+instance ToParamSchema Status where
74+ toParamSchema = genericToParamSchema defaultSchemaOptions
75+ { constructorTagModifier = map toLower . drop (length "Status") }
76+
77+statusSchemaJSON :: Value
78+statusSchemaJSON = [aesonQQ|
79+{
80+ "type": "string",
81+ "enum": ["ok", "error"]
82+}
83+|]
84+
85+-- ========================================================================
86+-- Email (newtype with unwrapUnaryRecords set to True)
87+-- ========================================================================
88+
89+newtype Email = Email { getEmail :: String }
90+ deriving (Generic)
91+instance ToParamSchema Email
92+
93+emailSchemaJSON :: Value
94+emailSchemaJSON = [aesonQQ|
95+{
96+ "type": "string"
97+}
98+|]
99+
100+-- ========================================================================
101+-- UserId (non-record newtype)
102+-- ========================================================================
103+
104+newtype UserId = UserId Integer
105+ deriving (Generic)
106+instance ToParamSchema UserId
107+
108+userIdSchemaJSON :: Value
109+userIdSchemaJSON = [aesonQQ|
110+{
111+ "type": "integer"
112+}
113+|]
114+
test/Data/Swagger/Schema/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.hs+65−130
@@ -1,50 +1,43 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE PackageImports #-}
3+{-# LANGUAGE PackageImports #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# OPTIONS_GHC -fno-warn-orphans #-}
7module Data.Swagger.Schema.ValidationSpec where
4module Data.Swagger.Schema.ValidationSpec where
8
5
9−import Control.Applicative
6+import Control.Applicative
10−import Control.Lens ((&), (.~), (?~))
11−import Data.Aeson
7+import Data.Aeson
12−import Data.Aeson.Types
8+import Data.Aeson.Types
13−import Data.Hashable (Hashable)
9+import Data.Int
14−import Data.HashMap.Strict (HashMap)
10+import Data.IntMap (IntMap)
15−import qualified Data.HashMap.Strict as HashMap
11+import qualified Data.IntMap as IntMap
12+import Data.IntSet (IntSet)
13+import Data.Hashable (Hashable)
16−import "unordered-containers" Data.HashSet (HashSet)
14+import "unordered-containers" Data.HashSet (HashSet)
17import qualified "unordered-containers" Data.HashSet as HashSet
15import qualified "unordered-containers" Data.HashSet as HashSet
18−import Data.Int
16+import Data.HashMap.Strict (HashMap)
19−import Data.IntMap (IntMap)
17+import qualified Data.HashMap.Strict as HashMap
20−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
21−import Data.Map (Map, fromList)
18+import Data.Map (Map)
22−import Data.Monoid (mempty)
19+import qualified Data.Map as Map
23−import Data.Proxy
20+import Data.Proxy
24−import Data.Set (Set)
21+import Data.Time
25−import qualified Data.Text as T
22+import qualified Data.Text as T
26−import qualified Data.Text.Lazy as TL
23+import qualified Data.Text.Lazy as TL
27−import Data.Time
24+import Data.Set (Set)
28−import Data.Version (Version)
25+import qualified Data.Set as Set
29−import Data.Word
26+import Data.Word
30−import GHC.Generics
27+import GHC.Generics
31−
28+
32−import Data.Swagger
29+import Data.Swagger
33−import Data.Swagger.Declare
30+import Data.Swagger.Declare
34−
31+import Data.Swagger.Schema.Validation
35−import Test.Hspec
32+
33+import SpecCommon
36−import Test.Hspec.QuickCheck
34+import Test.Hspec
37−import Test.QuickCheck
35+import Test.Hspec.QuickCheck
38−import Test.QuickCheck.Instances ()
36+import Test.QuickCheck
39
37
40shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
38shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
41shouldValidate _ x = validateToJSON x == []
39shouldValidate _ x = validateToJSON x == []
42
40
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−
48spec :: Spec
41spec :: Spec
49spec = do
42spec = do
50 describe "Validation" $ do
43 describe "Validation" $ do
@@ -73,7 +66,6 @@ spec = do
73 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
66 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
74 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
67 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
75 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
68 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))
69 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
78 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
70 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
79 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
71 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
@@ -83,7 +75,6 @@ spec = do
83 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
75 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
84 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
76 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))
77 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))
78 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
88 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
79 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))
80 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
@@ -92,16 +83,6 @@ spec = do
92 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
83 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
93 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
84 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
94 prop "Light" $ shouldValidate (Proxy :: Proxy Light)
85 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
86
106main :: IO ()
87main :: IO ()
107main = hspec spec
88main = hspec spec
@@ -121,13 +102,6 @@ instance ToSchema Person
121instance Arbitrary Person where
102instance Arbitrary Person where
122 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
103 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
123
104
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-- ========================================================================
105-- ========================================================================
132-- Color (enum)
106-- Color (enum)
133-- ========================================================================
107-- ========================================================================
@@ -139,11 +113,6 @@ instance ToSchema Color
139instance Arbitrary Color where
113instance Arbitrary Color where
140 arbitrary = arbitraryBoundedEnum
114 arbitrary = arbitraryBoundedEnum
141
115
142−invalidColorToJSON :: Color -> Value
143−invalidColorToJSON Red = toJSON "red"
144−invalidColorToJSON Green = toJSON "green"
145−invalidColorToJSON Blue = toJSON "blue"
146−
147-- ========================================================================
116-- ========================================================================
148-- Paint (record with bounded enum property)
117-- Paint (record with bounded enum property)
149-- ========================================================================
118-- ========================================================================
@@ -157,9 +126,6 @@ instance ToSchema Paint
157instance Arbitrary Paint where
126instance Arbitrary Paint where
158 arbitrary = Paint <$> arbitrary
127 arbitrary = Paint <$> arbitrary
159
128
160−invalidPaintToJSON :: Paint -> Value
161−invalidPaintToJSON = toJSON . color
162−
163-- ========================================================================
129-- ========================================================================
164-- MyRoseTree (custom datatypeNameModifier)
130-- MyRoseTree (custom datatypeNameModifier)
165-- ========================================================================
131-- ========================================================================
@@ -188,8 +154,7 @@ instance Arbitrary MyRoseTree where
188
154
189data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
155data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
190
156
191−instance ToSchema Light where
157+instance ToSchema Light
192− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
193
158
194instance ToJSON Light where
159instance ToJSON Light where
195 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
160 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
@@ -201,78 +166,48 @@ instance Arbitrary Light where
201 , LightColor <$> arbitrary
166 , LightColor <$> arbitrary
202 ]
167 ]
203
168
204−invalidLightToJSON :: Light -> Value
169+-- Arbitrary instances for common types
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
170
223−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
171+#if MIN_VERSION_QuickCheck(2,8,2)
224− deriving (Show, Generic)
172+#else
173+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where
174+ arbitrary = Map.fromList <$> arbitrary
225
175
226−instance ToJSON ButtonImages where
176+instance Arbitrary a => Arbitrary (IntMap a) where
227− toJSON = toJSON . getButtonImages
177+ arbitrary = IntMap.fromList <$> arbitrary
228
178
229−instance ToSchema ButtonImages where
179+instance (Ord a, Arbitrary a) => Arbitrary (Set a) where
230− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
180+ arbitrary = Set.fromList <$> arbitrary
231− declareSchemaBoundedEnumKeyMapping
181+#endif
232
182
233−invalidButtonImagesToJSON :: ButtonImages -> Value
183+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
234−invalidButtonImagesToJSON = genericToJSON defaultOptions
184+ arbitrary = HashMap.fromList <$> arbitrary
235
185
236−instance Arbitrary ButtonImages where
186+instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where
237− arbitrary = ButtonImages <$> arbitrary
187+ arbitrary = HashSet.fromList <$> arbitrary
238
188
239−-- ========================================================================
189+instance Arbitrary T.Text where
240−-- FreeForm (wraps a raw JSON Value)
190+ arbitrary = T.pack <$> arbitrary
241−-- ========================================================================
242
191
243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
192+instance Arbitrary TL.Text where
244− deriving (Show, Generic)
193+ arbitrary = TL.pack <$> arbitrary
245
194
246−instance ToJSON FreeForm where
195+instance Arbitrary Day where
247− toJSON = toJSON . jsonContent
196+ arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary
248
197
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
198+instance Arbitrary LocalTime where
255− arbitrary = (FreeForm . fromList) <$> genObj
199+ arbitrary = LocalTime
256− where
200+ <$> arbitrary
257− genObj = listOf $ do
201+ <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))
258− k <- arbitrary
259− v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]
260− pure (k, v)
261
202
262instance Eq ZonedTime where
203instance Eq ZonedTime where
263 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
204 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
264
205
265−-- ========================================================================
206+instance Arbitrary ZonedTime where
266−-- Arbitrary instance for Data.Aeson.Value
207+ arbitrary = ZonedTime
267−-- ========================================================================
208+ <$> arbitrary
209+ <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))
210+
211+instance Arbitrary UTCTime where
212+ arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))
268
213
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+513−25
@@ -7,23 +7,22 @@ module Data.Swagger.SchemaSpec where
7import Prelude ()
7import Prelude ()
8import Prelude.Compat
8import Prelude.Compat
9
9
10−import Control.Lens ((^.))
10+import Data.Aeson
11−import Data.Aeson (Value)
11+import Data.Aeson.QQ
12+import Data.Char
12−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
13+import qualified Data.HashMap.Strict as HashMap
13import Data.Proxy
14import Data.Proxy
14import Data.Set (Set)
15import Data.Set (Set)
16+import qualified Data.Set as Set
15import qualified Data.Text as Text
17import qualified Data.Text as Text
18+import GHC.Generics
16
19
17import Data.Swagger
20import Data.Swagger
18import Data.Swagger.Declare
21import Data.Swagger.Declare
19
22
20−import Data.Swagger.CommonTestTypes
21import SpecCommon
23import SpecCommon
22import Test.Hspec
24import Test.Hspec
23
25
24−import qualified Data.HashMap.Strict as HM
25−import Data.Time.LocalTime
26−
27checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
26checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
28checkToSchema proxy js = toSchema proxy <=> js
27checkToSchema proxy js = toSchema proxy <=> js
29
28
@@ -35,17 +34,10 @@ checkSchemaName sname proxy =
35checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
34checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
36checkDefs proxy names =
35checkDefs proxy names =
37 it ("uses these definitions " ++ show names) $
36 it ("uses these definitions " ++ show names) $
38− InsOrdHashMap.keys defs `shouldBe` map Text.pack names
37+ Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)
39 where
38 where
40 defs = execDeclare (declareNamedSchema proxy) mempty
39 defs = execDeclare (declareNamedSchema proxy) mempty
41
40
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−
49checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
41checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
50checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
42checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
51
43
@@ -66,9 +58,6 @@ spec = do
66 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
58 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
67 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
59 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
68 context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
60 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
72 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
61 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
73 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
62 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
74 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
63 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
@@ -77,10 +66,8 @@ spec = do
77 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
66 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
78 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
67 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
79 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
68 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
80− context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
81 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
69 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
82 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
70 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
84 context "Sum types" $ do
71 context "Sum types" $ do
85 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
72 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
86 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
73 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
@@ -96,7 +83,6 @@ spec = do
96 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
83 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
97 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
84 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
98 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
85 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
99− context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]
100 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
86 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
101 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
87 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
102 describe "Inlining Schemas" $ do
88 describe "Inlining Schemas" $ do
@@ -105,10 +91,512 @@ spec = do
105 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
91 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
106 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
92 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
107 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
93 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
112
94
113main :: IO ()
95main :: IO ()
114main = hspec spec
96main = hspec spec
97+
98+-- ========================================================================
99+-- Person (simple record with optional fields)
100+-- ========================================================================
101+data Person = Person
102+ { name :: String
103+ , phone :: Integer
104+ , email :: Maybe String
105+ } deriving (Generic)
106+
107+instance ToSchema Person
108+
109+personSchemaJSON :: Value
110+personSchemaJSON = [aesonQQ|
111+{
112+ "type": "object",
113+ "properties":
114+ {
115+ "name": { "type": "string" },
116+ "phone": { "type": "integer" },
117+ "email": { "type": "string" }
118+ },
119+ "required": ["name", "phone"]
120+}
121+|]
122+
123+-- ========================================================================
124+-- ISPair (non-record product data type)
125+-- ========================================================================
126+data ISPair = ISPair Integer String
127+ deriving (Generic)
128+
129+instance ToSchema ISPair
130+
131+ispairSchemaJSON :: Value
132+ispairSchemaJSON = [aesonQQ|
133+{
134+ "type": "array",
135+ "items":
136+ [
137+ { "type": "integer" },
138+ { "type": "string" }
139+ ]
140+}
141+|]
142+
143+-- ========================================================================
144+-- Point (record data type with custom fieldLabelModifier)
145+-- ========================================================================
146+data Point = Point
147+ { pointX :: Double
148+ , pointY :: Double
149+ } deriving (Generic)
150+
151+instance ToSchema Point where
152+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
153+ { fieldLabelModifier = map toLower . drop (length "point") }
154+
155+pointSchemaJSON :: Value
156+pointSchemaJSON = [aesonQQ|
157+{
158+ "type": "object",
159+ "properties":
160+ {
161+ "x": { "type": "number", "format": "double" },
162+ "y": { "type": "number", "format": "double" }
163+ },
164+ "required": ["x", "y"]
165+}
166+|]
167+
168+
169+-- ========================================================================
170+-- Color (enum)
171+-- ========================================================================
172+data Color
173+ = Red
174+ | Green
175+ | Blue
176+ deriving (Generic)
177+instance ToSchema Color
178+
179+colorSchemaJSON :: Value
180+colorSchemaJSON = [aesonQQ|
181+{
182+ "type": "string",
183+ "enum": ["Red", "Green", "Blue"]
184+}
185+|]
186+
187+-- ========================================================================
188+-- Shade (paramSchemaToNamedSchema)
189+-- ========================================================================
190+
191+data Shade = Dim | Bright deriving (Generic)
192+instance ToParamSchema Shade
193+
194+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
195+
196+shadeSchemaJSON :: Value
197+shadeSchemaJSON = [aesonQQ|
198+{
199+ "type": "string",
200+ "enum": ["Dim", "Bright"]
201+}
202+|]
203+
204+-- ========================================================================
205+-- Paint (record with bounded enum property)
206+-- ========================================================================
207+
208+newtype Paint = Paint { color :: Color }
209+ deriving (Generic)
210+instance ToSchema Paint
211+
212+paintSchemaJSON :: Value
213+paintSchemaJSON = [aesonQQ|
214+{
215+ "type": "object",
216+ "properties":
217+ {
218+ "color":
219+ {
220+ "$ref": "#/definitions/Color"
221+ }
222+ },
223+ "required": ["color"]
224+}
225+|]
226+
227+paintInlinedSchemaJSON :: Value
228+paintInlinedSchemaJSON = [aesonQQ|
229+{
230+ "type": "object",
231+ "properties":
232+ {
233+ "color":
234+ {
235+ "type": "string",
236+ "enum": ["Red", "Green", "Blue"]
237+ }
238+ },
239+ "required": ["color"]
240+}
241+|]
242+
243+-- ========================================================================
244+-- Email (newtype with unwrapUnaryRecords set to True)
245+-- ========================================================================
246+
247+newtype Email = Email { getEmail :: String }
248+ deriving (Generic)
249+
250+instance ToSchema Email where
251+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
252+ { unwrapUnaryRecords = True }
253+
254+emailSchemaJSON :: Value
255+emailSchemaJSON = [aesonQQ|
256+{
257+ "type": "string"
258+}
259+|]
260+
261+-- ========================================================================
262+-- UserId (non-record newtype)
263+-- ========================================================================
264+
265+newtype UserId = UserId Integer
266+ deriving (Eq, Ord, Generic)
267+instance ToSchema UserId
268+
269+userIdSchemaJSON :: Value
270+userIdSchemaJSON = [aesonQQ|
271+{
272+ "type": "integer"
273+}
274+|]
275+
276+-- ========================================================================
277+-- UserGroup (set newtype)
278+-- ========================================================================
279+
280+newtype UserGroup = UserGroup (Set UserId)
281+ deriving (Generic)
282+instance ToSchema UserGroup
283+
284+userGroupSchemaJSON :: Value
285+userGroupSchemaJSON = [aesonQQ|
286+{
287+ "type": "array",
288+ "items": { "$ref": "#/definitions/UserId" },
289+ "uniqueItems": true
290+}
291+|]
292+
293+-- ========================================================================
294+-- Player (record newtype)
295+-- ========================================================================
296+
297+newtype Player = Player
298+ { position :: Point
299+ } deriving (Generic)
300+instance ToSchema Player
301+
302+playerSchemaJSON :: Value
303+playerSchemaJSON = [aesonQQ|
304+{
305+ "type": "object",
306+ "properties":
307+ {
308+ "position":
309+ {
310+ "$ref": "#/definitions/Point"
311+ }
312+ },
313+ "required": ["position"]
314+}
315+|]
316+
317+-- ========================================================================
318+-- MyRoseTree (custom datatypeNameModifier)
319+-- ========================================================================
320+
321+data MyRoseTree = MyRoseTree
322+ { root :: String
323+ , trees :: [MyRoseTree]
324+ } deriving (Generic)
325+
326+instance ToSchema MyRoseTree where
327+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
328+ { datatypeNameModifier = drop (length "My") }
329+
330+myRoseTreeSchemaJSON :: Value
331+myRoseTreeSchemaJSON = [aesonQQ|
332+{
333+ "type": "object",
334+ "properties":
335+ {
336+ "root": { "type": "string" },
337+ "trees":
338+ {
339+ "type": "array",
340+ "items":
341+ {
342+ "$ref": "#/definitions/RoseTree"
343+ }
344+ }
345+ },
346+ "required": ["root", "trees"]
347+}
348+|]
349+
350+-- ========================================================================
351+-- Inlined (newtype for inlining schemas)
352+-- ========================================================================
353+
354+newtype Inlined a = Inlined { getInlined :: a }
355+
356+instance ToSchema a => ToSchema (Inlined a) where
357+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
358+ where
359+ unname (NamedSchema _ s) = NamedSchema Nothing s
360+
361+newtype Players = Players [Inlined Player]
362+ deriving (Generic)
363+instance ToSchema Players
364+
365+playersSchemaJSON :: Value
366+playersSchemaJSON = [aesonQQ|
367+{
368+ "type": "array",
369+ "items":
370+ {
371+ "type": "object",
372+ "properties":
373+ {
374+ "position":
375+ {
376+ "$ref": "#/definitions/Point"
377+ }
378+ },
379+ "required": ["position"]
380+ }
381+}
382+|]
383+
384+-- ========================================================================
385+-- Status (sum type with unary constructors)
386+-- ========================================================================
387+
388+data Status
389+ = StatusOk String
390+ | StatusError String
391+ deriving (Generic)
392+
393+instance ToSchema Status where
394+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
395+ { constructorTagModifier = map toLower . drop (length "Status") }
396+
397+statusSchemaJSON :: Value
398+statusSchemaJSON = [aesonQQ|
399+{
400+ "type": "object",
401+ "properties":
402+ {
403+ "ok": { "type": "string" },
404+ "error": { "type": "string" }
405+ },
406+ "maxProperties": 1,
407+ "minProperties": 1
408+}
409+|]
410+
411+-- ========================================================================
412+-- Unit type
413+-- ========================================================================
414+
415+data Unit = Unit deriving (Generic)
416+instance ToSchema Unit
417+
418+unitSchemaJSON :: Value
419+unitSchemaJSON = [aesonQQ|
420+{
421+ "type": "string",
422+ "enum": ["Unit"]
423+}
424+|]
425+
426+
427+-- ========================================================================
428+-- Character (sum type with ref and record in alternative)
429+-- ========================================================================
430+
431+data Character
432+ = PC Player
433+ | NPC { npcName :: String, npcPosition :: Point }
434+ deriving (Generic)
435+instance ToSchema Character
436+
437+characterSchemaJSON :: Value
438+characterSchemaJSON = [aesonQQ|
439+{
440+ "type": "object",
441+ "properties":
442+ {
443+ "PC": { "$ref": "#/definitions/Player" },
444+ "NPC":
445+ {
446+ "type": "object",
447+ "properties":
448+ {
449+ "npcName": { "type": "string" },
450+ "npcPosition": { "$ref": "#/definitions/Point" }
451+ },
452+ "required": ["npcName", "npcPosition"]
453+ }
454+ },
455+ "maxProperties": 1,
456+ "minProperties": 1
457+}
458+|]
459+
460+characterInlinedSchemaJSON :: Value
461+characterInlinedSchemaJSON = [aesonQQ|
462+{
463+ "type": "object",
464+ "properties":
465+ {
466+ "PC":
467+ {
468+ "type": "object",
469+ "properties":
470+ {
471+ "position":
472+ {
473+ "type": "object",
474+ "properties":
475+ {
476+ "x": { "type": "number", "format": "double" },
477+ "y": { "type": "number", "format": "double" }
478+ },
479+ "required": ["x", "y"]
480+ }
481+ },
482+ "required": ["position"]
483+ },
484+ "NPC":
485+ {
486+ "type": "object",
487+ "properties":
488+ {
489+ "npcName": { "type": "string" },
490+ "npcPosition":
491+ {
492+ "type": "object",
493+ "properties":
494+ {
495+ "x": { "type": "number", "format": "double" },
496+ "y": { "type": "number", "format": "double" }
497+ },
498+ "required": ["x", "y"]
499+ }
500+ },
501+ "required": ["npcName", "npcPosition"]
502+ }
503+ },
504+ "maxProperties": 1,
505+ "minProperties": 1
506+}
507+|]
508+
509+characterInlinedPlayerSchemaJSON :: Value
510+characterInlinedPlayerSchemaJSON = [aesonQQ|
511+{
512+ "type": "object",
513+ "properties":
514+ {
515+ "PC":
516+ {
517+ "type": "object",
518+ "properties":
519+ {
520+ "position":
521+ {
522+ "$ref": "#/definitions/Point"
523+ }
524+ },
525+ "required": ["position"]
526+ },
527+ "NPC":
528+ {
529+ "type": "object",
530+ "properties":
531+ {
532+ "npcName": { "type": "string" },
533+ "npcPosition": { "$ref": "#/definitions/Point" }
534+ },
535+ "required": ["npcName", "npcPosition"]
536+ }
537+ },
538+ "maxProperties": 1,
539+ "minProperties": 1
540+}
541+|]
542+
543+-- ========================================================================
544+-- Light (sum type with unwrapUnaryRecords)
545+-- ========================================================================
546+
547+data Light
548+ = NoLight
549+ | LightFreq Double
550+ | LightColor Color
551+ | LightWaveLength { waveLength :: Double }
552+ deriving (Generic)
553+
554+instance ToSchema Light where
555+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
556+ { unwrapUnaryRecords = True }
557+
558+lightSchemaJSON :: Value
559+lightSchemaJSON = [aesonQQ|
560+{
561+ "type": "object",
562+ "properties":
563+ {
564+ "NoLight": { "type": "array", "items": [] },
565+ "LightFreq": { "type": "number", "format": "double" },
566+ "LightColor": { "$ref": "#/definitions/Color" },
567+ "LightWaveLength": { "type": "number", "format": "double" }
568+ },
569+ "maxProperties": 1,
570+ "minProperties": 1
571+}
572+|]
573+
574+lightInlinedSchemaJSON :: Value
575+lightInlinedSchemaJSON = [aesonQQ|
576+{
577+ "type": "object",
578+ "properties":
579+ {
580+ "NoLight": { "type": "array", "items": [] },
581+ "LightFreq": { "type": "number", "format": "double" },
582+ "LightColor":
583+ {
584+ "type": "string",
585+ "enum": ["Red", "Green", "Blue"]
586+ },
587+ "LightWaveLength": { "type": "number", "format": "double" }
588+ },
589+ "maxProperties": 1,
590+ "minProperties": 1
591+}
592+|]
593+
594+-- ========================================================================
595+-- ResourceId (series of newtypes)
596+-- ========================================================================
597+
598+newtype Id = Id String deriving (Generic)
599+instance ToSchema Id
600+
601+newtype ResourceId = ResourceId Id deriving (Generic)
602+instance ToSchema ResourceId
test/Data/SwaggerSpec.hs+326−420
@@ -10,9 +10,9 @@ import Prelude.Compat
10import Control.Lens
10import Control.Lens
11
11
12import Data.Aeson
12import Data.Aeson
13−import Data.Aeson.QQ.Simple
13+import Data.Aeson.QQ
14import Data.HashMap.Strict (HashMap)
14import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashSet.InsOrd as InsOrdHS
15+import qualified Data.Set as Set
16import Data.Text (Text)
16import Data.Text (Text)
17
17
18import Data.Swagger
18import Data.Swagger
@@ -21,14 +21,6 @@ import Test.Hspec hiding (example)
21
21
22spec :: Spec
22spec :: Spec
23spec = do
23spec = 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
32 describe "License Object" $ licenseExample <=> licenseExampleJSON
24 describe "License Object" $ licenseExample <=> licenseExampleJSON
33 describe "Contact Object" $ contactExample <=> contactExampleJSON
25 describe "Contact Object" $ contactExample <=> contactExampleJSON
34 describe "Info Object" $ infoExample <=> infoExampleJSON
26 describe "Info Object" $ infoExample <=> infoExampleJSON
@@ -37,14 +29,11 @@ spec = do
37 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
29 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
38 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
30 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
39 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
31 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
40− context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON
41 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
32 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
42 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
33 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
43 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
34 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
44 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
35 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
45 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
36 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON
47− describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
48 describe "Swagger Object" $ do
37 describe "Swagger Object" $ do
49 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
38 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
50 context "PetStore Example" $
39 context "PetStore Example" $
@@ -128,7 +117,7 @@ licenseExampleJSON = [aesonQQ|
128
117
129operationExample :: Operation
118operationExample :: Operation
130operationExample = mempty
119operationExample = mempty
131− & tags .~ InsOrdHS.fromList ["pet"]
120+ & tags .~ Set.fromList ["pet"]
132 & summary ?~ "Updates a pet in the store with form data"
121 & summary ?~ "Updates a pet in the store with form data"
133 & description ?~ ""
122 & description ?~ ""
134 & operationId ?~ "updatePetWithForm"
123 & operationId ?~ "updatePetWithForm"
@@ -159,7 +148,7 @@ operationExample = mempty
159 stringSchema :: ParamLocation -> ParamOtherSchema
148 stringSchema :: ParamLocation -> ParamOtherSchema
160 stringSchema loc = mempty
149 stringSchema loc = mempty
161 & in_ .~ loc
150 & in_ .~ loc
162− & type_ ?~ SwaggerString
151+ & type_ .~ SwaggerString
163
152
164operationExampleJSON :: Value
153operationExampleJSON :: Value
165operationExampleJSON = [aesonQQ|
154operationExampleJSON = [aesonQQ|
@@ -225,7 +214,7 @@ operationExampleJSON = [aesonQQ|
225
214
226schemaPrimitiveExample :: Schema
215schemaPrimitiveExample :: Schema
227schemaPrimitiveExample = mempty
216schemaPrimitiveExample = mempty
228− & type_ ?~ SwaggerString
217+ & type_ .~ SwaggerString
229 & format ?~ "email"
218 & format ?~ "email"
230
219
231schemaPrimitiveExampleJSON :: Value
220schemaPrimitiveExampleJSON :: Value
@@ -238,14 +227,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|
238
227
239schemaSimpleModelExample :: Schema
228schemaSimpleModelExample :: Schema
240schemaSimpleModelExample = mempty
229schemaSimpleModelExample = mempty
241− & type_ ?~ SwaggerObject
230+ & type_ .~ SwaggerObject
242 & required .~ [ "name" ]
231 & required .~ [ "name" ]
243 & properties .~
232 & properties .~
244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))
233+ [ ("name", Inline (mempty & type_ .~ SwaggerString))
245 , ("address", Ref (Reference "Address"))
234 , ("address", Ref (Reference "Address"))
246 , ("age", Inline $ mempty
235 , ("age", Inline $ mempty
247 & minimum_ ?~ 0
236 & minimum_ ?~ 0
248− & type_ ?~ SwaggerInteger
237+ & type_ .~ SwaggerInteger
249 & format ?~ "int32" ) ]
238 & format ?~ "int32" ) ]
250
239
251schemaSimpleModelExampleJSON :: Value
240schemaSimpleModelExampleJSON :: Value
@@ -273,8 +262,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
273
262
274schemaModelDictExample :: Schema
263schemaModelDictExample :: Schema
275schemaModelDictExample = mempty
264schemaModelDictExample = mempty
276− & type_ ?~ SwaggerObject
265+ & type_ .~ SwaggerObject
277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
266+ & additionalProperties ?~ (mempty & type_ .~ SwaggerString)
278
267
279schemaModelDictExampleJSON :: Value
268schemaModelDictExampleJSON :: Value
280schemaModelDictExampleJSON = [aesonQQ|
269schemaModelDictExampleJSON = [aesonQQ|
@@ -286,28 +275,15 @@ schemaModelDictExampleJSON = [aesonQQ|
286}
275}
287|]
276|]
288
277
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−
302schemaWithExampleExample :: Schema
278schemaWithExampleExample :: Schema
303schemaWithExampleExample = mempty
279schemaWithExampleExample = mempty
304− & type_ ?~ SwaggerObject
280+ & type_ .~ SwaggerObject
305 & properties .~
281 & properties .~
306 [ ("id", Inline $ mempty
282 [ ("id", Inline $ mempty
307− & type_ ?~ SwaggerInteger
283+ & type_ .~ SwaggerInteger
308 & format ?~ "int64" )
284 & format ?~ "int64" )
309 , ("name", Inline $ mempty
285 , ("name", Inline $ mempty
310− & type_ ?~ SwaggerString) ]
286+ & type_ .~ SwaggerString) ]
311 & required .~ [ "name" ]
287 & required .~ [ "name" ]
312 & example ?~ [aesonQQ|
288 & example ?~ [aesonQQ|
313 {
289 {
@@ -346,19 +322,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
346definitionsExample :: HashMap Text Schema
322definitionsExample :: HashMap Text Schema
347definitionsExample =
323definitionsExample =
348 [ ("Category", mempty
324 [ ("Category", mempty
349− & type_ ?~ SwaggerObject
325+ & type_ .~ SwaggerObject
350 & properties .~
326 & properties .~
351 [ ("id", Inline $ mempty
327 [ ("id", Inline $ mempty
352− & type_ ?~ SwaggerInteger
328+ & type_ .~ SwaggerInteger
353 & format ?~ "int64")
329 & format ?~ "int64")
354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
330+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )
355 , ("Tag", mempty
331 , ("Tag", mempty
356− & type_ ?~ SwaggerObject
332+ & type_ .~ SwaggerObject
357 & properties .~
333 & properties .~
358 [ ("id", Inline $ mempty
334 [ ("id", Inline $ mempty
359− & type_ ?~ SwaggerInteger
335+ & type_ .~ SwaggerInteger
360 & format ?~ "int64")
336 & format ?~ "int64")
361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
337+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]
362
338
363definitionsExampleJSON :: Value
339definitionsExampleJSON :: Value
364definitionsExampleJSON = [aesonQQ|
340definitionsExampleJSON = [aesonQQ|
@@ -402,7 +378,7 @@ paramsDefinitionExample =
402 & required ?~ True
378 & required ?~ True
403 & schema .~ ParamOther (mempty
379 & schema .~ ParamOther (mempty
404 & in_ .~ ParamQuery
380 & in_ .~ ParamQuery
405− & type_ ?~ SwaggerInteger
381+ & type_ .~ SwaggerInteger
406 & format ?~ "int32" ))
382 & format ?~ "int32" ))
407 , ("limitParam", mempty
383 , ("limitParam", mempty
408 & name .~ "limit"
384 & name .~ "limit"
@@ -410,7 +386,7 @@ paramsDefinitionExample =
410 & required ?~ True
386 & required ?~ True
411 & schema .~ ParamOther (mempty
387 & schema .~ ParamOther (mempty
412 & in_ .~ ParamQuery
388 & in_ .~ ParamQuery
413− & type_ ?~ SwaggerInteger
389+ & type_ .~ SwaggerInteger
414 & format ?~ "int32" )) ]
390 & format ?~ "int32" )) ]
415
391
416paramsDefinitionExampleJSON :: Value
392paramsDefinitionExampleJSON :: Value
@@ -460,8 +436,8 @@ responsesDefinitionExampleJSON = [aesonQQ|
460-- Responses Definition object
436-- Responses Definition object
461-- =======================================================================
437-- =======================================================================
462
438
463−securityDefinitionsExample :: SecurityDefinitions
439+securityDefinitionsExample :: HashMap Text SecurityScheme
464−securityDefinitionsExample = SecurityDefinitions
440+securityDefinitionsExample =
465 [ ("api_key", SecurityScheme
441 [ ("api_key", SecurityScheme
466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
442 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
467 , _securitySchemeDescription = Nothing })
443 , _securitySchemeDescription = Nothing })
@@ -493,46 +469,6 @@ securityDefinitionsExampleJSON = [aesonQQ|
493}
469}
494|]
470|]
495
471
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−
536-- =======================================================================
472-- =======================================================================
537-- Swagger object
473-- Swagger object
538-- =======================================================================
474-- =======================================================================
@@ -551,18 +487,18 @@ swaggerExample = mempty
551 & at 200 ?~ Inline (mempty
487 & at 200 ?~ Inline (mempty
552 & description .~ "OK"
488 & description .~ "OK"
553 & schema ?~ Inline (mempty
489 & schema ?~ Inline (mempty
554− & type_ ?~ SwaggerObject
490+ & type_ .~ SwaggerObject
555 & example ?~ [aesonQQ|
491 & example ?~ [aesonQQ|
556 {
492 {
557 "created": 100,
493 "created": 100,
558 "description": "get milk"
494 "description": "get milk"
559 } |]
495 } |]
560− & description ?~ "This is some real Todo right here"
496+ & description ?~ "This is some real Todo right here"
561 & properties .~
497 & properties .~
562 [ ("created", Inline $ mempty
498 [ ("created", Inline $ mempty
563− & type_ ?~ SwaggerInteger
499+ & type_ .~ SwaggerInteger
564 & format ?~ "int32")
500 & format ?~ "int32")
565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))
501+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))
566 & produces ?~ MimeList [ "application/json" ]
502 & produces ?~ MimeList [ "application/json" ]
567 & parameters .~
503 & parameters .~
568 [ Inline $ mempty
504 [ Inline $ mempty
@@ -571,8 +507,8 @@ swaggerExample = mempty
571 & description ?~ "TodoId param"
507 & description ?~ "TodoId param"
572 & schema .~ ParamOther (mempty
508 & schema .~ ParamOther (mempty
573 & in_ .~ ParamPath
509 & in_ .~ ParamPath
574− & type_ ?~ SwaggerString ) ]
510+ & type_ .~ SwaggerString ) ]
575− & tags .~ InsOrdHS.fromList [ "todo" ] ))
511+ & tags .~ Set.fromList [ "todo" ] ))
576
512
577swaggerExampleJSON :: Value
513swaggerExampleJSON :: Value
578swaggerExampleJSON = [aesonQQ|
514swaggerExampleJSON = [aesonQQ|
@@ -639,130 +575,130 @@ swaggerExampleJSON = [aesonQQ|
639
575
640petstoreExampleJSON :: Value
576petstoreExampleJSON :: Value
641petstoreExampleJSON = [aesonQQ|
577petstoreExampleJSON = [aesonQQ|
642−{
578+{
643 "swagger":"2.0",
579 "swagger":"2.0",
644− "info":{
580+ "info":{
645 "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.",
581 "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.",
646 "version":"1.0.0",
582 "version":"1.0.0",
647 "title":"Swagger Petstore",
583 "title":"Swagger Petstore",
648 "termsOfService":"http://swagger.io/terms/",
584 "termsOfService":"http://swagger.io/terms/",
649− "contact":{
585+ "contact":{
650 "email":"apiteam@swagger.io"
586 "email":"apiteam@swagger.io"
651 },
587 },
652− "license":{
588+ "license":{
653 "name":"Apache 2.0",
589 "name":"Apache 2.0",
654 "url":"http://www.apache.org/licenses/LICENSE-2.0.html"
590 "url":"http://www.apache.org/licenses/LICENSE-2.0.html"
655 }
591 }
656 },
592 },
657 "host":"petstore.swagger.io",
593 "host":"petstore.swagger.io",
658 "basePath":"/v2",
594 "basePath":"/v2",
659− "tags":[
595+ "tags":[
660− {
596+ {
661 "name":"pet",
597 "name":"pet",
662 "description":"Everything about your Pets",
598 "description":"Everything about your Pets",
663− "externalDocs":{
599+ "externalDocs":{
664 "description":"Find out more",
600 "description":"Find out more",
665 "url":"http://swagger.io"
601 "url":"http://swagger.io"
666 }
602 }
667 },
603 },
668− {
604+ {
669 "name":"store",
605 "name":"store",
670 "description":"Access to Petstore orders"
606 "description":"Access to Petstore orders"
671 },
607 },
672− {
608+ {
673 "name":"user",
609 "name":"user",
674 "description":"Operations about user",
610 "description":"Operations about user",
675− "externalDocs":{
611+ "externalDocs":{
676 "description":"Find out more about our store",
612 "description":"Find out more about our store",
677 "url":"http://swagger.io"
613 "url":"http://swagger.io"
678 }
614 }
679 }
615 }
680 ],
616 ],
681− "schemes":[
617+ "schemes":[
682 "http"
618 "http"
683 ],
619 ],
684− "paths":{
620+ "paths":{
685− "/pet":{
621+ "/pet":{
686− "post":{
622+ "post":{
687− "tags":[
623+ "tags":[
688 "pet"
624 "pet"
689 ],
625 ],
690 "summary":"Add a new pet to the store",
626 "summary":"Add a new pet to the store",
691 "description":"",
627 "description":"",
692 "operationId":"addPet",
628 "operationId":"addPet",
693− "consumes":[
629+ "consumes":[
694 "application/json",
630 "application/json",
695 "application/xml"
631 "application/xml"
696 ],
632 ],
697− "produces":[
633+ "produces":[
698 "application/xml",
634 "application/xml",
699 "application/json"
635 "application/json"
700 ],
636 ],
701− "parameters":[
637+ "parameters":[
702− {
638+ {
703 "in":"body",
639 "in":"body",
704 "name":"body",
640 "name":"body",
705 "description":"Pet object that needs to be added to the store",
641 "description":"Pet object that needs to be added to the store",
706 "required":true,
642 "required":true,
707− "schema":{
643+ "schema":{
708 "$ref":"#/definitions/Pet"
644 "$ref":"#/definitions/Pet"
709 }
645 }
710 }
646 }
711 ],
647 ],
712− "responses":{
648+ "responses":{
713− "405":{
649+ "405":{
714 "description":"Invalid input"
650 "description":"Invalid input"
715 }
651 }
716 },
652 },
717− "security":[
653+ "security":[
718− {
654+ {
719− "petstore_auth":[
655+ "petstore_auth":[
720 "write:pets",
656 "write:pets",
721 "read:pets"
657 "read:pets"
722 ]
658 ]
723 }
659 }
724 ]
660 ]
725 },
661 },
726− "put":{
662+ "put":{
727− "tags":[
663+ "tags":[
728 "pet"
664 "pet"
729 ],
665 ],
730 "summary":"Update an existing pet",
666 "summary":"Update an existing pet",
731 "description":"",
667 "description":"",
732 "operationId":"updatePet",
668 "operationId":"updatePet",
733− "consumes":[
669+ "consumes":[
734 "application/json",
670 "application/json",
735 "application/xml"
671 "application/xml"
736 ],
672 ],
737− "produces":[
673+ "produces":[
738 "application/xml",
674 "application/xml",
739 "application/json"
675 "application/json"
740 ],
676 ],
741− "parameters":[
677+ "parameters":[
742− {
678+ {
743 "in":"body",
679 "in":"body",
744 "name":"body",
680 "name":"body",
745 "description":"Pet object that needs to be added to the store",
681 "description":"Pet object that needs to be added to the store",
746 "required":true,
682 "required":true,
747− "schema":{
683+ "schema":{
748 "$ref":"#/definitions/Pet"
684 "$ref":"#/definitions/Pet"
749 }
685 }
750 }
686 }
751 ],
687 ],
752− "responses":{
688+ "responses":{
753− "400":{
689+ "400":{
754 "description":"Invalid ID supplied"
690 "description":"Invalid ID supplied"
755 },
691 },
756− "404":{
692+ "404":{
757 "description":"Pet not found"
693 "description":"Pet not found"
758 },
694 },
759− "405":{
695+ "405":{
760 "description":"Validation exception"
696 "description":"Validation exception"
761 }
697 }
762 },
698 },
763− "security":[
699+ "security":[
764− {
700+ {
765− "petstore_auth":[
701+ "petstore_auth":[
766 "write:pets",
702 "write:pets",
767 "read:pets"
703 "read:pets"
768 ]
704 ]
@@ -770,28 +706,28 @@ petstoreExampleJSON = [aesonQQ|
770 ]
706 ]
771 }
707 }
772 },
708 },
773− "/pet/findByStatus":{
709+ "/pet/findByStatus":{
774− "get":{
710+ "get":{
775− "tags":[
711+ "tags":[
776 "pet"
712 "pet"
777 ],
713 ],
778 "summary":"Finds Pets by status",
714 "summary":"Finds Pets by status",
779 "description":"Multiple status values can be provided with comma seperated strings",
715 "description":"Multiple status values can be provided with comma seperated strings",
780 "operationId":"findPetsByStatus",
716 "operationId":"findPetsByStatus",
781− "produces":[
717+ "produces":[
782 "application/xml",
718 "application/xml",
783 "application/json"
719 "application/json"
784 ],
720 ],
785− "parameters":[
721+ "parameters":[
786− {
722+ {
787 "name":"status",
723 "name":"status",
788 "in":"query",
724 "in":"query",
789 "description":"Status values that need to be considered for filter",
725 "description":"Status values that need to be considered for filter",
790 "required":true,
726 "required":true,
791 "type":"array",
727 "type":"array",
792− "items":{
728+ "items":{
793 "type":"string",
729 "type":"string",
794− "enum":[
730+ "enum":[
795 "available",
731 "available",
796 "pending",
732 "pending",
797 "sold"
733 "sold"
@@ -801,23 +737,23 @@ petstoreExampleJSON = [aesonQQ|
801 "collectionFormat":"csv"
737 "collectionFormat":"csv"
802 }
738 }
803 ],
739 ],
804− "responses":{
740+ "responses":{
805− "200":{
741+ "200":{
806 "description":"successful operation",
742 "description":"successful operation",
807− "schema":{
743+ "schema":{
808 "type":"array",
744 "type":"array",
809− "items":{
745+ "items":{
810 "$ref":"#/definitions/Pet"
746 "$ref":"#/definitions/Pet"
811 }
747 }
812 }
748 }
813 },
749 },
814− "400":{
750+ "400":{
815 "description":"Invalid status value"
751 "description":"Invalid status value"
816 }
752 }
817 },
753 },
818− "security":[
754+ "security":[
819− {
755+ {
820− "petstore_auth":[
756+ "petstore_auth":[
821 "write:pets",
757 "write:pets",
822 "read:pets"
758 "read:pets"
823 ]
759 ]
@@ -825,48 +761,48 @@ petstoreExampleJSON = [aesonQQ|
825 ]
761 ]
826 }
762 }
827 },
763 },
828− "/pet/findByTags":{
764+ "/pet/findByTags":{
829− "get":{
765+ "get":{
830− "tags":[
766+ "tags":[
831 "pet"
767 "pet"
832 ],
768 ],
833 "summary":"Finds Pets by tags",
769 "summary":"Finds Pets by tags",
834 "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",
770 "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",
835 "operationId":"findPetsByTags",
771 "operationId":"findPetsByTags",
836− "produces":[
772+ "produces":[
837 "application/xml",
773 "application/xml",
838 "application/json"
774 "application/json"
839 ],
775 ],
840− "parameters":[
776+ "parameters":[
841− {
777+ {
842 "name":"tags",
778 "name":"tags",
843 "in":"query",
779 "in":"query",
844 "description":"Tags to filter by",
780 "description":"Tags to filter by",
845 "required":true,
781 "required":true,
846 "type":"array",
782 "type":"array",
847− "items":{
783+ "items":{
848 "type":"string"
784 "type":"string"
849 },
785 },
850 "collectionFormat":"csv"
786 "collectionFormat":"csv"
851 }
787 }
852 ],
788 ],
853− "responses":{
789+ "responses":{
854− "200":{
790+ "200":{
855 "description":"successful operation",
791 "description":"successful operation",
856− "schema":{
792+ "schema":{
857 "type":"array",
793 "type":"array",
858− "items":{
794+ "items":{
859 "$ref":"#/definitions/Pet"
795 "$ref":"#/definitions/Pet"
860 }
796 }
861 }
797 }
862 },
798 },
863− "400":{
799+ "400":{
864 "description":"Invalid tag value"
800 "description":"Invalid tag value"
865 }
801 }
866 },
802 },
867− "security":[
803+ "security":[
868− {
804+ {
869− "petstore_auth":[
805+ "petstore_auth":[
870 "write:pets",
806 "write:pets",
871 "read:pets"
807 "read:pets"
872 ]
808 ]
@@ -874,20 +810,20 @@ petstoreExampleJSON = [aesonQQ|
874 ]
810 ]
875 }
811 }
876 },
812 },
877− "/pet/{petId}":{
813+ "/pet/{petId}":{
878− "get":{
814+ "get":{
879− "tags":[
815+ "tags":[
880 "pet"
816 "pet"
881 ],
817 ],
882 "summary":"Find pet by ID",
818 "summary":"Find pet by ID",
883 "description":"Returns a single pet",
819 "description":"Returns a single pet",
884 "operationId":"getPetById",
820 "operationId":"getPetById",
885− "produces":[
821+ "produces":[
886 "application/xml",
822 "application/xml",
887 "application/json"
823 "application/json"
888 ],
824 ],
889− "parameters":[
825+ "parameters":[
890− {
826+ {
891 "name":"petId",
827 "name":"petId",
892 "in":"path",
828 "in":"path",
893 "description":"ID of pet to return",
829 "description":"ID of pet to return",
@@ -896,42 +832,42 @@ petstoreExampleJSON = [aesonQQ|
896 "format":"int64"
832 "format":"int64"
897 }
833 }
898 ],
834 ],
899− "responses":{
835+ "responses":{
900− "200":{
836+ "200":{
901 "description":"successful operation",
837 "description":"successful operation",
902− "schema":{
838+ "schema":{
903 "$ref":"#/definitions/Pet"
839 "$ref":"#/definitions/Pet"
904 }
840 }
905 },
841 },
906− "400":{
842+ "400":{
907 "description":"Invalid ID supplied"
843 "description":"Invalid ID supplied"
908 },
844 },
909− "404":{
845+ "404":{
910 "description":"Pet not found"
846 "description":"Pet not found"
911 }
847 }
912 },
848 },
913− "security":[
849+ "security":[
914− {
850+ {
915 "api_key": []
851 "api_key": []
916 }
852 }
917 ]
853 ]
918 },
854 },
919− "post":{
855+ "post":{
920− "tags":[
856+ "tags":[
921 "pet"
857 "pet"
922 ],
858 ],
923 "summary":"Updates a pet in the store with form data",
859 "summary":"Updates a pet in the store with form data",
924 "description":"",
860 "description":"",
925 "operationId":"updatePetWithForm",
861 "operationId":"updatePetWithForm",
926− "consumes":[
862+ "consumes":[
927 "application/x-www-form-urlencoded"
863 "application/x-www-form-urlencoded"
928 ],
864 ],
929− "produces":[
865+ "produces":[
930 "application/xml",
866 "application/xml",
931 "application/json"
867 "application/json"
932 ],
868 ],
933− "parameters":[
869+ "parameters":[
934− {
870+ {
935 "name":"petId",
871 "name":"petId",
936 "in":"path",
872 "in":"path",
937 "description":"ID of pet that needs to be updated",
873 "description":"ID of pet that needs to be updated",
@@ -939,14 +875,14 @@ petstoreExampleJSON = [aesonQQ|
939 "type":"integer",
875 "type":"integer",
940 "format":"int64"
876 "format":"int64"
941 },
877 },
942− {
878+ {
943 "name":"name",
879 "name":"name",
944 "in":"formData",
880 "in":"formData",
945 "description":"Updated name of the pet",
881 "description":"Updated name of the pet",
946 "required":false,
882 "required":false,
947 "type":"string"
883 "type":"string"
948 },
884 },
949− {
885+ {
950 "name":"status",
886 "name":"status",
951 "in":"formData",
887 "in":"formData",
952 "description":"Updated status of the pet",
888 "description":"Updated status of the pet",
@@ -954,39 +890,39 @@ petstoreExampleJSON = [aesonQQ|
954 "type":"string"
890 "type":"string"
955 }
891 }
956 ],
892 ],
957− "responses":{
893+ "responses":{
958− "405":{
894+ "405":{
959 "description":"Invalid input"
895 "description":"Invalid input"
960 }
896 }
961 },
897 },
962− "security":[
898+ "security":[
963− {
899+ {
964− "petstore_auth":[
900+ "petstore_auth":[
965 "write:pets",
901 "write:pets",
966 "read:pets"
902 "read:pets"
967 ]
903 ]
968 }
904 }
969 ]
905 ]
970 },
906 },
971− "delete":{
907+ "delete":{
972− "tags":[
908+ "tags":[
973 "pet"
909 "pet"
974 ],
910 ],
975 "summary":"Deletes a pet",
911 "summary":"Deletes a pet",
976 "description":"",
912 "description":"",
977 "operationId":"deletePet",
913 "operationId":"deletePet",
978− "produces":[
914+ "produces":[
979 "application/xml",
915 "application/xml",
980 "application/json"
916 "application/json"
981 ],
917 ],
982− "parameters":[
918+ "parameters":[
983− {
919+ {
984 "name":"api_key",
920 "name":"api_key",
985 "in":"header",
921 "in":"header",
986 "required":false,
922 "required":false,
987 "type":"string"
923 "type":"string"
988 },
924 },
989− {
925+ {
990 "name":"petId",
926 "name":"petId",
991 "in":"path",
927 "in":"path",
992 "description":"Pet id to delete",
928 "description":"Pet id to delete",
@@ -995,14 +931,14 @@ petstoreExampleJSON = [aesonQQ|
995 "format":"int64"
931 "format":"int64"
996 }
932 }
997 ],
933 ],
998− "responses":{
934+ "responses":{
999− "400":{
935+ "400":{
1000 "description":"Invalid pet value"
936 "description":"Invalid pet value"
1001 }
937 }
1002 },
938 },
1003− "security":[
939+ "security":[
1004− {
940+ {
1005− "petstore_auth":[
941+ "petstore_auth":[
1006 "write:pets",
942 "write:pets",
1007 "read:pets"
943 "read:pets"
1008 ]
944 ]
@@ -1010,22 +946,22 @@ petstoreExampleJSON = [aesonQQ|
1010 ]
946 ]
1011 }
947 }
1012 },
948 },
1013− "/pet/{petId}/uploadImage":{
949+ "/pet/{petId}/uploadImage":{
1014− "post":{
950+ "post":{
1015− "tags":[
951+ "tags":[
1016 "pet"
952 "pet"
1017 ],
953 ],
1018 "summary":"uploads an image",
954 "summary":"uploads an image",
1019 "description":"",
955 "description":"",
1020 "operationId":"uploadFile",
956 "operationId":"uploadFile",
1021− "consumes":[
957+ "consumes":[
1022 "multipart/form-data"
958 "multipart/form-data"
1023 ],
959 ],
1024− "produces":[
960+ "produces":[
1025 "application/json"
961 "application/json"
1026 ],
962 ],
1027− "parameters":[
963+ "parameters":[
1028− {
964+ {
1029 "name":"petId",
965 "name":"petId",
1030 "in":"path",
966 "in":"path",
1031 "description":"ID of pet to update",
967 "description":"ID of pet to update",
@@ -1033,14 +969,14 @@ petstoreExampleJSON = [aesonQQ|
1033 "type":"integer",
969 "type":"integer",
1034 "format":"int64"
970 "format":"int64"
1035 },
971 },
1036− {
972+ {
1037 "name":"additionalMetadata",
973 "name":"additionalMetadata",
1038 "in":"formData",
974 "in":"formData",
1039 "description":"Additional data to pass to server",
975 "description":"Additional data to pass to server",
1040 "required":false,
976 "required":false,
1041 "type":"string"
977 "type":"string"
1042 },
978 },
1043− {
979+ {
1044 "name":"file",
980 "name":"file",
1045 "in":"formData",
981 "in":"formData",
1046 "description":"file to upload",
982 "description":"file to upload",
@@ -1048,17 +984,17 @@ petstoreExampleJSON = [aesonQQ|
1048 "type":"file"
984 "type":"file"
1049 }
985 }
1050 ],
986 ],
1051− "responses":{
987+ "responses":{
1052− "200":{
988+ "200":{
1053 "description":"successful operation",
989 "description":"successful operation",
1054− "schema":{
990+ "schema":{
1055 "$ref":"#/definitions/ApiResponse"
991 "$ref":"#/definitions/ApiResponse"
1056 }
992 }
1057 }
993 }
1058 },
994 },
1059− "security":[
995+ "security":[
1060− {
996+ {
1061− "petstore_auth":[
997+ "petstore_auth":[
1062 "write:pets",
998 "write:pets",
1063 "read:pets"
999 "read:pets"
1064 ]
1000 ]
@@ -1066,87 +1002,87 @@ petstoreExampleJSON = [aesonQQ|
1066 ]
1002 ]
1067 }
1003 }
1068 },
1004 },
1069− "/store/inventory":{
1005+ "/store/inventory":{
1070− "get":{
1006+ "get":{
1071− "tags":[
1007+ "tags":[
1072 "store"
1008 "store"
1073 ],
1009 ],
1074 "summary":"Returns pet inventories by status",
1010 "summary":"Returns pet inventories by status",
1075 "description":"Returns a map of status codes to quantities",
1011 "description":"Returns a map of status codes to quantities",
1076 "operationId":"getInventory",
1012 "operationId":"getInventory",
1077− "produces":[
1013+ "produces":[
1078 "application/json"
1014 "application/json"
1079 ],
1015 ],
1080 "parameters": [],
1016 "parameters": [],
1081− "responses":{
1017+ "responses":{
1082− "200":{
1018+ "200":{
1083 "description":"successful operation",
1019 "description":"successful operation",
1084− "schema":{
1020+ "schema":{
1085 "type":"object",
1021 "type":"object",
1086− "additionalProperties":{
1022+ "additionalProperties":{
1087 "type":"integer",
1023 "type":"integer",
1088 "format":"int32"
1024 "format":"int32"
1089 }
1025 }
1090 }
1026 }
1091 }
1027 }
1092 },
1028 },
1093− "security":[
1029+ "security":[
1094− {
1030+ {
1095 "api_key": []
1031 "api_key": []
1096 }
1032 }
1097 ]
1033 ]
1098 }
1034 }
1099 },
1035 },
1100− "/store/order":{
1036+ "/store/order":{
1101− "post":{
1037+ "post":{
1102− "tags":[
1038+ "tags":[
1103 "store"
1039 "store"
1104 ],
1040 ],
1105 "summary":"Place an order for a pet",
1041 "summary":"Place an order for a pet",
1106 "description":"",
1042 "description":"",
1107 "operationId":"placeOrder",
1043 "operationId":"placeOrder",
1108− "produces":[
1044+ "produces":[
1109 "application/xml",
1045 "application/xml",
1110 "application/json"
1046 "application/json"
1111 ],
1047 ],
1112− "parameters":[
1048+ "parameters":[
1113− {
1049+ {
1114 "in":"body",
1050 "in":"body",
1115 "name":"body",
1051 "name":"body",
1116 "description":"order placed for purchasing the pet",
1052 "description":"order placed for purchasing the pet",
1117 "required":true,
1053 "required":true,
1118− "schema":{
1054+ "schema":{
1119 "$ref":"#/definitions/Order"
1055 "$ref":"#/definitions/Order"
1120 }
1056 }
1121 }
1057 }
1122 ],
1058 ],
1123− "responses":{
1059+ "responses":{
1124− "200":{
1060+ "200":{
1125 "description":"successful operation",
1061 "description":"successful operation",
1126− "schema":{
1062+ "schema":{
1127 "$ref":"#/definitions/Order"
1063 "$ref":"#/definitions/Order"
1128 }
1064 }
1129 },
1065 },
1130− "400":{
1066+ "400":{
1131 "description":"Invalid Order"
1067 "description":"Invalid Order"
1132 }
1068 }
1133 }
1069 }
1134 }
1070 }
1135 },
1071 },
1136− "/store/order/{orderId}":{
1072+ "/store/order/{orderId}":{
1137− "get":{
1073+ "get":{
1138− "tags":[
1074+ "tags":[
1139 "store"
1075 "store"
1140 ],
1076 ],
1141 "summary":"Find purchase order by ID",
1077 "summary":"Find purchase order by ID",
1142 "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",
1078 "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",
1143 "operationId":"getOrderById",
1079 "operationId":"getOrderById",
1144− "produces":[
1080+ "produces":[
1145 "application/xml",
1081 "application/xml",
1146 "application/json"
1082 "application/json"
1147 ],
1083 ],
1148− "parameters":[
1084+ "parameters":[
1149− {
1085+ {
1150 "name":"orderId",
1086 "name":"orderId",
1151 "in":"path",
1087 "in":"path",
1152 "description":"ID of pet that needs to be fetched",
1088 "description":"ID of pet that needs to be fetched",
@@ -1157,34 +1093,34 @@ petstoreExampleJSON = [aesonQQ|
1157 "format":"int64"
1093 "format":"int64"
1158 }
1094 }
1159 ],
1095 ],
1160− "responses":{
1096+ "responses":{
1161− "200":{
1097+ "200":{
1162 "description":"successful operation",
1098 "description":"successful operation",
1163− "schema":{
1099+ "schema":{
1164 "$ref":"#/definitions/Order"
1100 "$ref":"#/definitions/Order"
1165 }
1101 }
1166 },
1102 },
1167− "400":{
1103+ "400":{
1168 "description":"Invalid ID supplied"
1104 "description":"Invalid ID supplied"
1169 },
1105 },
1170− "404":{
1106+ "404":{
1171 "description":"Order not found"
1107 "description":"Order not found"
1172 }
1108 }
1173 }
1109 }
1174 },
1110 },
1175− "delete":{
1111+ "delete":{
1176− "tags":[
1112+ "tags":[
1177 "store"
1113 "store"
1178 ],
1114 ],
1179 "summary":"Delete purchase order by ID",
1115 "summary":"Delete purchase order by ID",
1180 "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",
1116 "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",
1181 "operationId":"deleteOrder",
1117 "operationId":"deleteOrder",
1182− "produces":[
1118+ "produces":[
1183 "application/xml",
1119 "application/xml",
1184 "application/json"
1120 "application/json"
1185 ],
1121 ],
1186− "parameters":[
1122+ "parameters":[
1187− {
1123+ {
1188 "name":"orderId",
1124 "name":"orderId",
1189 "in":"path",
1125 "in":"path",
1190 "description":"ID of the order that needs to be deleted",
1126 "description":"ID of the order that needs to be deleted",
@@ -1193,133 +1129,133 @@ petstoreExampleJSON = [aesonQQ|
1193 "minimum":1.0
1129 "minimum":1.0
1194 }
1130 }
1195 ],
1131 ],
1196− "responses":{
1132+ "responses":{
1197− "400":{
1133+ "400":{
1198 "description":"Invalid ID supplied"
1134 "description":"Invalid ID supplied"
1199 },
1135 },
1200− "404":{
1136+ "404":{
1201 "description":"Order not found"
1137 "description":"Order not found"
1202 }
1138 }
1203 }
1139 }
1204 }
1140 }
1205 },
1141 },
1206− "/user":{
1142+ "/user":{
1207− "post":{
1143+ "post":{
1208− "tags":[
1144+ "tags":[
1209 "user"
1145 "user"
1210 ],
1146 ],
1211 "summary":"Create user",
1147 "summary":"Create user",
1212 "description":"This can only be done by the logged in user.",
1148 "description":"This can only be done by the logged in user.",
1213 "operationId":"createUser",
1149 "operationId":"createUser",
1214− "produces":[
1150+ "produces":[
1215 "application/xml",
1151 "application/xml",
1216 "application/json"
1152 "application/json"
1217 ],
1153 ],
1218− "parameters":[
1154+ "parameters":[
1219− {
1155+ {
1220 "in":"body",
1156 "in":"body",
1221 "name":"body",
1157 "name":"body",
1222 "description":"Created user object",
1158 "description":"Created user object",
1223 "required":true,
1159 "required":true,
1224− "schema":{
1160+ "schema":{
1225 "$ref":"#/definitions/User"
1161 "$ref":"#/definitions/User"
1226 }
1162 }
1227 }
1163 }
1228 ],
1164 ],
1229− "responses":{
1165+ "responses":{
1230− "default":{
1166+ "default":{
1231 "description":"successful operation"
1167 "description":"successful operation"
1232 }
1168 }
1233 }
1169 }
1234 }
1170 }
1235 },
1171 },
1236− "/user/createWithArray":{
1172+ "/user/createWithArray":{
1237− "post":{
1173+ "post":{
1238− "tags":[
1174+ "tags":[
1239 "user"
1175 "user"
1240 ],
1176 ],
1241 "summary":"Creates list of users with given input array",
1177 "summary":"Creates list of users with given input array",
1242 "description":"",
1178 "description":"",
1243 "operationId":"createUsersWithArrayInput",
1179 "operationId":"createUsersWithArrayInput",
1244− "produces":[
1180+ "produces":[
1245 "application/xml",
1181 "application/xml",
1246 "application/json"
1182 "application/json"
1247 ],
1183 ],
1248− "parameters":[
1184+ "parameters":[
1249− {
1185+ {
1250 "in":"body",
1186 "in":"body",
1251 "name":"body",
1187 "name":"body",
1252 "description":"List of user object",
1188 "description":"List of user object",
1253 "required":true,
1189 "required":true,
1254− "schema":{
1190+ "schema":{
1255 "type":"array",
1191 "type":"array",
1256− "items":{
1192+ "items":{
1257 "$ref":"#/definitions/User"
1193 "$ref":"#/definitions/User"
1258 }
1194 }
1259 }
1195 }
1260 }
1196 }
1261 ],
1197 ],
1262− "responses":{
1198+ "responses":{
1263− "default":{
1199+ "default":{
1264 "description":"successful operation"
1200 "description":"successful operation"
1265 }
1201 }
1266 }
1202 }
1267 }
1203 }
1268 },
1204 },
1269− "/user/createWithList":{
1205+ "/user/createWithList":{
1270− "post":{
1206+ "post":{
1271− "tags":[
1207+ "tags":[
1272 "user"
1208 "user"
1273 ],
1209 ],
1274 "summary":"Creates list of users with given input array",
1210 "summary":"Creates list of users with given input array",
1275 "description":"",
1211 "description":"",
1276 "operationId":"createUsersWithListInput",
1212 "operationId":"createUsersWithListInput",
1277− "produces":[
1213+ "produces":[
1278 "application/xml",
1214 "application/xml",
1279 "application/json"
1215 "application/json"
1280 ],
1216 ],
1281− "parameters":[
1217+ "parameters":[
1282− {
1218+ {
1283 "in":"body",
1219 "in":"body",
1284 "name":"body",
1220 "name":"body",
1285 "description":"List of user object",
1221 "description":"List of user object",
1286 "required":true,
1222 "required":true,
1287− "schema":{
1223+ "schema":{
1288 "type":"array",
1224 "type":"array",
1289− "items":{
1225+ "items":{
1290 "$ref":"#/definitions/User"
1226 "$ref":"#/definitions/User"
1291 }
1227 }
1292 }
1228 }
1293 }
1229 }
1294 ],
1230 ],
1295− "responses":{
1231+ "responses":{
1296− "default":{
1232+ "default":{
1297 "description":"successful operation"
1233 "description":"successful operation"
1298 }
1234 }
1299 }
1235 }
1300 }
1236 }
1301 },
1237 },
1302− "/user/login":{
1238+ "/user/login":{
1303− "get":{
1239+ "get":{
1304− "tags":[
1240+ "tags":[
1305 "user"
1241 "user"
1306 ],
1242 ],
1307 "summary":"Logs user into the system",
1243 "summary":"Logs user into the system",
1308 "description":"",
1244 "description":"",
1309 "operationId":"loginUser",
1245 "operationId":"loginUser",
1310− "produces":[
1246+ "produces":[
1311 "application/xml",
1247 "application/xml",
1312 "application/json"
1248 "application/json"
1313 ],
1249 ],
1314− "parameters":[
1250+ "parameters":[
1315− {
1251+ {
1316 "name":"username",
1252 "name":"username",
1317 "in":"query",
1253 "in":"query",
1318 "description":"The user name for login",
1254 "description":"The user name for login",
1319 "required":true,
1255 "required":true,
1320 "type":"string"
1256 "type":"string"
1321 },
1257 },
1322− {
1258+ {
1323 "name":"password",
1259 "name":"password",
1324 "in":"query",
1260 "in":"query",
1325 "description":"The password for login in clear text",
1261 "description":"The password for login in clear text",
@@ -1327,65 +1263,65 @@ petstoreExampleJSON = [aesonQQ|
1327 "type":"string"
1263 "type":"string"
1328 }
1264 }
1329 ],
1265 ],
1330− "responses":{
1266+ "responses":{
1331− "200":{
1267+ "200":{
1332 "description":"successful operation",
1268 "description":"successful operation",
1333− "schema":{
1269+ "schema":{
1334 "type":"string"
1270 "type":"string"
1335 },
1271 },
1336− "headers":{
1272+ "headers":{
1337− "X-Rate-Limit":{
1273+ "X-Rate-Limit":{
1338 "type":"integer",
1274 "type":"integer",
1339 "format":"int32",
1275 "format":"int32",
1340 "description":"calls per hour allowed by the user"
1276 "description":"calls per hour allowed by the user"
1341 },
1277 },
1342− "X-Expires-After":{
1278+ "X-Expires-After":{
1343 "type":"string",
1279 "type":"string",
1344 "format":"date-time",
1280 "format":"date-time",
1345 "description":"date in UTC when toekn expires"
1281 "description":"date in UTC when toekn expires"
1346 }
1282 }
1347 }
1283 }
1348 },
1284 },
1349− "400":{
1285+ "400":{
1350 "description":"Invalid username/password supplied"
1286 "description":"Invalid username/password supplied"
1351 }
1287 }
1352 }
1288 }
1353 }
1289 }
1354 },
1290 },
1355− "/user/logout":{
1291+ "/user/logout":{
1356− "get":{
1292+ "get":{
1357− "tags":[
1293+ "tags":[
1358 "user"
1294 "user"
1359 ],
1295 ],
1360 "summary":"Logs out current logged in user session",
1296 "summary":"Logs out current logged in user session",
1361 "description":"",
1297 "description":"",
1362 "operationId":"logoutUser",
1298 "operationId":"logoutUser",
1363− "produces":[
1299+ "produces":[
1364 "application/xml",
1300 "application/xml",
1365 "application/json"
1301 "application/json"
1366 ],
1302 ],
1367 "parameters": [],
1303 "parameters": [],
1368− "responses":{
1304+ "responses":{
1369− "default":{
1305+ "default":{
1370 "description":"successful operation"
1306 "description":"successful operation"
1371 }
1307 }
1372 }
1308 }
1373 }
1309 }
1374 },
1310 },
1375− "/user/{username}":{
1311+ "/user/{username}":{
1376− "get":{
1312+ "get":{
1377− "tags":[
1313+ "tags":[
1378 "user"
1314 "user"
1379 ],
1315 ],
1380 "summary":"Get user by user name",
1316 "summary":"Get user by user name",
1381 "description":"",
1317 "description":"",
1382 "operationId":"getUserByName",
1318 "operationId":"getUserByName",
1383− "produces":[
1319+ "produces":[
1384 "application/xml",
1320 "application/xml",
1385 "application/json"
1321 "application/json"
1386 ],
1322 ],
1387− "parameters":[
1323+ "parameters":[
1388− {
1324+ {
1389 "name":"username",
1325 "name":"username",
1390 "in":"path",
1326 "in":"path",
1391 "description":"The name that needs to be fetched. Use user1 for testing. ",
1327 "description":"The name that needs to be fetched. Use user1 for testing. ",
@@ -1393,72 +1329,72 @@ petstoreExampleJSON = [aesonQQ|
1393 "type":"string"
1329 "type":"string"
1394 }
1330 }
1395 ],
1331 ],
1396− "responses":{
1332+ "responses":{
1397− "200":{
1333+ "200":{
1398 "description":"successful operation",
1334 "description":"successful operation",
1399− "schema":{
1335+ "schema":{
1400 "$ref":"#/definitions/User"
1336 "$ref":"#/definitions/User"
1401 }
1337 }
1402 },
1338 },
1403− "400":{
1339+ "400":{
1404 "description":"Invalid username supplied"
1340 "description":"Invalid username supplied"
1405 },
1341 },
1406− "404":{
1342+ "404":{
1407 "description":"User not found"
1343 "description":"User not found"
1408 }
1344 }
1409 }
1345 }
1410 },
1346 },
1411− "put":{
1347+ "put":{
1412− "tags":[
1348+ "tags":[
1413 "user"
1349 "user"
1414 ],
1350 ],
1415 "summary":"Updated user",
1351 "summary":"Updated user",
1416 "description":"This can only be done by the logged in user.",
1352 "description":"This can only be done by the logged in user.",
1417 "operationId":"updateUser",
1353 "operationId":"updateUser",
1418− "produces":[
1354+ "produces":[
1419 "application/xml",
1355 "application/xml",
1420 "application/json"
1356 "application/json"
1421 ],
1357 ],
1422− "parameters":[
1358+ "parameters":[
1423− {
1359+ {
1424 "name":"username",
1360 "name":"username",
1425 "in":"path",
1361 "in":"path",
1426 "description":"name that need to be deleted",
1362 "description":"name that need to be deleted",
1427 "required":true,
1363 "required":true,
1428 "type":"string"
1364 "type":"string"
1429 },
1365 },
1430− {
1366+ {
1431 "in":"body",
1367 "in":"body",
1432 "name":"body",
1368 "name":"body",
1433 "description":"Updated user object",
1369 "description":"Updated user object",
1434 "required":true,
1370 "required":true,
1435− "schema":{
1371+ "schema":{
1436 "$ref":"#/definitions/User"
1372 "$ref":"#/definitions/User"
1437 }
1373 }
1438 }
1374 }
1439 ],
1375 ],
1440− "responses":{
1376+ "responses":{
1441− "400":{
1377+ "400":{
1442 "description":"Invalid user supplied"
1378 "description":"Invalid user supplied"
1443 },
1379 },
1444− "404":{
1380+ "404":{
1445 "description":"User not found"
1381 "description":"User not found"
1446 }
1382 }
1447 }
1383 }
1448 },
1384 },
1449− "delete":{
1385+ "delete":{
1450− "tags":[
1386+ "tags":[
1451 "user"
1387 "user"
1452 ],
1388 ],
1453 "summary":"Delete user",
1389 "summary":"Delete user",
1454 "description":"This can only be done by the logged in user.",
1390 "description":"This can only be done by the logged in user.",
1455 "operationId":"deleteUser",
1391 "operationId":"deleteUser",
1456− "produces":[
1392+ "produces":[
1457 "application/xml",
1393 "application/xml",
1458 "application/json"
1394 "application/json"
1459 ],
1395 ],
1460− "parameters":[
1396+ "parameters":[
1461− {
1397+ {
1462 "name":"username",
1398 "name":"username",
1463 "in":"path",
1399 "in":"path",
1464 "description":"The name that needs to be deleted",
1400 "description":"The name that needs to be deleted",
@@ -1466,237 +1402,207 @@ petstoreExampleJSON = [aesonQQ|
1466 "type":"string"
1402 "type":"string"
1467 }
1403 }
1468 ],
1404 ],
1469− "responses":{
1405+ "responses":{
1470− "400":{
1406+ "400":{
1471 "description":"Invalid username supplied"
1407 "description":"Invalid username supplied"
1472 },
1408 },
1473− "404":{
1409+ "404":{
1474 "description":"User not found"
1410 "description":"User not found"
1475 }
1411 }
1476 }
1412 }
1477 }
1413 }
1478 }
1414 }
1479 },
1415 },
1480− "securityDefinitions":{
1416+ "securityDefinitions":{
1481− "petstore_auth":{
1417+ "petstore_auth":{
1482 "type":"oauth2",
1418 "type":"oauth2",
1483 "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",
1419 "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",
1484 "flow":"implicit",
1420 "flow":"implicit",
1485− "scopes":{
1421+ "scopes":{
1486 "write:pets":"modify pets in your account",
1422 "write:pets":"modify pets in your account",
1487 "read:pets":"read your pets"
1423 "read:pets":"read your pets"
1488 }
1424 }
1489 },
1425 },
1490− "api_key":{
1426+ "api_key":{
1491 "type":"apiKey",
1427 "type":"apiKey",
1492 "name":"api_key",
1428 "name":"api_key",
1493 "in":"header"
1429 "in":"header"
1494 }
1430 }
1495 },
1431 },
1496− "definitions":{
1432+ "definitions":{
1497− "Order":{
1433+ "Order":{
1498 "type":"object",
1434 "type":"object",
1499− "properties":{
1435+ "properties":{
1500− "id":{
1436+ "id":{
1501 "type":"integer",
1437 "type":"integer",
1502 "format":"int64"
1438 "format":"int64"
1503 },
1439 },
1504− "petId":{
1440+ "petId":{
1505 "type":"integer",
1441 "type":"integer",
1506 "format":"int64"
1442 "format":"int64"
1507 },
1443 },
1508− "quantity":{
1444+ "quantity":{
1509 "type":"integer",
1445 "type":"integer",
1510 "format":"int32"
1446 "format":"int32"
1511 },
1447 },
1512− "shipDate":{
1448+ "shipDate":{
1513 "type":"string",
1449 "type":"string",
1514 "format":"date-time"
1450 "format":"date-time"
1515 },
1451 },
1516− "status":{
1452+ "status":{
1517 "type":"string",
1453 "type":"string",
1518 "description":"Order Status",
1454 "description":"Order Status",
1519− "enum":[
1455+ "enum":[
1520 "placed",
1456 "placed",
1521 "approved",
1457 "approved",
1522 "delivered"
1458 "delivered"
1523 ]
1459 ]
1524 },
1460 },
1525− "complete":{
1461+ "complete":{
1526 "type":"boolean",
1462 "type":"boolean",
1527 "default":false
1463 "default":false
1528 }
1464 }
1529 },
1465 },
1530− "xml":{
1466+ "xml":{
1531 "name":"Order"
1467 "name":"Order"
1532 }
1468 }
1533 },
1469 },
1534− "Category":{
1470+ "Category":{
1535 "type":"object",
1471 "type":"object",
1536− "properties":{
1472+ "properties":{
1537− "id":{
1473+ "id":{
1538 "type":"integer",
1474 "type":"integer",
1539 "format":"int64"
1475 "format":"int64"
1540 },
1476 },
1541− "name":{
1477+ "name":{
1542 "type":"string"
1478 "type":"string"
1543 }
1479 }
1544 },
1480 },
1545− "xml":{
1481+ "xml":{
1546 "name":"Category"
1482 "name":"Category"
1547 }
1483 }
1548 },
1484 },
1549− "User":{
1485+ "User":{
1550 "type":"object",
1486 "type":"object",
1551− "properties":{
1487+ "properties":{
1552− "id":{
1488+ "id":{
1553 "type":"integer",
1489 "type":"integer",
1554 "format":"int64"
1490 "format":"int64"
1555 },
1491 },
1556− "username":{
1492+ "username":{
1557 "type":"string"
1493 "type":"string"
1558 },
1494 },
1559− "firstName":{
1495+ "firstName":{
1560 "type":"string"
1496 "type":"string"
1561 },
1497 },
1562− "lastName":{
1498+ "lastName":{
1563 "type":"string"
1499 "type":"string"
1564 },
1500 },
1565− "email":{
1501+ "email":{
1566 "type":"string"
1502 "type":"string"
1567 },
1503 },
1568− "password":{
1504+ "password":{
1569 "type":"string"
1505 "type":"string"
1570 },
1506 },
1571− "phone":{
1507+ "phone":{
1572 "type":"string"
1508 "type":"string"
1573 },
1509 },
1574− "userStatus":{
1510+ "userStatus":{
1575 "type":"integer",
1511 "type":"integer",
1576 "format":"int32",
1512 "format":"int32",
1577 "description":"User Status"
1513 "description":"User Status"
1578 }
1514 }
1579 },
1515 },
1580− "xml":{
1516+ "xml":{
1581 "name":"User"
1517 "name":"User"
1582 }
1518 }
1583 },
1519 },
1584− "Tag":{
1520+ "Tag":{
1585 "type":"object",
1521 "type":"object",
1586− "properties":{
1522+ "properties":{
1587− "id":{
1523+ "id":{
1588 "type":"integer",
1524 "type":"integer",
1589 "format":"int64"
1525 "format":"int64"
1590 },
1526 },
1591− "name":{
1527+ "name":{
1592 "type":"string"
1528 "type":"string"
1593 }
1529 }
1594 },
1530 },
1595− "xml":{
1531+ "xml":{
1596 "name":"Tag"
1532 "name":"Tag"
1597 }
1533 }
1598 },
1534 },
1599− "Pet":{
1535+ "Pet":{
1600 "type":"object",
1536 "type":"object",
1601− "required":[
1537+ "required":[
1602 "name",
1538 "name",
1603 "photoUrls"
1539 "photoUrls"
1604 ],
1540 ],
1605− "properties":{
1541+ "properties":{
1606− "id":{
1542+ "id":{
1607 "type":"integer",
1543 "type":"integer",
1608 "format":"int64"
1544 "format":"int64"
1609 },
1545 },
1610− "category":{
1546+ "category":{
1611 "$ref":"#/definitions/Category"
1547 "$ref":"#/definitions/Category"
1612 },
1548 },
1613− "name":{
1549+ "name":{
1614 "type":"string",
1550 "type":"string",
1615 "example":"doggie"
1551 "example":"doggie"
1616 },
1552 },
1617− "photoUrls":{
1553+ "photoUrls":{
1618 "type":"array",
1554 "type":"array",
1619− "xml":{
1555+ "xml":{
1620 "name":"photoUrl",
1556 "name":"photoUrl",
1621 "wrapped":true
1557 "wrapped":true
1622 },
1558 },
1623− "items":{
1559+ "items":{
1624 "type":"string"
1560 "type":"string"
1625 }
1561 }
1626 },
1562 },
1627− "tags":{
1563+ "tags":{
1628 "type":"array",
1564 "type":"array",
1629− "xml":{
1565+ "xml":{
1630 "name":"tag",
1566 "name":"tag",
1631 "wrapped":true
1567 "wrapped":true
1632 },
1568 },
1633− "items":{
1569+ "items":{
1634 "$ref":"#/definitions/Tag"
1570 "$ref":"#/definitions/Tag"
1635 }
1571 }
1636 },
1572 },
1637− "status":{
1573+ "status":{
1638 "type":"string",
1574 "type":"string",
1639 "description":"pet status in the store",
1575 "description":"pet status in the store",
1640− "enum":[
1576+ "enum":[
1641 "available",
1577 "available",
1642 "pending",
1578 "pending",
1643 "sold"
1579 "sold"
1644 ]
1580 ]
1645 }
1581 }
1646 },
1582 },
1647− "xml":{
1583+ "xml":{
1648 "name":"Pet"
1584 "name":"Pet"
1649 }
1585 }
1650 },
1586 },
1651− "ApiResponse":{
1587+ "ApiResponse":{
1652 "type":"object",
1588 "type":"object",
1653− "properties":{
1589+ "properties":{
1654− "code":{
1590+ "code":{
1655 "type":"integer",
1591 "type":"integer",
1656 "format":"int32"
1592 "format":"int32"
1657 },
1593 },
1658− "type":{
1594+ "type":{
1659 "type":"string"
1595 "type":"string"
1660 },
1596 },
1661− "message":{
1597+ "message":{
1662 "type":"string"
1598 "type":"string"
1663 }
1599 }
1664 }
1600 }
1665 }
1601 }
1666 },
1602 },
1667− "externalDocs":{
1603+ "externalDocs":{
1668 "description":"Find out more about Swagger",
1604 "description":"Find out more about Swagger",
1669 "url":"http://swagger.io"
1605 "url":"http://swagger.io"
1670 }
1606 }
1671}
1607}
1672|]
1608|]
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+8
@@ -0,0 +1,8 @@
1+module Main (main) where
2+
3+import System.FilePath.Glob (glob)
4+import Test.DocTest (doctest)
5+
6+main :: IO ()
7+main = glob "src/**/*.hs" >>= doctest'
8+ where doctest' files = doctest $ "-Iinclude/" : "-D__DOCTEST__" : files
test/SpecCommon.hs+2−7
@@ -1,7 +1,6 @@
1module SpecCommon where
1module SpecCommon where
2
2
3import Data.Aeson
3import Data.Aeson
4−import Data.ByteString.Builder (toLazyByteString)
5import qualified Data.Foldable as F
4import qualified Data.Foldable as F
6import qualified Data.HashMap.Strict as HashMap
5import qualified Data.HashMap.Strict as HashMap
7import qualified Data.Vector as Vector
6import qualified Data.Vector as Vector
@@ -22,9 +21,5 @@ x <=> js = do
22 toJSON x `shouldBe` js
21 toJSON x `shouldBe` js
23 it "decodes correctly" $ do
22 it "decodes correctly" $ do
24 fromJSON js `shouldBe` Success x
23 fromJSON js `shouldBe` Success x
25− it "roundtrips: eitherDecode . encode" $ do
24+
26− eitherDecode (encode x) `shouldBe` Right x
25+
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
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