git.iko.soy/typeable/swagger2
on 7efa220 help sign in
41 files changed+1544−7443
since splitsnapshots
unifiedsplit
.ghci−2 .gitignore−2 .travis.yml+43−157 CHANGELOG.md+5−294 LICENSE+1−1 README.md−33 Setup.hs−31 cabal.project−2 examples/hackage.hs−86 hackage-docs.sh−78 include/overlapping-compat.h−8 src/Data/Swagger.hs+31−294 src/Data/Swagger/Declare.hs−199 src/Data/Swagger/Internal.hs+385−803 src/Data/Swagger/Internal/AesonUtils.hs−346 src/Data/Swagger/Internal/ParamSchema.hs−337 src/Data/Swagger/Internal/Schema.hs−882 src/Data/Swagger/Internal/Schema/Validation.hs−511 src/Data/Swagger/Internal/TypeShape.hs−66 src/Data/Swagger/Internal/Utils.hs+42−52 src/Data/Swagger/Lens.hs+95−174 src/Data/Swagger/Operation.hs−193 src/Data/Swagger/Optics.hs−597 src/Data/Swagger/ParamSchema.hs−26 src/Data/Swagger/Schema.hs+8−51 src/Data/Swagger/Schema/Generator.hs−114 src/Data/Swagger/Schema/Internal.hs+236 src/Data/Swagger/Schema/Validation.hs−90 src/Data/Swagger/SchemaOptions.hs−72 stack-7.8.yaml+5 stack-head.yaml+5 stack.yaml+2−6 swagger2.cabal+27−117 test/Data/Swagger/CommonTestTypes.hs−679 test/Data/Swagger/ParamSchemaSpec.hs−40 test/Data/Swagger/Schema/GeneratorSpec.hs−168 test/Data/Swagger/Schema/ValidationSpec.hs−278 test/Data/Swagger/SchemaSpec.hs+154−81 test/Data/SwaggerSpec.hs+486−551 test/SpecCommon.hs+19−10 test/doctests.hs−12
.ghcideleted−2
@@ -1,2 +0,0 @@
1−:set -itest -isrc -optP-include -optP.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/autogen/cabal_macros.h -optP-I -optPinclude
2−:set -hide-package base-compat-0.10.4
.gitignore−2
@@ -1,6 +1,4 @@
11dist
2−dist-newstyle
3−.ghc.environment.*
42cabal-dev
53*.o
64*.hi
.travis.yml+43−157
@@ -1,162 +1,48 @@
1−# This Travis job script has been generated by a script via
2−#
3−# haskell-ci '--branches' 'master' '--haddock-jobs=>=8.4' '--output' '.travis.yml' 'swagger2.cabal'
4−#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.5.20191020
8−#
9−language: c
10−dist: xenial
11−git:
12− # whether to recursively clone submodules
13− submodules: false
14−branches:
15− only:
16− - master
17−cache:
18− directories:
19− - $HOME/.cabal/packages
20− - $HOME/.cabal/store
21−before_cache:
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
23− # remove files that are regenerated by 'cabal update'
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
27− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
28− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
29− - rm -rfv $CABALHOME/packages/head.hackage
1+# explicitly request container-based infrastructure
2+sudo: false
3+
304matrix:
315 include:
32− - compiler: ghc-8.8.1
33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
34− - compiler: ghc-8.6.5
35− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
36− - compiler: ghc-8.4.4
37− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
38− - compiler: ghc-8.2.2
39− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
40− - compiler: ghc-8.0.2
41− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
6+ - env: GHCVER=7.8.4 STACK_YAML=stack-7.8.yaml
7+ addons:
8+ apt:
9+ sources:
10+ - hvr-ghc
11+ packages:
12+ - ghc-7.8.4
13+ - env: GHCVER=7.10.2 STACK_YAML=stack.yaml
14+ addons:
15+ apt:
16+ sources:
17+ - hvr-ghc
18+ packages:
19+ - ghc-7.10.2
20+ - env: GHCVER=head STACK_YAML=stack-head.yaml
21+ addons:
22+ apt:
23+ sources:
24+ - hvr-ghc
25+ packages:
26+ - ghc-head
27+ allow_failures:
28+ - env: GHCVER=7.8.4 STACK_YAML=stack-7.8.yaml
29+ - env: GHCVER=head STACK_YAML=stack-head.yaml
30+
31+cache:
32+ directories:
33+ - $HOME/.stack/
34+
4235before_install:
43− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
44− - WITHCOMPILER="-w $HC"
45− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
46− - HCPKG="$HC-pkg"
47− - unset CC
48− - CABAL=/opt/ghc/bin/cabal
49− - CABALHOME=$HOME/.cabal
50− - export PATH="$CABALHOME/bin:$PATH"
51− - TOP=$(pwd)
52− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
53− - echo $HCNUMVER
54− - CABAL="$CABAL -vnormal+nowrap+markoutput"
55− - set -o pipefail
56− - |
57− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
58− echo 'BEGIN { state = "output"; }' >> .colorful.awk
59− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
60− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
61− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
62− echo ' if (state == "cabal") {' >> .colorful.awk
63− echo ' print blue($0)' >> .colorful.awk
64− echo ' } else {' >> .colorful.awk
65− echo ' print $0' >> .colorful.awk
66− echo ' }' >> .colorful.awk
67− echo '}' >> .colorful.awk
68− - cat .colorful.awk
69− - |
70− color_cabal_output () {
71− awk -f $TOP/.colorful.awk
72− }
73− - echo text | color_cabal_output
36+ # ghc
37+ - export PATH=/opt/ghc/$GHCVER/bin:$PATH
38+ # stack
39+ - mkdir -p ~/.local/bin
40+ - export PATH=~/.local/bin:$PATH
41+ - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
42+
7443install:
75− - ${CABAL} --version
76− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
77− - TEST=--enable-tests
78− - BENCH=--enable-benchmarks
79− - HEADHACKAGE=false
80− - rm -f $CABALHOME/config
81− - |
82− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
83− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
84− echo "write-ghc-environment-files: always" >> $CABALHOME/config
85− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
86− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
87− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
88− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
89− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
90− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
91− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
92− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
93− echo "install-dirs user" >> $CABALHOME/config
94− echo " prefix: $CABALHOME" >> $CABALHOME/config
95− echo "repository hackage.haskell.org" >> $CABALHOME/config
96− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
97− echo " secure: True" >> $CABALHOME/config
98− echo " key-threshold: 3" >> $CABALHOME/config
99− echo " root-keys:" >> $CABALHOME/config
100− echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config
101− echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config
102− echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config
103− echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config
104− echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config
105− - |
106− echo "program-default-options" >> $CABALHOME/config
107− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
108− - cat $CABALHOME/config
109− - rm -fv cabal.project cabal.project.local cabal.project.freeze
110− - travis_retry ${CABAL} v2-update -v
111− # Generate cabal.project
112− - rm -rf cabal.project cabal.project.local cabal.project.freeze
113− - touch cabal.project
114− - |
115− echo "packages: ." >> cabal.project
116− - |
117− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
118− - cat cabal.project || true
119− - cat cabal.project.local || true
120− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
121− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
122− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
123− - rm cabal.project.freeze
124− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output
125− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
126−script:
127− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
128− # Packaging...
129− - ${CABAL} v2-sdist all | color_cabal_output
130− # Unpacking...
131− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
132− - cd ${DISTDIR} || false
133− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
134− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
135− - PKGDIR_swagger2="$(find . -maxdepth 1 -type d -regex '.*/swagger2-[0-9.]*')"
136− # Generate cabal.project
137− - rm -rf cabal.project cabal.project.local cabal.project.freeze
138− - touch cabal.project
139− - |
140− echo "packages: ${PKGDIR_swagger2}" >> cabal.project
141− - |
142− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
143− - cat cabal.project || true
144− - cat cabal.project.local || true
145− # Building...
146− # this builds all libraries and executables (without tests/benchmarks)
147− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
148− # Building with tests and benchmarks...
149− # build & run tests, build benchmarks
150− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
151− # Testing...
152− - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
153− # cabal check...
154− - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check)
155− # haddock...
156− - if [ $HCNUMVER -ge 80400 ] ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi
157− # Building without installed constraints for packages in global-db...
158− - rm -f cabal.project.local
159− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
44+ - stack --no-terminal --skip-ghc-check setup
45+ - stack --no-terminal --skip-ghc-check test --only-snapshot
16046
161−# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])
162−# EOF
47+script:
48+ - stack --no-terminal --skip-ghc-check test
CHANGELOG.md+5−294
@@ -1,292 +1,3 @@
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−
186−1.2.1
187−---
188−
189−* Minor changes:
190− * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.
191−
192−* Fixes:
193− * Fix build for GHC 8.0-rc1.
194−
195−1.2
196−---
197−* Minor changes (see [#36](https://github.com/GetShopTV/swagger2/pull/36)):
198− * Change default `ToSchema` instance for unit data types (i.e. types with one nullable constructor like `data Unit = Unit`):
199− now these types are treated like sum types with only one alternative;
200− * Add generic `ToParamSchema` instance for unit data types;
201− * Add `items: []` to schema for `()` (making it a valid schema).
202−
203−* Fixes:
204− * Do not omit `items: []` from `Schema` JSON;
205− * Do not generate unused definitions for nested `newtype`s (see [#38](https://github.com/GetShopTV/swagger2/pull/38)).
206−
207−1.1.1
208−---
209−* Fixes:
210− * `CollectionFormat Param` -> `CollectionFormat ParamOtherSchema`;
211− this change was necessary after putting `CollectionFormat` to `SwaggerItems`.
212−
213−1.1
214−---
215−* Major changes:
216− * Put `CollectionFormat` in one place (see [`3cc860d`](https://github.com/GetShopTV/swagger2/commit/3cc860dd3f002ab984f4d0e4ce1d1799f985832e)).
217−
218−* Minor changes:
219− * Use Swagger formats for `Int32`, `Int64`, `Float`, `Double`, `Day` and `ZonedTime` (see [#32](https://github.com/GetShopTV/swagger2/pull/32));
220− * Export `HeaderName`, `TagName`, `HttpStatusCode` type synonyms;
221− * Add `ToParamSchema` instances for `[a]`, `Set a` and `HashSet a`;
222− * Add `Monoid` instances for `Header` and `Example`.
223−
224−* Fixes:
225− * Use overwrite strategy for `HashMap` `SwaggerMonoid` instances by default.
226−
227−1.0
228−---
229−* Major changes:
230− * Add `Data` and `Typeable` instances for `Data.Swagger` types;
231− * Merge `ParamType`/`ItemsType`/`SchemaType` into `SwaggerType` GADT;
232− * Merge collection format types into `CollectionFormat` GADT;
233− * Introduce `SwaggerItems` GADT, replacing `Items` and `SchemaItems` in `ParamSchema` (see [#24](https://github.com/GetShopTV/swagger2/pull/24));
234− * Move type, format and items fields to `ParamSchema` (former `SchemaComon`);
235− * Prepend reference path automatically (see [commit 49d1fad](https://github.com/GetShopTV/swagger2/commit/49d1fadd2100644e70c442667180d0d73e107a5f))
236− and thus remove `"#/definitions/"` from user code, leaving much clearer `Reference "Name"`;
237− * Change `Data.Swagger.Schema` (see [#19](https://github.com/GetShopTV/swagger2/pull/19)):
238− * Change the only method of `ToSchema` to `declareNamedSchema` which should produce a `NamedSchema`
239− along with a list of schema definitions used to produce it;
240− * Add `declareSchema`, `declareSchemaRef`;
241− * Replace `genericTo*` helpers with `genericDeclare*` helpers;
242− * Add `paramSchemaTo[Named]Schema` helpers to facilitate code reuse for primitive schemas;
243− * Add helpers for inlining `Schema` references dynamically (see [#23](https://github.com/GetShopTV/swagger2/pull/23));
244− * Add `ToParamSchema` class (see [#17](https://github.com/GetShopTV/swagger2/pull/17)) with
245− * generic default implementation and
246− * instances for some base types compliant with `http-api-data` instances;
247− * Add `Data.Swagger.Declare` module with
248− * `DeclareT` monad transformer;
249− * `MonadDeclare` type class;
250− * various helpers;
251− * Rename parameter-related types:
252− * `Parameter` -> `Param`;
253− * `ParameterSchema` -> `ParamAnySchema`;
254− * `ParameterOtherSchema` -> `ParamOtherSchema`;
255− * `ParameterLocation` -> `ParamLocation`;
256− * `SchemaCommon` -> `ParamSchema`;
257− * `parameter*` fields renamed to `param*` fields;
258− * `schemaCommon*` fields renamed to `paramSchema*` fields;
259− * `HasSchemaCommon` -> `HasParamSchema`.
260−
261−* Minor changes:
262− * Replace TH-generated JSON instances with `Generic`-based (see [#25](https://github.com/GetShopTV/swagger2/pull/25));
263− * Drop `template-haskell` dependency;
264− * Omit empty array/object properties from `toJSON` output ([#22](https://github.com/GetShopTV/swagger2/pull/22));
265− * Remove `minLength` property from schemas for `time` types;
266− * Move `SchemaOptions` to `Data.Swagger.SchemaOptions`;
267− * Remove `useReferences` from `SchemaOptions` (see [#23](https://github.com/GetShopTV/swagger2/pull/23));
268− * Place all internal submodules under `Data.Swagger.Internal`;
269− * Better documentation (see [#26](https://github.com/GetShopTV/swagger2/pull/26)).
270−
271−0.4.1
272−---
273−* Fixes:
274− * Use `PackageImports` for `Data.HashSet` to avoid test failure on stackage (see [#15](https://github.com/GetShopTV/swagger2/issues/15));
275− * Add an upper version bound for `aeson` due to `aeson-0.10.0.0` bug (see [bos/aeson#293](https://github.com/bos/aeson/issues/293));
276− * Switch to Cabal-based multi GHC Travis config.
277−
278−0.4
279−---
280−* Remove `Swagger`/`swagger` prefixes;
281−* Add `ToSchema` type class with default generic implementation;
282−* Add configurable generic `ToSchema` helpers;
283−* Add `doctest` test suite;
284−* Fixes:
285− * Fix `HasSchemaCommon` instance for `Schema`;
286− * Change `minimum`, `maximum` and `multipleOf` properties to be any number,
287− not necessarily an integer;
288− * Fix all warnings.
289−
29010.3
2912---
2923* Fixes:
@@ -297,9 +8,9 @@ Dependencies and CI:
2978
29890.2
29910---
300−* Add `Data.Swagger.Lens`;
301−* Support references;
11+* Add `Data.Swagger.Lens`
12+* Support references
30213* Fixes:
303− * Fix `FromJSON SwaggerHost` instance;
304− * Add missing `Maybe`s for field types;
305− * Decode petstore `swagger.json` successfully.
14+ * Fix `FromJSON SwaggerHost` instance
15+ * Add missing `Maybe`s for field types
16+ * Decode petstore swagger.json successfully
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015-2017, GetShopTV
1+Copyright (c) 2015, GetShopTV
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without
README.md−33
@@ -1,39 +1,6 @@
11# swagger2
22
3−[![Join the chat at https://gitter.im/haskell-swagger2/Lobby](https://badges.gitter.im/haskell-swagger2/Lobby.svg)](https://gitter.im/haskell-swagger2/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
4−
53[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
64[![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)
7−[![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2)
8−[![Stackage Nightly](http://stackage.org/package/swagger2/badge/nightly)](http://stackage.org/nightly/package/swagger2)
95
106Swagger 2.0 data model.
11−
12−The original Swagger 2.0 specification is available at http://swagger.io/specification/.
13−
14−## Usage
15−
16−This library is intended to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them.
17−
18−Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2).
19−
20−Some examples can be found in [`examples/` directory](/examples).
21−
22−## Trying out
23−
24−All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/).
25−
26−Ready-to-use specification can be served as JSON and interactive API documentation
27−can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui).
28−
29−Many Swagger tools, including server and client code generation for many languages, can be found on
30−[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/).
31−
32−## Contributing
33−
34−We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.
35−
36−Please report bugs via the [github issue tracker](https://github.com/GetShopTV/swagger2/issues).
37−
38−*GetShopTV Team*
39−
Setup.hs−31
@@ -1,33 +1,2 @@
1−{-# LANGUAGE CPP #-}
2−{-# OPTIONS_GHC -Wall #-}
3−module Main (main) where
4−
5−#ifndef MIN_VERSION_cabal_doctest
6−#define MIN_VERSION_cabal_doctest(x,y,z) 0
7−#endif
8−
9−#if MIN_VERSION_cabal_doctest(1,0,0)
10−
11−import Distribution.Extra.Doctest ( defaultMainWithDoctests )
12−main :: IO ()
13−main = defaultMainWithDoctests "doctests"
14−
15−#else
16−
17−#ifdef MIN_VERSION_Cabal
18−-- If the macro is defined, we have new cabal-install,
19−-- but for some reason we don't have cabal-doctest in package-db
20−--
21−-- Probably we are running cabal sdist, when otherwise using new-build
22−-- workflow
23−#warning You are configuring this package without cabal-doctest installed. \
24− The doctests test-suite will not work as a result. \
25− To fix this, install cabal-doctest before configuring.
26−#endif
27−
281import Distribution.Simple
29−
30−main :: IO ()
312main = defaultMain
32−
33−#endif
cabal.projectdeleted−2
@@ -1,2 +0,0 @@
1−packages: .
2−tests: true
examples/hackage.hsdeleted−86
@@ -1,86 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DeriveAnyClass #-}
3−{-# LANGUAGE OverloadedLists #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−module Main where
6−
7−import Control.Lens
8−import Data.Aeson
9−import Data.Proxy
10−import Data.Text (Text)
11−import GHC.Generics
12−
13−import Data.Swagger
14−import Data.Swagger.Declare
15−import Data.Swagger.Lens
16−import Data.Swagger.Operation
17−
18−type Username = Text
19−
20−data UserSummary = UserSummary
21− { summaryUsername :: Username
22− , summaryUserid :: Int
23− } deriving (Generic)
24−
25−instance ToSchema UserSummary where
26− declareNamedSchema _ = do
27− usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
28− useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
29− return $ NamedSchema (Just "UserSummary") $ mempty
30− & type_ ?~ SwaggerObject
31− & properties .~
32− [ ("summaryUsername", usernameSchema )
33− , ("summaryUserid" , useridSchema )
34− ]
35− & required .~ [ "summaryUsername"
36− , "summaryUserid" ]
37−
38−
39−type Group = Text
40−
41−data UserDetailed = UserDetailed
42− { username :: Username
43− , userid :: Int
44− , groups :: [Group]
45− } deriving (Generic, ToSchema)
46−
47−newtype Package = Package { packageName :: Text }
48− deriving (Generic, ToSchema)
49−
50−hackageSwagger :: Swagger
51−hackageSwagger = spec & definitions .~ defs
52− where
53− (defs, spec) = runDeclare declareHackageSwagger mempty
54−
55−declareHackageSwagger :: Declare (Definitions Schema) Swagger
56−declareHackageSwagger = do
57− -- param schemas
58− let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)
59−
60− -- responses
61− userSummaryResponse <- declareResponse (Proxy :: Proxy UserSummary)
62− userDetailedResponse <- declareResponse (Proxy :: Proxy UserDetailed)
63− packagesResponse <- declareResponse (Proxy :: Proxy [Package])
64−
65− return $ mempty
66− & paths .~
67− [ ("/users", mempty & get ?~ (mempty
68− & produces ?~ MimeList ["application/json"]
69− & at 200 ?~ Inline userSummaryResponse))
70− , ("/user/{username}", mempty & get ?~ (mempty
71− & produces ?~ MimeList ["application/json"]
72− & parameters .~ [ Inline $ mempty
73− & name .~ "username"
74− & required ?~ True
75− & schema .~ ParamOther (mempty
76− & in_ .~ ParamPath
77− & paramSchema .~ usernameParamSchema) ]
78− & at 200 ?~ Inline userDetailedResponse))
79− , ("/packages", mempty & get ?~ (mempty
80− & produces ?~ MimeList ["application/json"]
81− & at 200 ?~ Inline packagesResponse))
82− ]
83−
84−main :: IO ()
85−main = putStrLn . read . show . encode $ hackageSwagger
86−
hackage-docs.shdeleted−78
@@ -1,78 +0,0 @@
1−#!/bin/bash
2−set -e
3−
4−# This if stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh
5−
6−if [ "$#" -ne 1 ]; then
7− echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
8− exit 1
9−fi
10−
11−user=$1
12−
13−cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
14−if [ ! -f "$cabal_file" ]; then
15− echo "Run this script in the top-level package directory"
16− exit 1
17−fi
18−
19−pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
20−ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
21−
22−if [ -z "$pkg" ]; then
23− echo "Unable to determine package name"
24− exit 1
25−fi
26−
27−if [ -z "$ver" ]; then
28− echo "Unable to determine package version"
29− exit 1
30−fi
31−
32−echo "Detected package: $pkg-$ver"
33−
34−dir=$(mktemp -d build-docs.XXXXXX)
35−trap 'rm -r "$dir"' EXIT
36−
37−export PATH=$(stack path --bin-path)
38−
39−ghc --version
40−cabal --version
41−stack --version
42−
43−if haddock --hyperlinked-source >/dev/null
44−then
45− echo "Using fancy hyperlinked source"
46− HYPERLINK_FLAG="--haddock-option=--hyperlinked-source"
47−else
48− echo "Using boring hyperlinked source"
49− HYPERLINK_FLAG="--hyperlink-source"
50−fi
51−
52−# Cabal dist in temporary location
53−builddir=$dir/dist
54−
55−# Build dependencies haddocks with stack, so we get links
56−stack haddock --only-dependencies
57−
58−# Configure using stack databases
59−snapshotpkgdb=$(stack path --snapshot-pkg-db)
60−localpkgdb=$(stack path --local-pkg-db)
61−cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb
62−
63−# Build Hadckage compatible docs
64−cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
65−
66−# Copy into right directory
67−cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs
68−
69−# Tar and gzip
70−tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
71−
72−# Upload
73−curl -X PUT \
74− -H 'Content-Type: application/x-tar' \
75− -H 'Content-Encoding: gzip' \
76− -u "$user" \
77− --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
78− "https://hackage.haskell.org/package/$pkg-$ver/docs"
include/overlapping-compat.hdeleted−8
@@ -1,8 +0,0 @@
1−#if __GLASGOW_HASKELL__ >= 710
2−#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
3−#define OVERLAPPING_ {-# OVERLAPPING #-}
4−#else
5−{-# LANGUAGE OverlappingInstances #-}
6−#define OVERLAPPABLE_
7−#define OVERLAPPING_
8−#endif
src/Data/Swagger.hs+31−294
@@ -1,9 +1,4 @@
1−{-# LANGUAGE CPP #-}
21-- |
3−-- Module: Data.Swagger
4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5−-- Stability: experimental
6−--
72-- Swagger™ is a project used to describe and document RESTful APIs.
83--
94-- The Swagger specification defines a set of files required to describe such an API.
@@ -11,340 +6,82 @@
116-- and Swagger-Codegen to generate clients in various languages.
127-- Additional utilities can also take advantage of the resulting files, such as testing tools.
138module Data.Swagger (
14− -- * How to use this library
15− -- $howto
16−
17− -- ** @'Monoid'@ instances
18− -- $monoids
19−
20− -- ** Lenses and prisms
21− -- $lens
22−
23− -- ** Schema specification
24− -- $schema
25−
26− -- ** Manipulation
27− -- $manipulation
28−
29− -- ** Validation
30− -- $validation
31−
32− -- * Re-exports
33− module Data.Swagger.Lens,
34− module Data.Swagger.Optics,
35− module Data.Swagger.Operation,
36− module Data.Swagger.ParamSchema,
379 module Data.Swagger.Schema,
38− module Data.Swagger.Schema.Validation,
3910
4011 -- * Swagger specification
4112 Swagger(..),
4213 Host(..),
4314 Scheme(..),
4415
45− -- ** Info types
16+ -- * Info types
4617 Info(..),
4718 Contact(..),
4819 License(..),
4920
50− -- ** PathItem
21+ -- * Paths
22+ Paths(..),
5123 PathItem(..),
5224
53− -- ** Operations
54− Operation(..),
25+ -- * Operations
5526 Tag(..),
56− TagName,
27+ Operation(..),
5728
58− -- ** Types and formats
59− SwaggerType(..),
60− Format,
61− Definitions,
29+ -- * Types and formats
30+ ParameterType(..),
31+ ItemsType(..),
32+ SchemaType(..),
33+ Format(..),
6234 CollectionFormat(..),
63−
64− -- ** Parameters
65− Param(..),
66− ParamAnySchema(..),
67− ParamOtherSchema(..),
68− ParamLocation(..),
69− ParamName,
35+ ItemsCollectionFormat(..),
36+
37+ -- * Parameters
38+ Parameter(..),
39+ ParameterSchema(..),
40+ ParameterOtherSchema(..),
41+ ParameterLocation(..),
42+ ParamName(..),
43+ Items(..),
7044 Header(..),
71− HeaderName,
7245 Example(..),
7346
74− -- ** Schemas
75− ParamSchema(..),
47+ -- * Schema
7648 Schema(..),
77− NamedSchema(..),
78− SwaggerItems(..),
49+ SchemaItems(..),
50+ SchemaCommon(..),
7951 Xml(..),
80− Pattern,
81− AdditionalProperties(..),
8252
83− -- ** Responses
53+ -- * Responses
8454 Responses(..),
8555 Response(..),
86− HttpStatusCode,
8756
88− -- ** Security
57+ -- * Security
8958 SecurityScheme(..),
9059 SecuritySchemeType(..),
9160 SecurityRequirement(..),
92− SecurityDefinitions(..),
9361
94− -- *** API key
62+ -- ** API key
9563 ApiKeyParams(..),
9664 ApiKeyLocation(..),
9765
98− -- *** OAuth2
66+ -- ** OAuth2
9967 OAuth2Params(..),
10068 OAuth2Flow(..),
101− AuthorizationURL,
102− TokenURL,
69+ AuthorizationURL(..),
70+ TokenURL(..),
10371
104− -- ** External documentation
72+ -- * External documentation
10573 ExternalDocs(..),
10674
107− -- ** References
75+ -- * References
10876 Reference(..),
10977 Referenced(..),
11078
111− -- ** Miscellaneous
79+ -- * Miscellaneous
11280 MimeList(..),
11381 URL(..),
11482) where
11583
116−import Data.Swagger.Lens
117−import Data.Swagger.Optics ()
118−import Data.Swagger.Operation
119−import Data.Swagger.ParamSchema
12084import Data.Swagger.Schema
121−import Data.Swagger.Schema.Validation
12285
12386import Data.Swagger.Internal
12487
125−-- $setup
126−-- >>> import Control.Lens
127−-- >>> import Data.Aeson
128−-- >>> import Data.Monoid
129−-- >>> import Data.Proxy
130−-- >>> import GHC.Generics
131−-- >>> :set -XDeriveGeneric
132−-- >>> :set -XOverloadedStrings
133−-- >>> :set -XOverloadedLists
134−-- >>> :set -fno-warn-missing-methods
135−
136−-- $howto
137−--
138−-- This section explains how to use this library to work with Swagger specification.
139−
140−-- $monoids
141−--
142−-- Virtually all types representing Swagger specification have @'Monoid'@ instances.
143−-- The @'Monoid'@ type class provides two methods — @'mempty'@ and @'mappend'@.
144−--
145−-- In this library you can use @'mempty'@ for a default/empty value. For instance:
146−--
147−-- >>> encode (mempty :: Swagger)
148−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"}}"
149−--
150−-- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty.
151−-- That is because these properties are actually required ones.
152−--
153−-- You /should/ always override the default (empty) value for these properties,
154−-- although it is not strictly necessary:
155−--
156−-- >>> encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" }
157−-- "{\"version\":\"1.0\",\"title\":\"Todo API\"}"
158−--
159−-- You can merge two values using @'mappend'@ or its infix version @('<>')@:
160−--
161−-- >>> encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" }
162−-- "{\"version\":\"1.0\",\"title\":\"Todo API\"}"
163−--
164−-- This can be useful for combining specifications of endpoints into a whole API specification:
165−--
166−-- @
167−-- \-\- /account subAPI specification
168−-- accountAPI :: Swagger
169−--
170−-- \-\- /task subAPI specification
171−-- taskAPI :: Swagger
172−--
173−-- \-\- while API specification is just a combination
174−-- \-\- of subAPIs' specifications
175−-- api :: Swagger
176−-- api = accountAPI <> taskAPI
177−-- @
178−
179−-- $lens
180−--
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
184−-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
185−-- make it fairly simple to construct/modify any part of the specification:
186−--
187−-- >>> :{
188−-- encode $ (mempty :: Swagger)
189−-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
190−-- & paths .~
191−-- [ ("/user", mempty & get ?~ (mempty
192−-- & produces ?~ MimeList ["application/json"]
193−-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))
194−-- & at 404 ?~ "User info not found")) ]
195−-- :}
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\"}}}"
197−--
198−-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
199−-- which produces @application/json@ output. It should respond with code @200@ and body specified
200−-- by schema @User@ which is defined in @'definitions'@ property of swagger specification.
201−-- Alternatively it may respond with code @404@ meaning that user info is not found.
202−--
203−-- For convenience, @swagger2@ uses /classy field lenses/. It means that
204−-- field accessor names can be overloaded for different types. One such
205−-- common field is @'description'@. Many components of a Swagger specification
206−-- can have descriptions, and you can use the same name for them:
207−--
208−-- >>> encode $ (mempty :: Response) & description .~ "No content"
209−-- "{\"description\":\"No content\"}"
210−-- >>> :{
211−-- encode $ (mempty :: Schema)
212−-- & type_ ?~ SwaggerBoolean
213−-- & description ?~ "To be or not to be"
214−-- :}
215−-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
216−--
217−-- @'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.
219−-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
220−--
221−-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber
222−-- "{\"type\":\"number\"}"
223−--
224−-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
225−-- have direct access to it via @'at' code@. Example:
226−--
227−-- >>> :{
228−-- encode $ (mempty :: Operation)
229−-- & at 404 ?~ "Not found"
230−-- :}
231−-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"
232−--
233−-- You might've noticed that @'type_'@ has an extra underscore in its name
234−-- compared to, say, @'description'@ field accessor.
235−-- This is because @type@ is a keyword in Haskell.
236−-- A few other field accessors are modified in this way:
237−--
238−-- - @'in_'@, @'type_'@, @'default_'@ (as keywords);
239−-- - @'maximum_'@, @'minimum_'@, @'head_'@ (as conflicting with @Prelude@);
240−-- - @'enum_'@ (as conflicting with @Control.Lens@).
241−
242−-- $schema
243−--
244−-- @'ParamSchema'@ and @'Schema'@ are the two core types for data model specification.
245−--
246−-- @'ParamSchema' t@ specifies all the common properties, available for every data schema.
247−-- The @t@ parameter imposes some restrictions on @type@ and @items@ properties (see @'SwaggerType'@ and @'SwaggerItems'@).
248−--
249−-- @'Schema'@ is used for request and response bodies and allows specifying objects
250−-- with properties in addition to what @'ParamSchema'@ provides.
251−--
252−-- In most cases you will have a Haskell data type for which you would like to
253−-- define a corresponding schema. To facilitate this use case
254−-- @swagger2@ provides two classes for schema encoding.
255−-- Both these classes provide means to encode /types/ as Swagger /schemas/.
256−--
257−-- @'ToParamSchema'@ is intended to be used for primitive API endpoint parameters,
258−-- such as query parameters, headers and URL path pieces.
259−-- Its corresponding value-encoding class is @'ToHttpApiData'@ (from @http-api-data@ package).
260−--
261−-- @'ToSchema'@ is used for request and response bodies and mostly differ from
262−-- primitive parameters by allowing objects/mappings in addition to primitive types and arrays.
263−-- Its corresponding value-encoding class is @'ToJSON'@ (from @aeson@ package).
264−--
265−-- While lenses and prisms make it easy to define schemas, it might be that you don't need to:
266−-- @'ToSchema'@ and @'ToParamSchema'@ classes both have default @'Generic'@-based implementations!
267−--
268−-- @'ToSchema'@ default implementation is also aligned with @'ToJSON'@ default implementation with
269−-- the only difference being for sum encoding. @'ToJSON'@ defaults sum encoding to @'defaultTaggedObject'@,
270−-- while @'ToSchema'@ defaults to something which corresponds to @'ObjectWithSingleField'@. This is due to
271−-- @'defaultTaggedObject'@ behavior being hard to specify in Swagger.
272−--
273−-- Here's an example showing @'ToJSON'@–@'ToSchema'@ correspondance:
274−--
275−-- >>> data Person = Person { name :: String, age :: Integer } deriving Generic
276−-- >>> instance ToJSON Person
277−-- >>> instance ToSchema Person
278−-- >>> encode (Person "David" 28)
279−-- "{\"age\":28,\"name\":\"David\"}"
280−-- >>> encode $ toSchema (Proxy :: Proxy Person)
281−-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
282−--
283−-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a
284−-- schema for basic enums like
285−--
286−-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic
287−-- >>> instance ToSchema SampleEnum
288−-- >>> instance ToJSON SampleEnum
289−--
290−-- and for sum types that have constructors with values
291−--
292−-- >>> data SampleSumType = ChoiceInt Int | ChoiceString String deriving Generic
293−-- >>> instance ToSchema SampleSumType
294−-- >>> instance ToJSON SampleSumType
295−--
296−-- we can not derive a valid schema for a mix of the above. The following will result in a type error
297−--
298−#if __GLASGOW_HASKELL__ < 800
299−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
300−-- >>> instance ToSchema BadMixedType
301−-- ...
302−-- ... error:
303−-- ... • No instance for (Data.Swagger.Internal.TypeShape.CannotDeriveSchemaForMixedSumType
304−-- ... BadMixedType)
305−-- ... arising from a use of ‘Data.Swagger.Internal.Schema.$dmdeclareNamedSchema’
306−-- ... • In the expression:
307−-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
308−-- ... In an equation for ‘declareNamedSchema’:
309−-- ... declareNamedSchema
310−-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
311−-- ... In the instance declaration for ‘ToSchema BadMixedType’
312−#else
313−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
314−-- >>> instance ToSchema BadMixedType
315−-- ...
316−-- ... error:
317−-- ... • Cannot derive Generic-based Swagger Schema for BadMixedType
318−-- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors).
319−-- ... Swagger does not have a good representation for these types.
320−-- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema
321−-- ... that matches aeson's Generic-based toJSON,
322−-- ... but that's not supported by some Swagger tools.
323−-- ... • In the expression:
324−-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
325−-- ... In an equation for ‘declareNamedSchema’:
326−-- ... declareNamedSchema
327−-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
328−-- ... In the instance declaration for ‘ToSchema BadMixedType’
329−#endif
330−--
331−-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON':
332−--
333−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
334−-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
335−-- >>> instance ToJSON BadMixedType
336−--
337−
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.hsdeleted−199
@@ -1,199 +0,0 @@
1−{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
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.
12−module Data.Swagger.Declare where
13−
14−import Prelude ()
15−import Prelude.Compat
16−
17−import Control.Monad
18−import Control.Monad.Cont (ContT)
19−import Control.Monad.List (ListT)
20−import Control.Monad.Reader (ReaderT)
21−import 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
31−import Data.Functor.Identity
32−
33−-- | A declare monad transformer parametrized by:
34−--
35−-- * @d@ — the output to accumulate (declarations);
36−--
37−-- * @m@ — the inner monad.
38−--
39−-- This monad transformer is similar to both state and writer monad transformers.
40−-- Thus it can be seen as
41−--
42−-- * a restricted append-only version of a state monad transformer or
43−--
44−-- * a writer monad transformer with the extra ability to read all previous output.
45−newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
46− deriving (Functor)
47−
48−instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
49− pure x = DeclareT (\_ -> pure (mempty, x))
50− DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
51− ~(d', f) <- df d
52− ~(d'', x) <- dx (mappend d d')
53− return (mappend d' d'', f x)
54−
55−instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
56− return x = DeclareT (\_ -> pure (mempty, x))
57− DeclareT dx >>= f = DeclareT $ \d -> do
58− ~(d', x) <- dx d
59− ~(d'', y) <- runDeclareT (f x) (mappend d d')
60− return (mappend d' d'', y)
61−
62−instance Monoid d => MonadTrans (DeclareT d) where
63− lift m = DeclareT (\_ -> (,) mempty `liftM` m)
64−
65−-- |
66−-- Definitions of @declare@ and @look@ must satisfy the following laws:
67−--
68−-- [/monoid homomorphism (mempty)/]
69−-- @'declare' mempty == return ()@
70−--
71−-- [/monoid homomorphism (mappend)/]
72−-- @'declare' x >> 'declare' y == 'declare' (x <> y)@
73−-- for every @x@, @y@
74−--
75−-- [/@declare@-@look@/]
76−-- @'declare' x >> 'look' == 'fmap' (<> x) 'look' <* 'declare' x@
77−-- for every @x@
78−--
79−-- [/@look@ as left identity/]
80−-- @'look' >> m == m@
81−-- for every @m@
82−class (Applicative m, Monad m) => MonadDeclare d m | m -> d where
83− -- | @'declare' x@ is an action that produces the output @x@.
84− declare :: d -> m ()
85− -- | @'look'@ is an action that returns all the output so far.
86− look :: m d
87−
88−instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
89− declare d = DeclareT (\_ -> return (d, ()))
90− look = DeclareT (\d -> return (mempty, d))
91−
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.
100−looks :: MonadDeclare d m => (d -> a) -> m a
101−looks f = f <$> look
102−
103−-- | Evaluate @'DeclareT' d m a@ computation,
104−-- ignoring new output @d@.
105−evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
106−evalDeclareT (DeclareT f) d = snd `liftM` f d
107−
108−-- | Execute @'DeclateT' d m a@ computation,
109−-- ignoring result and only producing new output @d@.
110−execDeclareT :: Monad m => DeclareT d m a -> d -> m d
111−execDeclareT (DeclareT f) d = fst `liftM` f d
112−
113−-- | Evaluate @'DeclareT' d m a@ computation,
114−-- starting with empty output history.
115−undeclareT :: (Monad m, Monoid d) => DeclareT d m a -> m a
116−undeclareT = flip evalDeclareT mempty
117−
118−-- | A declare monad parametrized by @d@ — the output to accumulate (declarations).
119−--
120−-- This monad is similar to both state and writer monads.
121−-- Thus it can be seen as
122−--
123−-- * a restricted append-only version of a state monad or
124−--
125−-- * a writer monad with the extra ability to read all previous output.
126−type Declare d = DeclareT d Identity
127−
128−-- | Run @'Declare' d a@ computation with output history @d@,
129−-- producing result @a@ and new output @d@.
130−runDeclare :: Declare d a -> d -> (d, a)
131−runDeclare m = runIdentity . runDeclareT m
132−
133−-- | Evaluate @'Declare' d a@ computation, ignoring output @d@.
134−evalDeclare :: Declare d a -> d -> a
135−evalDeclare m = runIdentity . evalDeclareT m
136−
137−-- | Execute @'Declate' d a@ computation, ignoring result and only
138−-- producing output @d@.
139−execDeclare :: Declare d a -> d -> d
140−execDeclare m = runIdentity . execDeclareT m
141−
142−-- | Evaluate @'DeclareT' d m a@ computation,
143−-- starting with empty output history.
144−undeclare :: Monoid d => Declare d a -> a
145−undeclare = runIdentity . undeclareT
146−
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+385−803
@@ -1,140 +1,96 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
4−{-# LANGUAGE DeriveFunctor #-}
51{-# LANGUAGE DeriveGeneric #-}
62{-# LANGUAGE DeriveTraversable #-}
7−{-# LANGUAGE FlexibleContexts #-}
83{-# LANGUAGE FlexibleInstances #-}
9−{-# LANGUAGE GADTs #-}
104{-# LANGUAGE GeneralizedNewtypeDeriving #-}
115{-# LANGUAGE OverloadedStrings #-}
126{-# LANGUAGE RecordWildCards #-}
137{-# LANGUAGE ScopedTypeVariables #-}
148{-# LANGUAGE StandaloneDeriving #-}
159{-# LANGUAGE TemplateHaskell #-}
16−{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE UndecidableInstances #-}
18−#if __GLASGOW_HASKELL__ <710
19−{-# LANGUAGE PolyKinds #-}
20−#endif
21−#include "overlapping-compat.h"
2210module Data.Swagger.Internal where
2311
24−import Prelude ()
25−import Prelude.Compat
26−
27−import Control.Lens ((&), (.~), (?~))
2812import Control.Applicative
13+import Control.Monad
2914import Data.Aeson
30−import qualified Data.Aeson.Types as JSON
31−import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
32−import Data.Hashable (Hashable)
15+import Data.Aeson.TH (deriveJSON)
16+import Data.Foldable (Foldable)
17+import Data.HashMap.Strict (HashMap)
3318import qualified Data.HashMap.Strict as HashMap
34−import Data.HashSet.InsOrd (InsOrdHashSet)
3519import Data.Map (Map)
3620import qualified Data.Map as Map
37−import Data.Monoid (Monoid (..))
38−import Data.Semigroup.Compat (Semigroup (..))
39−import Data.Scientific (Scientific)
40−import Data.String (IsString(..))
21+import Data.Monoid
22+import Data.String (fromString)
4123import Data.Text (Text)
4224import qualified Data.Text as Text
25+import Data.Traversable (Traversable)
26+import Data.Hashable (Hashable)
4327import GHC.Generics (Generic)
44−import Network.Socket (HostName, PortNumber)
28+import Network (HostName, PortNumber)
4529import Network.HTTP.Media (MediaType)
4630import Text.Read (readMaybe)
4731
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)
6032import Data.Swagger.Internal.Utils
6133
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.
74−type Definitions = InsOrdHashMap Text
75−
7634-- | This is the root document object for the API specification.
7735data Swagger = Swagger
7836 { -- | Provides metadata about the API.
7937 -- The metadata can be used by the clients if needed.
80− _swaggerInfo :: Info
38+ _info :: Info
8139
8240 -- | The host (name or ip) serving the API. It MAY include a port.
8341 -- If the host is not included, the host serving the documentation is to be used (including the port).
84− , _swaggerHost :: Maybe Host
42+ , _host :: Maybe Host
8543
8644 -- | The base path on which the API is served, which is relative to the host.
8745 -- If it is not included, the API is served directly under the host.
8846 -- The value MUST start with a leading slash (/).
89− , _swaggerBasePath :: Maybe FilePath
47+ , _basePath :: Maybe FilePath
9048
9149 -- | The transfer protocol of the API.
9250 -- If the schemes is not included, the default scheme to be used is the one used to access the Swagger definition itself.
93− , _swaggerSchemes :: Maybe [Scheme]
51+ , _schemes :: Maybe [Scheme]
9452
9553 -- | A list of MIME types the APIs can consume.
9654 -- This is global to all APIs but can be overridden on specific API calls.
97− , _swaggerConsumes :: MimeList
55+ , _consumes :: MimeList
9856
9957 -- | A list of MIME types the APIs can produce.
100− -- This is global to all APIs but can be overridden on specific API calls.
101− , _swaggerProduces :: MimeList
58+ -- This is global to all APIs but can be overridden on specific API calls.
59+ , _produces :: MimeList
10260
10361 -- | The available paths and operations for the API.
104− -- Holds the relative paths to the individual endpoints.
105− -- The path is appended to the @'basePath'@ in order to construct the full URL.
106− , _swaggerPaths :: InsOrdHashMap FilePath PathItem
62+ , _paths :: Paths
10763
10864 -- | An object to hold data types produced and consumed by operations.
109− , _swaggerDefinitions :: Definitions Schema
65+ , _definitions :: HashMap Text Schema
11066
11167 -- | An object to hold parameters that can be used across operations.
11268 -- This property does not define global parameters for all operations.
113− , _swaggerParameters :: Definitions Param
69+ , _parameters :: HashMap Text Parameter
11470
11571 -- | An object to hold responses that can be used across operations.
11672 -- This property does not define global responses for all operations.
117− , _swaggerResponses :: Definitions Response
73+ , _responses :: HashMap Text Response
11874
11975 -- | Security scheme definitions that can be used across the specification.
120− , _swaggerSecurityDefinitions :: SecurityDefinitions
76+ , _securityDefinitions :: HashMap Text SecurityScheme
12177
12278 -- | A declaration of which security schemes are applied for the API as a whole.
12379 -- The list of values describes alternative security schemes that can be used
12480 -- (that is, there is a logical OR between the security requirements).
12581 -- Individual operations can override this definition.
126− , _swaggerSecurity :: [SecurityRequirement]
82+ , _security :: [SecurityRequirement]
12783
12884 -- | A list of tags used by the specification with additional metadata.
12985 -- The order of the tags can be used to reflect on their order by the parsing tools.
13086 -- Not all tags that are used by the Operation Object must be declared.
13187 -- The tags that are not declared may be organized randomly or based on the tools' logic.
13288 -- Each tag name in the list MUST be unique.
133− , _swaggerTags :: InsOrdHashSet Tag
89+ , _tags :: [Tag]
13490
13591 -- | Additional external documentation.
136− , _swaggerExternalDocs :: Maybe ExternalDocs
137− } deriving (Eq, Show, Generic, Data, Typeable)
92+ , _externalDocs :: Maybe ExternalDocs
93+ } deriving (Eq, Show, Generic)
13894
13995-- | The object provides metadata about the API.
14096-- The metadata can be used by the clients if needed,
@@ -159,7 +115,7 @@ data Info = Info
159115 -- | Provides the version of the application API
160116 -- (not to be confused with the specification version).
161117 , _infoVersion :: Text
162− } deriving (Eq, Show, Generic, Data, Typeable)
118+ } deriving (Eq, Show, Generic)
163119
164120-- | Contact information for the exposed API.
165121data Contact = Contact
@@ -171,7 +127,7 @@ data Contact = Contact
171127
172128 -- | The email address of the contact person/organization.
173129 , _contactEmail :: Maybe Text
174− } deriving (Eq, Show, Generic, Data, Typeable)
130+ } deriving (Eq, Show)
175131
176132-- | License information for the exposed API.
177133data License = License
@@ -180,32 +136,13 @@ data License = License
180136
181137 -- | A URL to the license used for the API.
182138 , _licenseUrl :: Maybe URL
183− } deriving (Eq, Show, Generic, Data, Typeable)
184−
185−instance IsString License where
186− fromString s = License (fromString s) Nothing
139+ } deriving (Eq, Show)
187140
188141-- | The host (name or ip) serving the API. It MAY include a port.
189142data Host = Host
190143 { _hostName :: HostName -- ^ Host name.
191144 , _hostPort :: Maybe PortNumber -- ^ Optional port.
192− } deriving (Eq, Show, Generic, Typeable)
193−
194−instance IsString Host where
195− fromString s = Host s Nothing
196−
197−hostConstr :: Constr
198−hostConstr = mkConstr hostDataType "Host" [] Prefix
199−
200−hostDataType :: DataType
201−hostDataType = mkDataType "Data.Swagger.Host" [hostConstr]
202−
203−instance Data Host where
204− gunfold k z c = case constrIndex c of
205− 1 -> k (k (z (\name mport -> Host name (fromInteger <$> mport))))
206− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Host."
207− toConstr (Host _ _) = hostConstr
208− dataTypeOf _ = hostDataType
145+ } deriving (Eq, Show)
209146
210147-- | The transfer protocol of the API.
211148data Scheme
@@ -213,7 +150,14 @@ data Scheme
213150 | Https
214151 | Ws
215152 | Wss
216− deriving (Eq, Show, Generic, Data, Typeable)
153+ deriving (Eq, Show)
154+
155+-- | The available paths and operations for the API.
156+data Paths = Paths
157+ { -- | Holds the relative paths to the individual endpoints.
158+ -- The path is appended to the @'basePath'@ in order to construct the full URL.
159+ _pathsMap :: HashMap FilePath PathItem
160+ } deriving (Eq, Show, Generic)
217161
218162-- | Describes the operations available on a single path.
219163-- A @'PathItem'@ may be empty, due to ACL constraints.
@@ -245,14 +189,14 @@ data PathItem = PathItem
245189 -- These parameters can be overridden at the operation level, but cannot be removed there.
246190 -- The list MUST NOT include duplicated parameters.
247191 -- A unique parameter is defined by a combination of a name and location.
248− , _pathItemParameters :: [Referenced Param]
249− } deriving (Eq, Show, Generic, Data, Typeable)
192+ , _pathItemParameters :: [Referenced Parameter]
193+ } deriving (Eq, Show, Generic)
250194
251195-- | Describes a single API operation on a path.
252196data Operation = Operation
253197 { -- | A list of tags for API documentation control.
254198 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
255− _operationTags :: InsOrdHashSet TagName
199+ _operationTags :: [Text]
256200
257201 -- | A short summary of what the operation does.
258202 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -286,7 +230,7 @@ data Operation = Operation
286230 -- the new definition will override it, but can never remove it.
287231 -- The list MUST NOT include duplicated parameters.
288232 -- A unique parameter is defined by a combination of a name and location.
289− , _operationParameters :: [Referenced Param]
233+ , _operationParameters :: [Referenced Parameter]
290234
291235 -- | The list of possible responses as they are returned from executing this operation.
292236 , _operationResponses :: Responses
@@ -306,205 +250,88 @@ data Operation = Operation
306250 -- This definition overrides any declared top-level security.
307251 -- To remove a top-level security declaration, @Just []@ can be used.
308252 , _operationSecurity :: [SecurityRequirement]
309− } deriving (Eq, Show, Generic, Data, Typeable)
253+ } deriving (Eq, Show, Generic)
310254
311255newtype MimeList = MimeList { getMimeList :: [MediaType] }
312− deriving (Eq, Show, Semigroup, Monoid, Typeable)
313−
314−mimeListConstr :: Constr
315−mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
316−
317−mimeListDataType :: DataType
318−mimeListDataType = mkDataType "Data.Swagger.MimeList" [mimeListConstr]
319−
320−instance Data MimeList where
321− gunfold k z c = case constrIndex c of
322− 1 -> k (z (\xs -> MimeList (map fromString xs)))
323− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MimeList."
324− toConstr (MimeList _) = mimeListConstr
325− dataTypeOf _ = mimeListDataType
256+ deriving (Eq, Show, Monoid)
326257
327258-- | Describes a single operation parameter.
328259-- A unique parameter is defined by a combination of a name and location.
329−data Param = Param
260+data Parameter = Parameter
330261 { -- | The name of the parameter.
331262 -- Parameter names are case sensitive.
332− _paramName :: Text
263+ _parameterName :: Text
333264
334265 -- | A brief description of the parameter.
335266 -- This could contain examples of use.
336267 -- GFM syntax can be used for rich text representation.
337− , _paramDescription :: Maybe Text
268+ , _parameterDescription :: Maybe Text
338269
339270 -- | Determines whether this parameter is mandatory.
340271 -- If the parameter is in "path", this property is required and its value MUST be true.
341272 -- Otherwise, the property MAY be included and its default value is @False@.
342− , _paramRequired :: Maybe Bool
273+ , _parameterRequired :: Maybe Bool
343274
344275 -- | Parameter schema.
345− , _paramSchema :: ParamAnySchema
346− } deriving (Eq, Show, Generic, Data, Typeable)
276+ , _parameterSchema :: ParameterSchema
277+ } deriving (Eq, Show, Generic)
347278
348−data ParamAnySchema
349− = ParamBody (Referenced Schema)
350− | ParamOther ParamOtherSchema
351− deriving (Eq, Show, Generic, Data, Typeable)
279+data ParameterSchema
280+ = ParameterBody (Referenced Schema)
281+ | ParameterOther ParameterOtherSchema
282+ deriving (Eq, Show)
352283
353−data ParamOtherSchema = ParamOtherSchema
284+data ParameterOtherSchema = ParameterOtherSchema
354285 { -- | The location of the parameter.
355− _paramOtherSchemaIn :: ParamLocation
286+ _parameterOtherSchemaIn :: ParameterLocation
287+
288+ -- | The type of the parameter.
289+ -- Since the parameter is not located at the request body,
290+ -- it is limited to simple types (that is, not an object).
291+ -- If type is @'ParamFile'@, the @consumes@ MUST be either
292+ -- "multipart/form-data" or " application/x-www-form-urlencoded"
293+ -- and the parameter MUST be in @'ParameterFormData'@.
294+ , _parameterOtherSchemaType :: ParameterType
295+
296+ -- | The extending format for the previously mentioned type.
297+ , _parameterOtherSchemaFormat :: Maybe Format
356298
357299 -- | Sets the ability to pass empty-valued parameters.
358− -- This is valid only for either @'ParamQuery'@ or @'ParamFormData'@
300+ -- This is valid only for either @'ParameterQuery'@ or @'ParameterFormData'@
359301 -- and allows you to send a parameter with a name only or an empty value.
360302 -- Default value is @False@.
361− , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
362−
363− , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
364− } deriving (Eq, Show, Generic, Typeable, Data)
365−
366−-- | Items for @'SwaggerArray'@ schemas.
367−--
368−-- @'SwaggerItemsPrimitive'@ should be used only for query params, headers and path pieces.
369−-- The @'CollectionFormat' t@ parameter specifies how elements of an array should be displayed.
370−-- Note that @fmt@ in @'SwaggerItemsPrimitive' fmt schema@ specifies format for elements of type @schema@.
371−-- This is different from the original Swagger's <http://swagger.io/specification/#itemsObject Items Object>.
372−--
373−-- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s.
374−--
375−-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
376−data SwaggerItems t where
377− SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k
378− SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema
379− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
380− deriving (Typeable)
381−
382−deriving instance Eq (SwaggerItems t)
383−deriving instance Show (SwaggerItems t)
384−--deriving instance Typeable (SwaggerItems t)
385−
386−swaggerItemsPrimitiveConstr :: Constr
387−swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
388−
389−swaggerItemsObjectConstr :: Constr
390−swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix
391−
392−swaggerItemsArrayConstr :: Constr
393−swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix
394−
395−swaggerItemsDataType :: DataType
396−swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
397−
398−-- Note: unfortunately we have to write these Data instances by hand,
399−-- to get better contexts / avoid duplicate name when using standalone deriving
400−
401−instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where
402− -- TODO: define gfoldl
403− gunfold k z c = case constrIndex c of
404− 1 -> k (k (z SwaggerItemsPrimitive))
405− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
406− toConstr _ = swaggerItemsPrimitiveConstr
407− dataTypeOf _ = swaggerItemsDataType
408−
409−-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only
410−instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where
411− -- TODO: define gfoldl
412− gunfold k z c = case constrIndex c of
413− 1 -> k (k (z SwaggerItemsPrimitive))
414− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindParamOtherSchema)."
415− toConstr _ = swaggerItemsPrimitiveConstr
416− dataTypeOf _ = swaggerItemsDataType
417−
418−instance Data (SwaggerItems 'SwaggerKindSchema) where
419− gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema"
420− gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref
421− gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref
422−
423− gunfold k z c = case constrIndex c of
424− 2 -> k (z SwaggerItemsObject)
425− 3 -> k (z SwaggerItemsArray)
426− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)."
427−
428− toConstr (SwaggerItemsPrimitive _ _) = error "Not supported"
429− toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr
430− toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr
431−
432− dataTypeOf _ = swaggerItemsDataType
433−
434−-- | Type used as a kind to avoid overlapping instances.
435−data SwaggerKind t
436− = SwaggerKindNormal t
437− | SwaggerKindParamOtherSchema
438− | SwaggerKindSchema
439− deriving (Typeable)
440−
441−deriving instance Typeable 'SwaggerKindNormal
442−deriving instance Typeable 'SwaggerKindParamOtherSchema
443−deriving instance Typeable 'SwaggerKindSchema
444−
445−type family SwaggerKindType (k :: SwaggerKind *) :: *
446−type instance SwaggerKindType ('SwaggerKindNormal t) = t
447−type instance SwaggerKindType 'SwaggerKindSchema = Schema
448−type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema
449−
450−data SwaggerType t where
451− SwaggerString :: SwaggerType t
452− SwaggerNumber :: SwaggerType t
453− SwaggerInteger :: SwaggerType t
454− SwaggerBoolean :: SwaggerType t
455− SwaggerArray :: SwaggerType t
456− SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema
457− SwaggerNull :: SwaggerType 'SwaggerKindSchema
458− SwaggerObject :: SwaggerType 'SwaggerKindSchema
459− deriving (Typeable)
460−
461−deriving instance Eq (SwaggerType t)
462−deriving instance Show (SwaggerType t)
463−
464−swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
465−swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
466−
467−swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType
468−swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
469−
470−swaggerCommonTypes :: [SwaggerType k]
471−swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
472−
473−swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]
474−swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
475−
476−swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]
477−swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
478−
479−swaggerTypeConstrs :: [Constr]
480−swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema])
481− ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
482−
483−instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where
484− gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
485− toConstr = swaggerTypeConstr
486− dataTypeOf = swaggerTypeDataType
487−
488−instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where
489− gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
490− toConstr = swaggerTypeConstr
491− dataTypeOf = swaggerTypeDataType
492−
493−instance Data (SwaggerType 'SwaggerKindSchema) where
494− gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
495− toConstr = swaggerTypeConstr
496− dataTypeOf = swaggerTypeDataType
497−
498−data ParamLocation
303+ , _parameterOtherSchemaAllowEmptyValue :: Maybe Bool
304+
305+ -- | __Required if type is @'ParamArray'@__.
306+ -- Describes the type of items in the array.
307+ , _parameterOtherSchemaItems :: Maybe Items
308+
309+ -- | Determines the format of the array if @'ParamArray'@ is used.
310+ -- Default value is csv.
311+ , _parameterOtherSchemaCollectionFormat :: Maybe CollectionFormat
312+
313+ , _parameterOtherSchemaCommon :: SchemaCommon
314+ } deriving (Eq, Show, Generic)
315+
316+data ParameterType
317+ = ParamString
318+ | ParamNumber
319+ | ParamInteger
320+ | ParamBoolean
321+ | ParamArray
322+ | ParamFile
323+ deriving (Eq, Show)
324+
325+data ParameterLocation
499326 = -- | Parameters that are appended to the URL.
500327 -- For example, in @/items?id=###@, the query parameter is @id@.
501− ParamQuery
328+ ParameterQuery
502329 -- | Custom headers that are expected as part of the request.
503− | ParamHeader
330+ | ParameterHeader
504331 -- | Used together with Path Templating, where the parameter value is actually part of the operation's URL.
505332 -- This does not include the host or base path of the API.
506333 -- For example, in @/items/{itemId}@, the path parameter is @itemId@.
507− | ParamPath
334+ | ParameterPath
508335 -- | Used to describe the payload of an HTTP request when either @application/x-www-form-urlencoded@
509336 -- or @multipart/form-data@ are used as the content type of the request
510337 -- (in Swagger's definition, the @consumes@ property of an operation).
@@ -512,57 +339,61 @@ data ParamLocation
512339 -- Since form parameters are sent in the payload, they cannot be declared together with a body parameter for the same operation.
513340 -- Form parameters have a different format based on the content-type used
514341 -- (for further details, consult <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).
515− | ParamFormData
516− deriving (Eq, Show, Generic, Data, Typeable)
342+ | ParameterFormData
343+ deriving (Eq, Show)
517344
518345type Format = Text
519346
520347-- | Determines the format of the array.
521−data CollectionFormat t where
522− -- Comma separated values: @foo,bar@.
523− CollectionCSV :: CollectionFormat t
524− -- Space separated values: @foo bar@.
525− CollectionSSV :: CollectionFormat t
526− -- Tab separated values: @foo\\tbar@.
527− CollectionTSV :: CollectionFormat t
528− -- Pipe separated values: @foo|bar@.
529− CollectionPipes :: CollectionFormat t
530− -- Corresponds to multiple parameter instances
531− -- instead of multiple values for a single instance @foo=bar&foo=baz@.
532− -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
533− CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema
534− deriving (Typeable)
535−
536−deriving instance Eq (CollectionFormat t)
537−deriving instance Show (CollectionFormat t)
538−
539−collectionFormatConstr :: CollectionFormat t -> Constr
540−collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix
541−
542−collectionFormatDataType :: DataType
543−collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
544− map collectionFormatConstr collectionCommonFormats
545−
546−collectionCommonFormats :: [CollectionFormat t]
547−collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
548−
549−instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where
550− gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
551− toConstr = collectionFormatConstr
552− dataTypeOf _ = collectionFormatDataType
553−
554−deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)
348+data CollectionFormat
349+ = CollectionCSV -- ^ Comma separated values: @foo,bar@.
350+ | CollectionSSV -- ^ Space separated values: @foo bar@.
351+ | CollectionTSV -- ^ Tab separated values: @foo\\tbar@.
352+ | CollectionPipes -- ^ Pipe separated values: @foo|bar@.
353+ | CollectionMulti -- ^ Corresponds to multiple parameter instances
354+ -- instead of multiple values for a single instance @foo=bar&foo=baz@.
355+ -- This is valid only for parameters in @'ParameterQuery'@ or @'ParameterFormData'@.
356+ deriving (Eq, Show)
357+
358+data ItemsType
359+ = ItemsString
360+ | ItemsNumber
361+ | ItemsInteger
362+ | ItemsBoolean
363+ | ItemsArray
364+ deriving (Eq, Show)
365+
366+data SchemaType
367+ = SchemaArray
368+ | SchemaBoolean
369+ | SchemaInteger
370+ | SchemaNumber
371+ | SchemaNull
372+ | SchemaObject
373+ | SchemaString
374+ deriving (Eq, Show)
375+
376+-- | Determines the format of the nested array.
377+data ItemsCollectionFormat
378+ = ItemsCollectionCSV -- ^ Comma separated values: @foo,bar@.
379+ | ItemsCollectionSSV -- ^ Space separated values: @foo bar@.
380+ | ItemsCollectionTSV -- ^ Tab separated values: @foo\\tbar@.
381+ | ItemsCollectionPipes -- ^ Pipe separated values: @foo|bar@.
382+ deriving (Eq, Show)
555383
556384type ParamName = Text
557385
558386data Schema = Schema
559− { _schemaTitle :: Maybe Text
387+ { _schemaType :: SchemaType
388+ , _schemaFormat :: Maybe Format
389+ , _schemaTitle :: Maybe Text
560390 , _schemaDescription :: Maybe Text
561391 , _schemaRequired :: [ParamName]
562392
563− , _schemaAllOf :: Maybe [Referenced Schema]
564− , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
565− , _schemaAdditionalProperties :: Maybe AdditionalProperties
393+ , _schemaItems :: Maybe SchemaItems
394+ , _schemaAllOf :: Maybe [Schema]
395+ , _schemaProperties :: HashMap Text (Referenced Schema)
396+ , _schemaAdditionalProperties :: Maybe Schema
566397
567398 , _schemaDiscriminator :: Maybe Text
568399 , _schemaReadOnly :: Maybe Bool
@@ -573,49 +404,39 @@ data Schema = Schema
573404 , _schemaMaxProperties :: Maybe Integer
574405 , _schemaMinProperties :: Maybe Integer
575406
576− , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema
577− } deriving (Eq, Show, Generic, Data, Typeable)
407+ , _schemaSchemaCommon :: SchemaCommon
408+ } deriving (Eq, Show, Generic)
578409
579−-- | A @'Schema'@ with an optional name.
580−-- This name can be used in references.
581−data NamedSchema = NamedSchema
582− { _namedSchemaName :: Maybe Text
583− , _namedSchemaSchema :: Schema
584− } deriving (Eq, Show, Generic, Data, Typeable)
410+data SchemaItems
411+ = SchemaItemsObject (Referenced Schema)
412+ | SchemaItemsArray [Referenced Schema]
413+ deriving (Eq, Show)
585414
586−-- | Regex pattern for @string@ type.
587−type Pattern = Text
588−
589−data ParamSchema (t :: SwaggerKind *) = ParamSchema
415+data SchemaCommon = SchemaCommon
590416 { -- | Declares the value of the parameter that the server will use if none is provided,
591417 -- for example a @"count"@ to control the number of results per page might default to @100@
592418 -- if not supplied by the client in the request.
593419 -- (Note: "default" has no meaning for required parameters.)
594420 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
595− _paramSchemaDefault :: Maybe Value
596−
597− , _paramSchemaType :: Maybe (SwaggerType t)
598− , _paramSchemaFormat :: Maybe Format
599− , _paramSchemaItems :: Maybe (SwaggerItems t)
600− , _paramSchemaMaximum :: Maybe Scientific
601− , _paramSchemaExclusiveMaximum :: Maybe Bool
602− , _paramSchemaMinimum :: Maybe Scientific
603− , _paramSchemaExclusiveMinimum :: Maybe Bool
604− , _paramSchemaMaxLength :: Maybe Integer
605− , _paramSchemaMinLength :: Maybe Integer
606− , _paramSchemaPattern :: Maybe Pattern
607− , _paramSchemaMaxItems :: Maybe Integer
608− , _paramSchemaMinItems :: Maybe Integer
609− , _paramSchemaUniqueItems :: Maybe Bool
610− , _paramSchemaEnum :: Maybe [Value]
611− , _paramSchemaMultipleOf :: Maybe Scientific
612− } deriving (Eq, Show, Generic, Typeable)
613−
614−deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)
421+ _schemaCommonDefault :: Maybe Value
422+
423+ , _schemaCommonMaximum :: Maybe Integer
424+ , _schemaCommonExclusiveMaximum :: Maybe Bool
425+ , _schemaCommonMinimum :: Maybe Integer
426+ , _schemaCommonExclusiveMinimum :: Maybe Bool
427+ , _schemaCommonMaxLength :: Maybe Integer
428+ , _schemaCommonMinLength :: Maybe Integer
429+ , _schemaCommonPattern :: Maybe Text
430+ , _schemaCommonMaxItems :: Maybe Integer
431+ , _schemaCommonMinItems :: Maybe Integer
432+ , _schemaCommonUniqueItems :: Maybe Bool
433+ , _schemaCommonEnum :: Maybe [Value]
434+ , _schemaCommonMultipleOf :: Maybe Integer
435+ } deriving (Eq, Show, Generic)
615436
616437data Xml = Xml
617438 { -- | Replaces the name of the element/attribute used for the described schema property.
618− -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list.
439+ -- When defined within the @'Items'@ (items), it will affect the name of the individual XML elements within the list.
619440 -- When defined alongside type being array (outside the items),
620441 -- it will affect the wrapping element and only if wrapped is true.
621442 -- If wrapped is false, it will be ignored.
@@ -639,7 +460,25 @@ data Xml = Xml
639460 -- Default value is @False@.
640461 -- The definition takes effect only when defined alongside type being array (outside the items).
641462 , _xmlWrapped :: Maybe Bool
642− } deriving (Eq, Show, Generic, Data, Typeable)
463+ } deriving (Eq, Show, Generic)
464+
465+data Items = Items
466+ { -- | The internal type of the array.
467+ _itemsType :: ItemsType
468+
469+ -- | The extending format for the previously mentioned type.
470+ , _itemsFormat :: Maybe Format
471+
472+ -- | __Required if type is @'ItemsArray'@.__
473+ -- Describes the type of items in the array.
474+ , _itemsItems :: Maybe Items
475+
476+ -- | Determines the format of the array if type array is used.
477+ -- Default value is @'ItemsCollectionCSV'@.
478+ , _itemsCollectionFormat :: Maybe ItemsCollectionFormat
479+
480+ , _itemsCommon :: SchemaCommon
481+ } deriving (Eq, Show, Generic)
643482
644483-- | A container for the expected responses of an operation.
645484-- The container maps a HTTP response code to the expected response.
@@ -653,8 +492,8 @@ data Responses = Responses
653492
654493 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
655494 -- Describes the expected response for those HTTP status codes.
656− , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)
657− } deriving (Eq, Show, Generic, Data, Typeable)
495+ , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
496+ } deriving (Eq, Show, Generic)
658497
659498type HttpStatusCode = Int
660499
@@ -672,14 +511,11 @@ data Response = Response
672511 , _responseSchema :: Maybe (Referenced Schema)
673512
674513 -- | A list of headers that are sent with the response.
675− , _responseHeaders :: InsOrdHashMap HeaderName Header
514+ , _responseHeaders :: HashMap HeaderName Header
676515
677516 -- | An example of the response message.
678517 , _responseExamples :: Maybe Example
679− } deriving (Eq, Show, Generic, Data, Typeable)
680−
681−instance IsString Response where
682− fromString s = Response (fromString s) Nothing mempty Nothing
518+ } deriving (Eq, Show, Generic)
683519
684520type HeaderName = Text
685521
@@ -687,30 +523,31 @@ data Header = Header
687523 { -- | A short description of the header.
688524 _headerDescription :: Maybe Text
689525
690− , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)
691− } deriving (Eq, Show, Generic, Data, Typeable)
526+ -- | The type of the object.
527+ , _headerType :: ItemsType
692528
693−data Example = Example { getExample :: Map MediaType Value }
694− deriving (Eq, Show, Generic, Typeable)
529+ -- | The extending format for the previously mentioned type. See Data Type Formats for further details.
530+ , _headerFormat :: Maybe Format
695531
696−exampleConstr :: Constr
697−exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix
532+ -- | __Required if type is @'ItemsArray'@__.
533+ -- Describes the type of items in the array.
534+ , _headerItems :: Maybe Items
698535
699−exampleDataType :: DataType
700−exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr]
536+ -- | Determines the format of the array if type array is used.
537+ -- Default value is @'ItemsCollectionCSV'@.
538+ , _headerCollectionFormat :: Maybe ItemsCollectionFormat
701539
702−instance Data Example where
703− gunfold k z c = case constrIndex c of
704− 1 -> k (z (\m -> Example (Map.mapKeys fromString m)))
705− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Example."
706− toConstr (Example _) = exampleConstr
707− dataTypeOf _ = exampleDataType
540+ , _headerCommon :: SchemaCommon
541+ } deriving (Eq, Show, Generic)
542+
543+data Example = Example { getExample :: Map MediaType Value }
544+ deriving (Eq, Show)
708545
709546-- | The location of the API key.
710547data ApiKeyLocation
711548 = ApiKeyQuery
712549 | ApiKeyHeader
713− deriving (Eq, Show, Generic, Data, Typeable)
550+ deriving (Eq, Show)
714551
715552data ApiKeyParams = ApiKeyParams
716553 { -- | The name of the header or query parameter to be used.
@@ -718,7 +555,7 @@ data ApiKeyParams = ApiKeyParams
718555
719556 -- | The location of the API key.
720557 , _apiKeyIn :: ApiKeyLocation
721− } deriving (Eq, Show, Generic, Data, Typeable)
558+ } deriving (Eq, Show)
722559
723560-- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
724561type AuthorizationURL = Text
@@ -731,21 +568,21 @@ data OAuth2Flow
731568 | OAuth2Password TokenURL
732569 | OAuth2Application TokenURL
733570 | OAuth2AccessCode AuthorizationURL TokenURL
734− deriving (Eq, Show, Generic, Data, Typeable)
571+ deriving (Eq, Show)
735572
736573data OAuth2Params = OAuth2Params
737574 { -- | The flow used by the OAuth2 security scheme.
738575 _oauth2Flow :: OAuth2Flow
739576
740577 -- | The available scopes for the OAuth2 security scheme.
741− , _oauth2Scopes :: InsOrdHashMap Text Text
742− } deriving (Eq, Show, Generic, Data, Typeable)
578+ , _oauth2Scopes :: HashMap Text Text
579+ } deriving (Eq, Show, Generic)
743580
744581data SecuritySchemeType
745582 = SecuritySchemeBasic
746583 | SecuritySchemeApiKey ApiKeyParams
747584 | SecuritySchemeOAuth2 OAuth2Params
748− deriving (Eq, Show, Generic, Data, Typeable)
585+ deriving (Eq, Show)
749586
750587data SecurityScheme = SecurityScheme
751588 { -- | The type of the security scheme.
@@ -753,39 +590,20 @@ data SecurityScheme = SecurityScheme
753590
754591 -- | A short description for security scheme.
755592 , _securitySchemeDescription :: Maybe Text
756− } deriving (Eq, Show, Generic, Data, Typeable)
757−
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)
593+ } deriving (Eq, Show, Generic)
773594
774595-- | Lists the required security schemes to execute this operation.
775596-- The object can have multiple security schemes declared in it which are all required
776597-- (that is, there is a logical AND between the schemes).
777598newtype SecurityRequirement = SecurityRequirement
778− { getSecurityRequirement :: InsOrdHashMap Text [Text]
779− } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
780−
781−-- | Tag name.
782−type TagName = Text
599+ { getSecurityRequirement :: HashMap Text [Text]
600+ } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON)
783601
784602-- | Allows adding meta data to a single tag that is used by @Operation@.
785603-- It is not mandatory to have a @Tag@ per tag used there.
786604data Tag = Tag
787605 { -- | The name of the tag.
788− _tagName :: TagName
606+ _tagName :: Text
789607
790608 -- | A short description for the tag.
791609 -- GFM syntax can be used for rich text representation.
@@ -793,12 +611,7 @@ data Tag = Tag
793611
794612 -- | Additional external documentation for this tag.
795613 , _tagExternalDocs :: Maybe ExternalDocs
796− } deriving (Eq, Ord, Show, Generic, Data, Typeable)
797−
798−instance Hashable Tag
799−
800−instance IsString Tag where
801− fromString s = Tag (fromString s) Nothing Nothing
614+ } deriving (Eq, Show)
802615
803616-- | Allows referencing an external resource for extended documentation.
804617data ExternalDocs = ExternalDocs
@@ -808,236 +621,170 @@ data ExternalDocs = ExternalDocs
808621
809622 -- | The URL for the target documentation.
810623 , _externalDocsUrl :: URL
811− } deriving (Eq, Ord, Show, Generic, Data, Typeable)
812−
813−instance Hashable ExternalDocs
624+ } deriving (Eq, Show, Generic)
814625
815626-- | A simple object to allow referencing other definitions in the specification.
816627-- It can be used to reference parameters and responses that are defined at the top level for reuse.
817628newtype Reference = Reference { getReference :: Text }
818− deriving (Eq, Show, Data, Typeable)
629+ deriving (Eq, Show)
819630
820631data Referenced a
821632 = Ref Reference
822633 | Inline a
823− deriving (Eq, Show, Functor, Data, Typeable)
824−
825−instance IsString a => IsString (Referenced a) where
826− fromString = Inline . fromString
634+ deriving (Eq, Show)
827635
828−newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable)
829−
830−data AdditionalProperties
831− = AdditionalPropertiesAllowed Bool
832− | AdditionalPropertiesSchema (Referenced Schema)
833− deriving (Eq, Show, Data, Typeable)
636+newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON)
834637
835638-- =======================================================================
836639-- Monoid instances
837640-- =======================================================================
838641
839−instance Semigroup Swagger where
840− (<>) = genericMappend
841642instance Monoid Swagger where
842643 mempty = genericMempty
843− mappend = (<>)
644+ mappend = genericMappend
844645
845−instance Semigroup Info where
846− (<>) = genericMappend
847646instance Monoid Info where
848647 mempty = genericMempty
849− mappend = (<>)
648+ mappend = genericMappend
850649
851−instance Semigroup Contact where
852− (<>) = genericMappend
853−instance Monoid Contact where
650+instance Monoid Paths where
854651 mempty = genericMempty
855− mappend = (<>)
652+ mappend = genericMappend
856653
857−instance Semigroup PathItem where
858− (<>) = genericMappend
859654instance Monoid PathItem where
860655 mempty = genericMempty
861− mappend = (<>)
656+ mappend = genericMappend
862657
863−instance Semigroup Schema where
864− (<>) = genericMappend
865658instance Monoid Schema where
866659 mempty = genericMempty
867− mappend = (<>)
868−
869−instance Semigroup (ParamSchema t) where
870− (<>) = genericMappend
871−instance Monoid (ParamSchema t) where
872− mempty = genericMempty
873− mappend = (<>)
660+ mappend = genericMappend
874661
875−instance Semigroup Param where
876− (<>) = genericMappend
877−instance Monoid Param where
662+instance Monoid SchemaCommon where
878663 mempty = genericMempty
879− mappend = (<>)
664+ mappend = genericMappend
880665
881−instance Semigroup ParamOtherSchema where
882− (<>) = genericMappend
883−instance Monoid ParamOtherSchema where
666+instance Monoid Parameter where
884667 mempty = genericMempty
885− mappend = (<>)
668+ mappend = genericMappend
886669
887−instance Semigroup Header where
888− (<>) = genericMappend
889−instance Monoid Header where
670+instance Monoid ParameterOtherSchema where
890671 mempty = genericMempty
891− mappend = (<>)
672+ mappend = genericMappend
892673
893−instance Semigroup Responses where
894− (<>) = genericMappend
895674instance Monoid Responses where
896675 mempty = genericMempty
897− mappend = (<>)
676+ mappend = genericMappend
898677
899−instance Semigroup Response where
900− (<>) = genericMappend
901678instance Monoid Response where
902679 mempty = genericMempty
903− mappend = (<>)
680+ mappend = genericMappend
904681
905−instance Semigroup ExternalDocs where
906− (<>) = genericMappend
907682instance Monoid ExternalDocs where
908683 mempty = genericMempty
909− mappend = (<>)
684+ mappend = genericMappend
910685
911−instance Semigroup Operation where
912− (<>) = genericMappend
913686instance Monoid Operation where
914687 mempty = genericMempty
915− mappend = (<>)
916−
917−instance Semigroup Example where
918− (<>) = genericMappend
919−instance Monoid Example where
920− mempty = genericMempty
921− mappend = (<>)
922−
923−instance Semigroup SecurityScheme where
924− (<>) = mergeSecurityScheme
925−
926−instance Semigroup SecurityDefinitions where
927− (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =
928− SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2
929−
930−instance Monoid SecurityDefinitions where
931− mempty = SecurityDefinitions $ InsOrdHashMap.empty
932− mappend = (<>)
688+ mappend = genericMappend
933689
934690-- =======================================================================
935691-- SwaggerMonoid helper instances
936692-- =======================================================================
937693
938694instance SwaggerMonoid Info
695+instance SwaggerMonoid Paths
939696instance SwaggerMonoid PathItem
940697instance SwaggerMonoid Schema
941−instance SwaggerMonoid (ParamSchema t)
942−instance SwaggerMonoid Param
943−instance SwaggerMonoid ParamOtherSchema
698+instance SwaggerMonoid SchemaCommon
699+instance SwaggerMonoid Parameter
700+instance SwaggerMonoid ParameterOtherSchema
944701instance SwaggerMonoid Responses
945702instance SwaggerMonoid Response
946703instance SwaggerMonoid ExternalDocs
947704instance SwaggerMonoid Operation
948−instance SwaggerMonoid SecurityDefinitions
949−instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
950705
951706instance SwaggerMonoid MimeList
952707deriving instance SwaggerMonoid URL
953708
954−instance SwaggerMonoid (SwaggerType t) where
955− swaggerMempty = SwaggerString
709+instance SwaggerMonoid SchemaType where
710+ swaggerMempty = SchemaNull
956711 swaggerMappend _ y = y
957712
958−instance SwaggerMonoid ParamLocation where
959− swaggerMempty = ParamQuery
713+instance SwaggerMonoid ParameterType where
714+ swaggerMempty = ParamString
960715 swaggerMappend _ y = y
961716
962−instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
963− swaggerMempty = InsOrdHashMap.empty
964− swaggerMappend = InsOrdHashMap.unionWith mappend
965−
966−instance Monoid a => SwaggerMonoid (Referenced a) where
967− swaggerMempty = Inline mempty
968− swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
717+instance SwaggerMonoid ParameterLocation where
718+ swaggerMempty = ParameterQuery
969719 swaggerMappend _ y = y
970720
971−instance SwaggerMonoid ParamAnySchema where
972− swaggerMempty = ParamOther swaggerMempty
973− swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y)
974− swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y)
975− swaggerMappend _ y = y
976−
977−-- =======================================================================
978−-- Simple Generic-based ToJSON instances
979−-- =======================================================================
980−
981−instance ToJSON ParamLocation where
982− toJSON = genericToJSON (jsonPrefix "Param")
721+instance SwaggerMonoid (HashMap Text Schema) where
722+ swaggerMempty = HashMap.empty
723+ swaggerMappend = HashMap.unionWith mappend
983724
984−instance ToJSON Info where
985− toJSON = genericToJSON (jsonPrefix "Info")
725+instance SwaggerMonoid (HashMap Text (Referenced Schema)) where
726+ swaggerMempty = HashMap.empty
727+ swaggerMappend = HashMap.unionWith swaggerMappend
986728
987−instance ToJSON Contact where
988− toJSON = genericToJSON (jsonPrefix "Contact")
729+instance Monoid a => SwaggerMonoid (Referenced a) where
730+ swaggerMempty = Inline mempty
731+ swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
732+ swaggerMappend _ y = y
989733
990−instance ToJSON License where
991− toJSON = genericToJSON (jsonPrefix "License")
734+instance SwaggerMonoid (HashMap Text Parameter) where
735+ swaggerMempty = HashMap.empty
736+ swaggerMappend = HashMap.unionWith mappend
992737
993−instance ToJSON ApiKeyLocation where
994− toJSON = genericToJSON (jsonPrefix "ApiKey")
738+instance SwaggerMonoid (HashMap Text Response) where
739+ swaggerMempty = HashMap.empty
740+ swaggerMappend = flip HashMap.union
995741
996−instance ToJSON ApiKeyParams where
997− toJSON = genericToJSON (jsonPrefix "apiKey")
742+instance SwaggerMonoid (HashMap Text SecurityScheme) where
743+ swaggerMempty = HashMap.empty
744+ swaggerMappend = flip HashMap.union
998745
999−instance ToJSON Scheme where
1000− toJSON = genericToJSON (jsonPrefix "")
746+instance SwaggerMonoid (HashMap FilePath PathItem) where
747+ swaggerMempty = HashMap.empty
748+ swaggerMappend = HashMap.unionWith mappend
1001749
1002−instance ToJSON Tag where
1003− toJSON = genericToJSON (jsonPrefix "Tag")
750+instance SwaggerMonoid (HashMap HeaderName Header) where
751+ swaggerMempty = HashMap.empty
752+ swaggerMappend = flip HashMap.union
1004753
1005−instance ToJSON ExternalDocs where
1006− toJSON = genericToJSON (jsonPrefix "ExternalDocs")
754+instance SwaggerMonoid (HashMap HttpStatusCode (Referenced Response)) where
755+ swaggerMempty = HashMap.empty
756+ swaggerMappend = flip HashMap.union
1007757
1008−instance ToJSON Xml where
1009− toJSON = genericToJSON (jsonPrefix "Xml")
758+instance SwaggerMonoid ParameterSchema where
759+ swaggerMempty = ParameterOther swaggerMempty
760+ swaggerMappend (ParameterBody x) (ParameterBody y) = ParameterBody (swaggerMappend x y)
761+ swaggerMappend (ParameterOther x) (ParameterOther y) = ParameterOther (swaggerMappend x y)
762+ swaggerMappend _ y = y
1010763
1011764-- =======================================================================
1012−-- Simple Generic-based FromJSON instances
765+-- TH derived ToJSON and FromJSON instances
1013766-- =======================================================================
1014767
1015−instance FromJSON ParamLocation where
1016− parseJSON = genericParseJSON (jsonPrefix "Param")
1017−
1018−instance FromJSON Info where
1019− parseJSON = genericParseJSON (jsonPrefix "Info")
1020−
1021−instance FromJSON Contact where
1022− parseJSON = genericParseJSON (jsonPrefix "Contact")
1023−
1024−instance FromJSON License where
1025− parseJSON = genericParseJSON (jsonPrefix "License")
1026−
1027−instance FromJSON ApiKeyLocation where
1028− parseJSON = genericParseJSON (jsonPrefix "ApiKey")
1029−
1030−instance FromJSON ApiKeyParams where
1031− parseJSON = genericParseJSON (jsonPrefix "apiKey")
1032−
1033−instance FromJSON Scheme where
1034− parseJSON = genericParseJSON (jsonPrefix "")
1035−
1036−instance FromJSON Tag where
1037− parseJSON = genericParseJSON (jsonPrefix "Tag")
1038−
1039−instance FromJSON ExternalDocs where
1040− parseJSON = genericParseJSON (jsonPrefix "ExternalDocs")
768+deriveJSON (jsonPrefix "Parameter") ''ParameterLocation
769+deriveJSON (jsonPrefix "Param") ''ParameterType
770+deriveJSON' ''Info
771+deriveJSON' ''Contact
772+deriveJSON' ''License
773+deriveJSON (jsonPrefix "Schema") ''SchemaType
774+deriveJSON (jsonPrefix "Items") ''ItemsType
775+deriveJSON (jsonPrefix "ItemsCollection") ''ItemsCollectionFormat
776+deriveJSON (jsonPrefix "Collection") ''CollectionFormat
777+deriveJSON (jsonPrefix "ApiKey") ''ApiKeyLocation
778+deriveJSON (jsonPrefix "apiKey") ''ApiKeyParams
779+deriveJSON' ''SchemaCommon
780+deriveJSONDefault ''Scheme
781+deriveJSON' ''Tag
782+deriveJSON' ''ExternalDocs
783+
784+deriveToJSON' ''Operation
785+deriveToJSON' ''Response
786+deriveToJSON' ''PathItem
787+deriveToJSON' ''Xml
1041788
1042789-- =======================================================================
1043790-- Manual ToJSON instances
@@ -1059,8 +806,7 @@ instance ToJSON OAuth2Flow where
1059806 , "tokenUrl" .= tokenUrl ]
1060807
1061808instance ToJSON OAuth2Params where
1062− toJSON = sopSwaggerGenericToJSON
1063− DEFINE_TOENCODING
809+ toJSON = genericToJSONWithSub "flow" (jsonPrefix "oauth2")
1064810
1065811instance ToJSON SecuritySchemeType where
1066812 toJSON SecuritySchemeBasic
@@ -1073,38 +819,22 @@ instance ToJSON SecuritySchemeType where
1073819 <+> object [ "type" .= ("oauth2" :: Text) ]
1074820
1075821instance ToJSON Swagger where
1076− toJSON = sopSwaggerGenericToJSON
1077− DEFINE_TOENCODING
822+ toJSON = addVersion . genericToJSON (jsonPrefix "")
823+ where
824+ addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
825+ addVersion _ = error "impossible"
1078826
1079827instance ToJSON SecurityScheme where
1080− toJSON = sopSwaggerGenericToJSON
1081− DEFINE_TOENCODING
828+ toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
1082829
1083830instance ToJSON Schema where
1084− toJSON = sopSwaggerGenericToJSON
1085− DEFINE_TOENCODING
831+ toJSON = genericToJSONWithSub "schemaCommon" (jsonPrefix "schema")
1086832
1087833instance ToJSON Header where
1088− toJSON = sopSwaggerGenericToJSON
1089− DEFINE_TOENCODING
1090−
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
1098− toJSON (SwaggerItemsPrimitive fmt schema) = object
1099− [ "collectionFormat" .= fmt
1100− , "items" .= schema ]
1101− 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 ]
834+ toJSON = genericToJSONWithSub "common" (jsonPrefix "header")
835+
836+instance ToJSON Items where
837+ toJSON = genericToJSONWithSub "common" (jsonPrefix "items")
1108838
1109839instance ToJSON Host where
1110840 toJSON (Host host mport) = toJSON $
@@ -1112,79 +842,38 @@ instance ToJSON Host where
1112842 Nothing -> host
1113843 Just port -> host ++ ":" ++ show port
1114844
845+instance ToJSON Paths where
846+ toJSON (Paths m) = toJSON m
847+
1115848instance ToJSON MimeList where
1116849 toJSON (MimeList xs) = toJSON (map show xs)
1117850
1118−instance ToJSON Param where
1119− toJSON = sopSwaggerGenericToJSON
1120− DEFINE_TOENCODING
851+instance ToJSON Parameter where
852+ toJSON = genericToJSONWithSub "schema" (jsonPrefix "parameter")
1121853
1122−instance ToJSON ParamAnySchema where
1123− toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
1124− toJSON (ParamOther s) = toJSON s
854+instance ToJSON ParameterSchema where
855+ toJSON (ParameterBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
856+ toJSON (ParameterOther s) = toJSON s
1125857
1126−instance ToJSON ParamOtherSchema where
1127− toJSON = sopSwaggerGenericToJSON
1128− DEFINE_TOENCODING
1129−
1130−instance ToJSON Responses where
1131− toJSON = sopSwaggerGenericToJSON
1132− DEFINE_TOENCODING
858+instance ToJSON ParameterOtherSchema where
859+ toJSON = genericToJSONWithSub "common" (jsonPrefix "parameterOtherSchema")
1133860
1134−instance ToJSON Response where
1135− toJSON = sopSwaggerGenericToJSON
1136− DEFINE_TOENCODING
861+instance ToJSON SchemaItems where
862+ toJSON (SchemaItemsObject x) = toJSON x
863+ toJSON (SchemaItemsArray xs) = toJSON xs
1137864
1138−instance ToJSON Operation where
1139− toJSON = sopSwaggerGenericToJSON
1140− DEFINE_TOENCODING
1141−
1142−instance ToJSON PathItem where
1143− toJSON = sopSwaggerGenericToJSON
1144− DEFINE_TOENCODING
865+instance ToJSON Responses where
866+ toJSON (Responses def rs) = toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
1145867
1146868instance ToJSON Example where
1147869 toJSON = toJSON . Map.mapKeys show . getExample
1148870
1149−instance ToJSON SecurityDefinitions where
1150− toJSON (SecurityDefinitions sd) = toJSON sd
1151−
1152871instance ToJSON Reference where
1153872 toJSON (Reference ref) = object [ "$ref" .= ref ]
1154873
1155−referencedToJSON :: ToJSON a => Text -> Referenced a -> Value
1156−referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ]
1157−referencedToJSON _ (Inline x) = toJSON x
1158−
1159−instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/definitions/"
1160−instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/parameters/"
1161−instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/responses/"
1162−
1163−instance ToJSON (SwaggerType t) where
1164− toJSON SwaggerArray = "array"
1165− toJSON SwaggerString = "string"
1166− toJSON SwaggerInteger = "integer"
1167− toJSON SwaggerNumber = "number"
1168− toJSON SwaggerBoolean = "boolean"
1169− toJSON SwaggerFile = "file"
1170− toJSON SwaggerNull = "null"
1171− toJSON SwaggerObject = "object"
1172−
1173−instance ToJSON (CollectionFormat t) where
1174− toJSON CollectionCSV = "csv"
1175− toJSON CollectionSSV = "ssv"
1176− toJSON CollectionTSV = "tsv"
1177− toJSON CollectionPipes = "pipes"
1178− toJSON CollectionMulti = "multi"
1179−
1180−instance ToJSON (ParamSchema k) where
1181− -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`?
1182− toJSON = sopSwaggerGenericToJSONWithOpts $
1183− mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1184−
1185−instance ToJSON AdditionalProperties where
1186− toJSON (AdditionalPropertiesAllowed b) = toJSON b
1187− toJSON (AdditionalPropertiesSchema s) = toJSON s
874+instance ToJSON a => ToJSON (Referenced a) where
875+ toJSON (Ref ref) = toJSON ref
876+ toJSON (Inline x) = toJSON x
1188877
1189878-- =======================================================================
1190879-- Manual FromJSON instances
@@ -1204,224 +893,117 @@ instance FromJSON OAuth2Flow where
1204893 parseJSON _ = empty
1205894
1206895instance FromJSON OAuth2Params where
1207− parseJSON = sopSwaggerGenericParseJSON
896+ parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
1208897
1209898instance FromJSON SecuritySchemeType where
1210− parseJSON js@(Object o) = do
899+ parseJSON json@(Object o) = do
1211900 (t :: Text) <- o .: "type"
1212901 case t of
1213902 "basic" -> pure SecuritySchemeBasic
1214− "apiKey" -> SecuritySchemeApiKey <$> parseJSON js
1215− "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js
903+ "apiKey" -> SecuritySchemeApiKey <$> parseJSON json
904+ "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON json
1216905 _ -> empty
1217906 parseJSON _ = empty
1218907
1219908instance FromJSON Swagger where
1220− parseJSON = sopSwaggerGenericParseJSON
909+ parseJSON json@(Object o) = do
910+ (version :: Text) <- o .: "swagger"
911+ when (version /= "2.0") empty
912+ (genericParseJSON (jsonPrefix "")
913+ `withDefaults` [ "consumes" .= (mempty :: MimeList)
914+ , "produces" .= (mempty :: MimeList)
915+ , "security" .= ([] :: [SecurityRequirement])
916+ , "tags" .= ([] :: [Tag])
917+ , "definitions" .= (mempty :: HashMap Text Schema)
918+ , "parameters" .= (mempty :: HashMap Text Parameter)
919+ , "responses" .= (mempty :: HashMap Text Response)
920+ , "securityDefinitions" .= (mempty :: HashMap Text SecurityScheme)
921+ ] ) json
922+ parseJSON _ = empty
1221923
1222924instance FromJSON SecurityScheme where
1223− parseJSON = sopSwaggerGenericParseJSON
925+ parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
1224926
1225927instance FromJSON Schema where
1226− parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
1227− where nullaryCleanup :: Schema -> Schema
1228− nullaryCleanup s@Schema{_schemaParamSchema=ps} =
1229− if _paramSchemaItems ps == Just (SwaggerItemsArray [])
1230− then s { _schemaExample = Nothing
1231− , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } }
1232− else s
928+ parseJSON = genericParseJSONWithSub "schemaCommon" (jsonPrefix "schema")
929+ `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
930+ , "required" .= ([] :: [ParamName]) ]
1233931
1234932instance FromJSON Header where
1235− parseJSON = sopSwaggerGenericParseJSON
1236−
1237−instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where
1238− parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1239− <$> o .:? "collectionFormat"
1240− <*> (o .: "items" >>= parseJSON)
1241−
1242−instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where
1243− parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1244− <$> o .:? "collectionFormat"
1245− <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))
1246−
1247−-- |
1248−--
1249−-- >>> decode "{}" :: Maybe (SwaggerItems 'SwaggerKindSchema)
1250−-- Just (SwaggerItemsArray [])
1251−--
1252−-- >>> eitherDecode "{\"$ref\":\"#/definitions/example\"}" :: Either String (SwaggerItems 'SwaggerKindSchema)
1253−-- Right (SwaggerItemsObject (Ref (Reference {getReference = "example"})))
1254−--
1255−-- >>> eitherDecode "[{\"$ref\":\"#/definitions/example\"}]" :: Either String (SwaggerItems 'SwaggerKindSchema)
1256−-- Right (SwaggerItemsArray [Ref (Reference {getReference = "example"})])
1257−--
1258−instance FromJSON (SwaggerItems 'SwaggerKindSchema) where
1259− parseJSON js@(Object obj)
1260− | null obj = pure $ SwaggerItemsArray [] -- Nullary schema.
1261− | otherwise = SwaggerItemsObject <$> parseJSON js
1262− parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1263− parseJSON _ = empty
933+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "header")
934+
935+instance FromJSON Items where
936+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "items")
1264937
1265938instance FromJSON Host where
1266− parseJSON (String s) = case map Text.unpack $ Text.split (== ':') s of
1267− [host] -> return $ Host host Nothing
1268− [host, port] -> case readMaybe port of
1269− Nothing -> fail $ "Invalid port `" ++ port ++ "'"
1270− Just p -> return $ Host host (Just (fromInteger p))
1271− _ -> fail $ "Invalid host `" ++ Text.unpack s ++ "'"
939+ parseJSON (String s) =
940+ case fromInteger <$> readMaybe portStr of
941+ Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'"
942+ mport -> pure $ Host host mport
943+ where
944+ (hostText, portText) = Text.breakOn ":" s
945+ [host, portStr] = map Text.unpack [hostText, portText]
1272946 parseJSON _ = empty
1273947
948+instance FromJSON Paths where
949+ parseJSON json = Paths <$> parseJSON json
950+
1274951instance FromJSON MimeList where
1275− parseJSON js = (MimeList . map fromString) <$> parseJSON js
952+ parseJSON json = (MimeList . map fromString) <$> parseJSON json
1276953
1277−instance FromJSON Param where
1278− parseJSON = sopSwaggerGenericParseJSON
954+instance FromJSON Parameter where
955+ parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "parameter")
1279956
1280−instance FromJSON ParamAnySchema where
1281− parseJSON js@(Object o) = do
957+instance FromJSON ParameterSchema where
958+ parseJSON json@(Object o) = do
1282959 (i :: Text) <- o .: "in"
1283960 case i of
1284961 "body" -> do
1285962 schema <- o .: "schema"
1286− ParamBody <$> parseJSON schema
1287− _ -> ParamOther <$> parseJSON js
963+ ParameterBody <$> parseJSON schema
964+ _ -> ParameterOther <$> parseJSON json
1288965 parseJSON _ = empty
1289966
1290−instance FromJSON ParamOtherSchema where
1291− parseJSON = sopSwaggerGenericParseJSON
967+instance FromJSON ParameterOtherSchema where
968+ parseJSON = genericParseJSONWithSub "common" (jsonPrefix "parameterOtherSchema")
969+
970+instance FromJSON SchemaItems where
971+ parseJSON json@(Object _) = SchemaItemsObject <$> parseJSON json
972+ parseJSON json@(Array _) = SchemaItemsArray <$> parseJSON json
973+ parseJSON _ = empty
1292974
1293975instance FromJSON Responses where
1294976 parseJSON (Object o) = Responses
1295977 <$> o .:? "default"
1296− <*> (parseJSON (Object (HashMap.delete "default" o)))
978+ <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
1297979 parseJSON _ = empty
1298980
1299981instance FromJSON Example where
1300− parseJSON js = do
1301− m <- parseJSON js
982+ parseJSON json = do
983+ m <- parseJSON json
1302984 pure $ Example (Map.mapKeys fromString m)
1303985
1304986instance FromJSON Response where
1305− parseJSON = sopSwaggerGenericParseJSON
987+ parseJSON = genericParseJSON (jsonPrefix "response")
988+ `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
1306989
1307990instance FromJSON Operation where
1308− parseJSON = sopSwaggerGenericParseJSON
991+ parseJSON = genericParseJSON (jsonPrefix "operation")
992+ `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) ]
1309993
1310994instance FromJSON PathItem where
1311− parseJSON = sopSwaggerGenericParseJSON
1312−
1313−instance FromJSON SecurityDefinitions where
1314− parseJSON js = SecurityDefinitions <$> parseJSON js
995+ parseJSON = genericParseJSON (jsonPrefix "pathItem")
996+ `withDefaults` [ "parameters" .= ([] :: [Parameter]) ]
1315997
1316998instance FromJSON Reference where
1317999 parseJSON (Object o) = Reference <$> o .: "$ref"
13181000 parseJSON _ = empty
13191001
1320−referencedParseJSON :: FromJSON a => Text -> Value -> JSON.Parser (Referenced a)
1321−referencedParseJSON prefix js@(Object o) = do
1322− ms <- o .:? "$ref"
1323− case ms of
1324− Nothing -> Inline <$> parseJSON js
1325− Just s -> Ref <$> parseRef s
1326− where
1327− parseRef s = do
1328− case Text.stripPrefix prefix s of
1329− Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s
1330− Just suffix -> pure (Reference suffix)
1331−referencedParseJSON _ _ = fail "referenceParseJSON: not an object"
1332−
1333−instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/definitions/"
1334−instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/parameters/"
1335−instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/responses/"
1002+instance FromJSON a => FromJSON (Referenced a) where
1003+ parseJSON json
1004+ = Ref <$> parseJSON json
1005+ <|> Inline <$> parseJSON json
13361006
13371007instance FromJSON Xml where
13381008 parseJSON = genericParseJSON (jsonPrefix "xml")
13391009
1340−instance FromJSON (SwaggerType 'SwaggerKindSchema) where
1341− parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1342−
1343−instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where
1344− parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1345−
1346−instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where
1347− parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1348−
1349−instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where
1350− parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1351−
1352−-- NOTE: There aren't collections of 'Schema'
1353−--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where
1354−-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1355−
1356−instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where
1357− parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1358−
1359−instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where
1360− parseJSON = sopSwaggerGenericParseJSON
1361−instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where
1362− parseJSON = sopSwaggerGenericParseJSON
1363−instance FromJSON (ParamSchema 'SwaggerKindSchema) where
1364− parseJSON = sopSwaggerGenericParseJSON
1365−
1366−instance FromJSON AdditionalProperties where
1367− parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b
1368− parseJSON js = AdditionalPropertiesSchema <$> parseJSON js
1369−
1370−-------------------------------------------------------------------------------
1371−-- TH splices
1372−-------------------------------------------------------------------------------
1373−
1374−deriveGeneric ''Header
1375−deriveGeneric ''OAuth2Params
1376−deriveGeneric ''Operation
1377−deriveGeneric ''Param
1378−deriveGeneric ''ParamOtherSchema
1379−deriveGeneric ''PathItem
1380−deriveGeneric ''Response
1381−deriveGeneric ''Responses
1382−deriveGeneric ''SecurityScheme
1383−deriveGeneric ''Schema
1384−deriveGeneric ''ParamSchema
1385−deriveGeneric ''Swagger
1386−
1387−instance HasSwaggerAesonOptions Header where
1388− swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema"
1389−instance HasSwaggerAesonOptions OAuth2Params where
1390− swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow"
1391−instance HasSwaggerAesonOptions Operation where
1392− swaggerAesonOptions _ = mkSwaggerAesonOptions "operation"
1393−instance HasSwaggerAesonOptions Param where
1394− swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject ?~ "schema"
1395−instance HasSwaggerAesonOptions ParamOtherSchema where
1396− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramOtherSchema" & saoSubObject ?~ "paramSchema"
1397−instance HasSwaggerAesonOptions PathItem where
1398− swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem"
1399−instance HasSwaggerAesonOptions Response where
1400− swaggerAesonOptions _ = mkSwaggerAesonOptions "response"
1401−instance HasSwaggerAesonOptions Responses where
1402− swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses"
1403−instance HasSwaggerAesonOptions SecurityScheme where
1404− swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type"
1405−instance HasSwaggerAesonOptions Schema where
1406− swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema"
1407−instance HasSwaggerAesonOptions Swagger where
1408− swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")]
1409−
1410−instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where
1411− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1412−instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where
1413− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1414−-- NOTE: Schema doesn't have 'items' sub object!
1415−instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where
1416− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema"
1417−
1418−instance AesonDefaultValue (ParamSchema s)
1419−instance AesonDefaultValue OAuth2Flow
1420−instance AesonDefaultValue Responses
1421−instance AesonDefaultValue ParamAnySchema
1422−instance AesonDefaultValue SecuritySchemeType
1423−instance AesonDefaultValue (SwaggerType a)
1424−instance AesonDefaultValue MimeList where defaultValue = Just mempty
1425−instance AesonDefaultValue Info
1426−instance AesonDefaultValue ParamLocation
1427−instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty
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.hsdeleted−337
@@ -1,337 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DefaultSignatures #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE PackageImports #-}
9−{-# LANGUAGE PolyKinds #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# 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"
22−module Data.Swagger.Internal.ParamSchema where
23−
24−import Control.Lens
25−import Data.Aeson (ToJSON (..))
26−import Data.Proxy
27−import GHC.Generics
28−
29−import Data.Int
30−import "unordered-containers" Data.HashSet (HashSet)
31−import Data.Monoid
32−import Data.Set (Set)
33−import Data.Scientific
34−import Data.Fixed (HasResolution(..), Fixed, Pico)
35−import qualified Data.Text as T
36−import qualified Data.Text.Lazy as TL
37−import Data.Time
38−import qualified Data.Vector as V
39−import qualified Data.Vector.Primitive as VP
40−import qualified Data.Vector.Storable as VS
41−import qualified Data.Vector.Unboxed as VU
42−import Data.Version (Version)
43−import Numeric.Natural.Compat (Natural)
44−import Data.Word
45−import Data.UUID.Types (UUID)
46−import Web.Cookie (SetCookie)
47−
48−import Data.Swagger.Internal
49−import Data.Swagger.Lens
50−import Data.Swagger.SchemaOptions
51−
52−#if __GLASGOW_HASKELL__ < 800
53−#else
54−import qualified Data.ByteString as BS
55−import qualified Data.ByteString.Lazy as BSL
56−import GHC.TypeLits (TypeError, ErrorMessage(..))
57−#endif
58−
59−-- | Default schema for binary data (any sequence of octets).
60−binaryParamSchema :: ParamSchema t
61−binaryParamSchema = mempty
62− & type_ ?~ SwaggerString
63− & format ?~ "binary"
64−
65−-- | Default schema for binary data (base64 encoded).
66−byteParamSchema :: ParamSchema t
67−byteParamSchema = mempty
68− & type_ ?~ SwaggerString
69− & format ?~ "byte"
70−
71−-- | Default schema for password string.
72−-- @"password"@ format is used to hint UIs the input needs to be obscured.
73−passwordParamSchema :: ParamSchema t
74−passwordParamSchema = mempty
75− & type_ ?~ SwaggerString
76− & format ?~ "password"
77−
78−-- | Convert a type into a plain @'ParamSchema'@.
79−--
80−-- An example type and instance:
81−--
82−-- @
83−-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
84−--
85−-- import Control.Lens
86−--
87−-- data Direction = Up | Down
88−--
89−-- instance ToParamSchema Direction where
90−-- toParamSchema _ = mempty
91−-- & type_ ?~ SwaggerString
92−-- & enum_ ?~ [ \"Up\", \"Down\" ]
93−-- @
94−--
95−-- Instead of manually writing your @'ToParamSchema'@ instance you can
96−-- use a default generic implementation of @'toParamSchema'@.
97−--
98−-- To do that, simply add @deriving 'Generic'@ clause to your datatype
99−-- and declare a @'ToParamSchema'@ instance for your datatype without
100−-- giving definition for @'toParamSchema'@.
101−--
102−-- For instance, the previous example can be simplified into this:
103−--
104−-- @
105−-- {-\# LANGUAGE DeriveGeneric \#-}
106−--
107−-- import GHC.Generics (Generic)
108−--
109−-- data Direction = Up | Down deriving Generic
110−--
111−-- instance ToParamSchema Direction
112−-- @
113−class ToParamSchema a where
114− -- | Convert a type into a plain parameter schema.
115− --
116− -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
117− -- "{\"type\":\"integer\"}"
118− toParamSchema :: Proxy a -> ParamSchema t
119− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t
120− toParamSchema = genericToParamSchema defaultSchemaOptions
121−
122−instance OVERLAPPING_ ToParamSchema String where
123− toParamSchema _ = mempty & type_ ?~ SwaggerString
124−
125−instance ToParamSchema Bool where
126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
127−
128−instance ToParamSchema Integer where
129− toParamSchema _ = mempty & type_ ?~ SwaggerInteger
130−
131−instance ToParamSchema Natural where
132− toParamSchema _ = mempty
133− & type_ ?~ SwaggerInteger
134− & minimum_ ?~ 0
135− & exclusiveMinimum ?~ False
136−
137−instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
138−instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
139−instance ToParamSchema Int16 where toParamSchema = toParamSchemaBoundedIntegral
140−
141−instance ToParamSchema Int32 where
142− toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int32"
143−
144−instance ToParamSchema Int64 where
145− toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64"
146−
147−instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral
148−instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral
149−instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral
150−instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral
151−instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
152−
153−-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
154−--
155−-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
156−-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
157−toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
158−toParamSchemaBoundedIntegral _ = mempty
159− & type_ ?~ SwaggerInteger
160− & minimum_ ?~ fromInteger (toInteger (minBound :: a))
161− & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
162−
163−instance ToParamSchema Char where
164− toParamSchema _ = mempty
165− & type_ ?~ SwaggerString
166− & maxLength ?~ 1
167− & minLength ?~ 1
168−
169−instance ToParamSchema Scientific where
170− toParamSchema _ = mempty & type_ ?~ SwaggerNumber
171−
172−instance HasResolution a => ToParamSchema (Fixed a) where
173− toParamSchema _ = mempty
174− & type_ ?~ SwaggerNumber
175− & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
176−
177−instance ToParamSchema Double where
178− toParamSchema _ = mempty
179− & type_ ?~ SwaggerNumber
180− & format ?~ "double"
181−
182−instance ToParamSchema Float where
183− toParamSchema _ = mempty
184− & type_ ?~ SwaggerNumber
185− & format ?~ "float"
186−
187−timeParamSchema :: String -> ParamSchema t
188−timeParamSchema fmt = mempty
189− & type_ ?~ SwaggerString
190− & format ?~ T.pack fmt
191−
192−-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
193−instance ToParamSchema Day where
194− toParamSchema _ = timeParamSchema "date"
195−
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−-- |
203−-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
204−-- Just "yyyy-mm-ddThh:MM:ss"
205−instance ToParamSchema LocalTime where
206− toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss"
207−
208−-- |
209−-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format
210−-- Just "yyyy-mm-ddThh:MM:ss+hhMM"
211−instance ToParamSchema ZonedTime where
212− toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"
213−
214−-- |
215−-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format
216−-- Just "yyyy-mm-ddThh:MM:ssZ"
217−instance ToParamSchema UTCTime where
218− toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
219−
220−instance ToParamSchema NominalDiffTime where
221− toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
222−
223−instance ToParamSchema T.Text where
224− toParamSchema _ = toParamSchema (Proxy :: Proxy String)
225−
226−instance ToParamSchema TL.Text where
227− toParamSchema _ = toParamSchema (Proxy :: Proxy String)
228−
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−
251−instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
252−instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
253−instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
254−instance ToParamSchema a => ToParamSchema (Product a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
255−instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
256−instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
257−instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
258−
259−instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
260−
261−instance ToParamSchema a => ToParamSchema [a] where
262− toParamSchema _ = mempty
263− & type_ ?~ SwaggerArray
264− & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
265−
266−instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
267−instance ToParamSchema a => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
268−instance ToParamSchema a => ToParamSchema (VS.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
269−instance ToParamSchema a => ToParamSchema (VU.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
270−
271−instance ToParamSchema a => ToParamSchema (Set a) where
272− toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
273− & uniqueItems ?~ True
274−
275−instance ToParamSchema a => ToParamSchema (HashSet a) where
276− toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a))
277−
278−-- |
279−-- >>> encode $ toParamSchema (Proxy :: Proxy ())
280−-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
281−instance ToParamSchema () where
282− toParamSchema _ = mempty
283− & type_ ?~ SwaggerString
284− & enum_ ?~ ["_"]
285−
286−instance ToParamSchema UUID where
287− toParamSchema _ = mempty
288− & type_ ?~ SwaggerString
289− & format ?~ "uuid"
290−
291−-- | A configurable generic @'ParamSchema'@ creator.
292−--
293−-- >>> :set -XDeriveGeneric
294−-- >>> data Color = Red | Blue deriving Generic
295−-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
296−-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
297−genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t
298−genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
299−
300−class GToParamSchema (f :: * -> *) where
301− gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
302−
303−instance GToParamSchema f => GToParamSchema (D1 d f) where
304− gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
305−
306−instance Constructor c => GToParamSchema (C1 c U1) where
307− gtoParamSchema = genumParamSchema
308−
309−instance GToParamSchema f => GToParamSchema (C1 c (S1 s f)) where
310− gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
311−
312−instance ToParamSchema c => GToParamSchema (K1 i c) where
313− gtoParamSchema _ _ _ = toParamSchema (Proxy :: Proxy c)
314−
315−instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) where
316− gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
317−
318−class GEnumParamSchema (f :: * -> *) where
319− genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
320−
321−instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
322− genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
323−
324−instance Constructor c => GEnumParamSchema (C1 c U1) where
325− genumParamSchema opts _ s = s
326− & type_ ?~ SwaggerString
327− & enum_ %~ addEnumValue tag
328− where
329− tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
330−
331− addEnumValue x Nothing = Just [x]
332− addEnumValue x (Just xs) = Just (x:xs)
333−
334−data Proxy3 a b c = Proxy3
335−
336−-- $setup
337−-- >>> import Data.Aeson (encode)
src/Data/Swagger/Internal/Schema.hsdeleted−882
@@ -1,882 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DefaultSignatures #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE DataKinds #-}
8−{-# LANGUAGE OverloadedLists #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PackageImports #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TupleSections #-}
14−{-# LANGUAGE TypeFamilies #-}
15−{-# LANGUAGE TypeOperators #-}
16−{-# 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"
25−module Data.Swagger.Internal.Schema where
26−
27−import Prelude ()
28−import Prelude.Compat
29−
30−import Control.Lens
31−import Data.Data.Lens (template)
32−
33−import Control.Monad
34−import Control.Monad.Writer
35−import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
36−import Data.Char
37−import Data.Data (Data)
38−import Data.Foldable (traverse_)
39−import Data.HashMap.Strict (HashMap)
40−import qualified Data.HashMap.Strict as HashMap
41−import "unordered-containers" Data.HashSet (HashSet)
42−import qualified "unordered-containers" Data.HashSet as HashSet
43−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
44−import Data.Int
45−import Data.IntSet (IntSet)
46−import Data.IntMap (IntMap)
47−import Data.List.NonEmpty.Compat (NonEmpty)
48−import Data.Map (Map)
49−import Data.Proxy
50−import Data.Scientific (Scientific)
51−import Data.Fixed (Fixed, HasResolution, Pico)
52−import Data.Set (Set)
53−import qualified Data.Text as T
54−import qualified Data.Text.Lazy as TL
55−import Data.Time
56−import qualified Data.Vector as V
57−import qualified Data.Vector.Primitive as VP
58−import qualified Data.Vector.Storable as VS
59−import qualified Data.Vector.Unboxed as VU
60−import Data.Version (Version)
61−import Numeric.Natural.Compat (Natural)
62−import Data.Word
63−import GHC.Generics
64−import qualified Data.UUID.Types as UUID
65−
66−import Data.Swagger.Declare
67−import Data.Swagger.Internal
68−import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
69−import Data.Swagger.Lens hiding (name, schema)
70−import qualified Data.Swagger.Lens as Swagger
71−import Data.Swagger.SchemaOptions
72−import Data.Swagger.Internal.TypeShape
73−
74−#if __GLASGOW_HASKELL__ < 800
75−#else
76−import qualified Data.ByteString as BS
77−import qualified Data.ByteString.Lazy as BSL
78−import GHC.TypeLits (TypeError, ErrorMessage(..))
79−#endif
80−
81−unnamed :: Schema -> NamedSchema
82−unnamed schema = NamedSchema Nothing schema
83−
84−named :: T.Text -> Schema -> NamedSchema
85−named name schema = NamedSchema (Just name) schema
86−
87−plain :: Schema -> Declare (Definitions Schema) NamedSchema
88−plain = pure . unnamed
89−
90−unname :: NamedSchema -> NamedSchema
91−unname (NamedSchema _ schema) = unnamed schema
92−
93−rename :: Maybe T.Text -> NamedSchema -> NamedSchema
94−rename name (NamedSchema _ schema) = NamedSchema name schema
95−
96−-- | Convert a type into @'Schema'@.
97−--
98−-- An example type and instance:
99−--
100−-- @
101−-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
102−-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
103−--
104−-- import Control.Lens
105−-- import Data.Proxy
106−-- import Data.Swagger
107−--
108−-- data Coord = Coord { x :: Double, y :: Double }
109−--
110−-- instance ToSchema Coord where
111−-- declareNamedSchema _ = do
112−-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
113−-- return $ NamedSchema (Just \"Coord\") $ mempty
114−-- & type_ ?~ SwaggerObject
115−-- & properties .~
116−-- [ (\"x\", doubleSchema)
117−-- , (\"y\", doubleSchema)
118−-- ]
119−-- & required .~ [ \"x\", \"y\" ]
120−-- @
121−--
122−-- Instead of manually writing your @'ToSchema'@ instance you can
123−-- use a default generic implementation of @'declareNamedSchema'@.
124−--
125−-- To do that, simply add @deriving 'Generic'@ clause to your datatype
126−-- and declare a @'ToSchema'@ instance for your datatype without
127−-- giving definition for @'declareNamedSchema'@.
128−--
129−-- For instance, the previous example can be simplified into this:
130−--
131−-- @
132−-- {-\# LANGUAGE DeriveGeneric \#-}
133−--
134−-- import GHC.Generics (Generic)
135−--
136−-- data Coord = Coord { x :: Double, y :: Double } deriving Generic
137−--
138−-- instance ToSchema Coord
139−-- @
140−class ToSchema a where
141− -- | Convert a type into an optionally named schema
142− -- together with all used definitions.
143− -- Note that the schema itself is included in definitions
144− -- only if it is recursive (and thus needs its definition in scope).
145− declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
146− default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
147− Proxy a -> Declare (Definitions Schema) NamedSchema
148− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
149−
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.
155−declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
156−declareSchema = fmap _namedSchemaSchema . declareNamedSchema
157−
158−-- | Convert a type into an optionally named schema.
159−--
160−-- >>> toNamedSchema (Proxy :: Proxy String) ^. name
161−-- Nothing
162−-- >>> encode (toNamedSchema (Proxy :: Proxy String) ^. schema)
163−-- "{\"type\":\"string\"}"
164−--
165−-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
166−-- Just "Day"
167−-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
168−-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
169−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
170−toNamedSchema = undeclare . declareNamedSchema
171−
172−-- | Get type's schema name according to its @'ToSchema'@ instance.
173−--
174−-- >>> schemaName (Proxy :: Proxy Int)
175−-- Nothing
176−--
177−-- >>> schemaName (Proxy :: Proxy UTCTime)
178−-- Just "UTCTime"
179−schemaName :: ToSchema a => Proxy a -> Maybe T.Text
180−schemaName = _namedSchemaName . toNamedSchema
181−
182−-- | Convert a type into a schema.
183−--
184−-- >>> encode $ toSchema (Proxy :: Proxy Int8)
185−-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
186−--
187−-- >>> encode $ toSchema (Proxy :: Proxy [Day])
188−-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
189−toSchema :: ToSchema a => Proxy a -> Schema
190−toSchema = _namedSchemaSchema . toNamedSchema
191−
192−-- | Convert a type into a referenced schema if possible.
193−-- Only named schemas can be referenced, nameless schemas are inlined.
194−--
195−-- >>> encode $ toSchemaRef (Proxy :: Proxy Integer)
196−-- "{\"type\":\"integer\"}"
197−--
198−-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
199−-- "{\"$ref\":\"#/definitions/Day\"}"
200−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
201−toSchemaRef = undeclare . declareSchemaRef
202−
203−-- | Convert a type into a referenced schema if possible
204−-- and declare all used schema definitions.
205−-- Only named schemas can be referenced, nameless schemas are inlined.
206−--
207−-- Schema definitions are typically declared for every referenced schema.
208−-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
209−-- will be declared (regardless of whether it is recusive or not).
210−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
211−declareSchemaRef proxy = do
212− case toNamedSchema proxy of
213− NamedSchema (Just name) schema -> do
214− -- This check is very important as it allows generically
215− -- derive used definitions for recursive schemas.
216− -- Lazy Declare monad allows toNamedSchema to ignore
217− -- any declarations (which would otherwise loop) and
218− -- retrieve the schema and its name to check if we
219− -- have already declared it.
220− -- If we have, we don't need to declare anything for
221− -- this schema this time and thus simply return the reference.
222− known <- looks (InsOrdHashMap.member name)
223− when (not known) $ do
224− declare [(name, schema)]
225− void $ declareNamedSchema proxy
226− return $ Ref (Reference name)
227− _ -> Inline <$> declareSchema proxy
228−
229−-- | Inline any referenced schema if its name satisfies given predicate.
230−--
231−-- /NOTE:/ if a referenced schema is not found in definitions the predicate is ignored
232−-- and schema stays referenced.
233−--
234−-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas
235−-- when inlining recursive schemas.
236−inlineSchemasWhen :: Data s => (T.Text -> Bool) -> (Definitions Schema) -> s -> s
237−inlineSchemasWhen p defs = template %~ deref
238− where
239− deref r@(Ref (Reference name))
240− | p name =
241− case InsOrdHashMap.lookup name defs of
242− Just schema -> Inline (inlineSchemasWhen p defs schema)
243− Nothing -> r
244− | otherwise = r
245− deref (Inline schema) = Inline (inlineSchemasWhen p defs schema)
246−
247−-- | Inline any referenced schema if its name is in the given list.
248−--
249−-- /NOTE:/ if a referenced schema is not found in definitions
250−-- it stays referenced even if it appears in the list of names.
251−--
252−-- __WARNING:__ @'inlineSchemas'@ will produce infinite schemas
253−-- when inlining recursive schemas.
254−inlineSchemas :: Data s => [T.Text] -> (Definitions Schema) -> s -> s
255−inlineSchemas names = inlineSchemasWhen (`elem` names)
256−
257−-- | Inline all schema references for which the definition
258−-- can be found in @'Definitions'@.
259−--
260−-- __WARNING:__ @'inlineAllSchemas'@ will produce infinite schemas
261−-- when inlining recursive schemas.
262−inlineAllSchemas :: Data s => (Definitions Schema) -> s -> s
263−inlineAllSchemas = inlineSchemasWhen (const True)
264−
265−-- | Convert a type into a schema without references.
266−--
267−-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
268−-- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
269−--
270−-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
271−-- when inlining recursive schemas.
272−toInlinedSchema :: ToSchema a => Proxy a -> Schema
273−toInlinedSchema proxy = inlineAllSchemas defs schema
274− where
275− (defs, schema) = runDeclare (declareSchema proxy) mempty
276−
277−-- | Inline all /non-recursive/ schemas for which the definition
278−-- can be found in @'Definitions'@.
279−inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
280−inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
281− where
282− nonRecursive name =
283− case InsOrdHashMap.lookup name defs of
284− Just schema -> name `notElem` execDeclare (usedNames schema) mempty
285− Nothing -> False
286−
287− usedNames schema = traverse_ schemaRefNames (schema ^.. template)
288−
289− schemaRefNames :: Referenced Schema -> Declare [T.Text] ()
290− schemaRefNames ref = case ref of
291− Ref (Reference name) -> do
292− seen <- looks (name `elem`)
293− when (not seen) $ do
294− declare [name]
295− traverse_ usedNames (InsOrdHashMap.lookup name defs)
296− Inline subschema -> usedNames subschema
297−
298−-- | Default schema for binary data (any sequence of octets).
299−binarySchema :: Schema
300−binarySchema = mempty
301− & type_ ?~ SwaggerString
302− & format ?~ "binary"
303−
304−-- | Default schema for binary data (base64 encoded).
305−byteSchema :: Schema
306−byteSchema = mempty
307− & type_ ?~ SwaggerString
308− & format ?~ "byte"
309−
310−-- | Default schema for password string.
311−-- @"password"@ format is used to hint UIs the input needs to be obscured.
312−passwordSchema :: Schema
313−passwordSchema = mempty
314− & type_ ?~ SwaggerString
315− & format ?~ "password"
316−
317−-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
318−-- Produced schema can be used for further refinement.
319−--
320−-- >>> encode $ sketchSchema "hello"
321−-- "{\"example\":\"hello\",\"type\":\"string\"}"
322−--
323−-- >>> encode $ sketchSchema (1, 2, 3)
324−-- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}"
325−--
326−-- >>> encode $ sketchSchema ("Jack", 25)
327−-- "{\"example\":[\"Jack\",25],\"items\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"type\":\"array\"}"
328−--
329−-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
330−-- >>> instance ToJSON Person
331−-- >>> encode $ sketchSchema (Person "Jack" 25)
332−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"
333−sketchSchema :: ToJSON a => a -> Schema
334−sketchSchema = sketch . toJSON
335− where
336− sketch Null = go Null
337− sketch js@(Bool _) = go js
338− sketch js = go js & example ?~ js
339−
340− go Null = mempty & type_ ?~ SwaggerNull
341− go (Bool _) = mempty & type_ ?~ SwaggerBoolean
342− go (String _) = mempty & type_ ?~ SwaggerString
343− go (Number _) = mempty & type_ ?~ SwaggerNumber
344− go (Array xs) = mempty
345− & type_ ?~ SwaggerArray
346− & items ?~ case ischema of
347− Just s -> SwaggerItemsObject (Inline s)
348− _ -> SwaggerItemsArray (map Inline ys)
349− where
350− ys = map go (V.toList xs)
351− allSame = and ((zipWith (==)) ys (tail ys))
352−
353− ischema = case ys of
354− (z:_) | allSame -> Just z
355− _ -> Nothing
356− go (Object o) = mempty
357− & type_ ?~ SwaggerObject
358− & required .~ HashMap.keys o
359− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
360−
361−-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
362−-- Produced schema uses as much constraints as possible.
363−--
364−-- >>> encode $ sketchStrictSchema "hello"
365−-- "{\"maxLength\":5,\"pattern\":\"hello\",\"minLength\":5,\"type\":\"string\",\"enum\":[\"hello\"]}"
366−--
367−-- >>> encode $ sketchStrictSchema (1, 2, 3)
368−-- "{\"minItems\":3,\"uniqueItems\":true,\"items\":[{\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\",\"enum\":[1]},{\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\",\"enum\":[2]},{\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\",\"enum\":[3]}],\"maxItems\":3,\"type\":\"array\",\"enum\":[[1,2,3]]}"
369−--
370−-- >>> encode $ sketchStrictSchema ("Jack", 25)
371−-- "{\"minItems\":2,\"uniqueItems\":true,\"items\":[{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]},{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]}],\"maxItems\":2,\"type\":\"array\",\"enum\":[[\"Jack\",25]]}"
372−--
373−-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
374−-- >>> instance ToJSON Person
375−-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
376−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}},\"maxProperties\":2,\"minProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}]}"
377−sketchStrictSchema :: ToJSON a => a -> Schema
378−sketchStrictSchema = go . toJSON
379− where
380− go Null = mempty & type_ ?~ SwaggerNull
381− go js@(Bool _) = mempty
382− & type_ ?~ SwaggerBoolean
383− & enum_ ?~ [js]
384− go js@(String s) = mempty
385− & type_ ?~ SwaggerString
386− & maxLength ?~ fromIntegral (T.length s)
387− & minLength ?~ fromIntegral (T.length s)
388− & pattern ?~ s
389− & enum_ ?~ [js]
390− go js@(Number n) = mempty
391− & type_ ?~ SwaggerNumber
392− & maximum_ ?~ n
393− & minimum_ ?~ n
394− & multipleOf ?~ n
395− & enum_ ?~ [js]
396− go js@(Array xs) = mempty
397− & type_ ?~ SwaggerArray
398− & maxItems ?~ fromIntegral sz
399− & minItems ?~ fromIntegral sz
400− & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
401− & uniqueItems ?~ allUnique
402− & enum_ ?~ [js]
403− where
404− sz = length xs
405− allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
406− go js@(Object o) = mempty
407− & type_ ?~ SwaggerObject
408− & required .~ names
409− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
410− & maxProperties ?~ fromIntegral (length names)
411− & minProperties ?~ fromIntegral (length names)
412− & enum_ ?~ [js]
413− where
414− names = HashMap.keys o
415−
416−class GToSchema (f :: * -> *) where
417− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
418−
419−instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
420− declareNamedSchema _ = do
421− ref <- declareSchemaRef (Proxy :: Proxy a)
422− return $ unnamed $ mempty
423− & type_ ?~ SwaggerArray
424− & items ?~ SwaggerItemsObject ref
425−
426−instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
427−instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
428−instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
430−instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
431−instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
432−instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
433−instance ToSchema Int32 where declareNamedSchema = plain . paramSchemaToSchema
434−instance ToSchema Int64 where declareNamedSchema = plain . paramSchemaToSchema
435−instance ToSchema Word where declareNamedSchema = plain . paramSchemaToSchema
436−instance ToSchema Word8 where declareNamedSchema = plain . paramSchemaToSchema
437−instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
438−instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
439−instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
440−
441−instance ToSchema Char where
442− declareNamedSchema proxy = plain (paramSchemaToSchema proxy)
443− & mapped.Swagger.schema.example ?~ toJSON '?'
444−
445−instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
446−instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
447−instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
448−
449−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
450−
451−instance ToSchema a => ToSchema (Maybe a) where
452− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
453−
454−instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
455−
456−instance ToSchema () where
457− declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
458−
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−
464−instance (ToSchema a, ToSchema b) => ToSchema (a, b)
465−instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
466−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
467−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
468−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
469−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
470−
471−timeSchema :: T.Text -> Schema
472−timeSchema fmt = mempty
473− & type_ ?~ SwaggerString
474− & format ?~ fmt
475−
476−-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
477−instance ToSchema Day where
478− declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"
479− & example ?~ toJSON (fromGregorian 2016 7 22)
480−
481−-- |
482−-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
483−-- Just "yyyy-mm-ddThh:MM:ss"
484−instance ToSchema LocalTime where
485− declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
486− & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
487−
488−-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
489−instance ToSchema ZonedTime where
490− declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
491− & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
492−
493−instance ToSchema NominalDiffTime where
494− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
495−
496−-- |
497−-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
498−-- Just "yyyy-mm-ddThh:MM:ssZ"
499−instance ToSchema UTCTime where
500− declareNamedSchema _ = pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"
501− & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)
502−
503−instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
504−instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
505−
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−
520−instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
521−
522−-- | NOTE: This schema does not account for the uniqueness of keys.
523−instance ToSchema a => ToSchema (IntMap a) where
524− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
525−
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−
543−instance ToSchema a => ToSchema (Map String a) where
544− declareNamedSchema _ = do
545− schema <- declareSchemaRef (Proxy :: Proxy a)
546− return $ unnamed $ mempty
547− & type_ ?~ SwaggerObject
548− & additionalProperties ?~ schema
549−
550−instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
551−instance ToSchema a => ToSchema (Map TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
552−
553−instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
554−instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
555−instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
556−
557−#endif
558−
559−instance OVERLAPPING_ ToSchema Object where
560− declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
561− & type_ ?~ SwaggerObject
562− & description ?~ "Arbitrary JSON object."
563− & additionalProperties ?~ AdditionalPropertiesAllowed True
564−
565−instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
566−instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
567−instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
568−instance ToSchema a => ToSchema (VP.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
569−
570−instance ToSchema a => ToSchema (Set a) where
571− declareNamedSchema _ = do
572− schema <- declareSchema (Proxy :: Proxy [a])
573− return $ unnamed $ schema
574− & uniqueItems ?~ True
575−
576−instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
577−
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−
585−instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
586−instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
587−
588−instance ToSchema a => ToSchema (Sum a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
589−instance ToSchema a => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
590−instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
591−instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
592−instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
593−
594−instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
595−
596−-- | Default schema for @'Bounded'@, @'Integral'@ types.
597−--
598−-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
599−-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
600−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
601−toSchemaBoundedIntegral _ = mempty
602− & type_ ?~ SwaggerInteger
603− & minimum_ ?~ fromInteger (toInteger (minBound :: a))
604− & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
605−
606−-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
607−genericToNamedSchemaBoundedIntegral :: forall a d f.
608− ( Bounded a, Integral a
609− , Generic a, Rep a ~ D1 d f, Datatype d)
610− => SchemaOptions -> Proxy a -> NamedSchema
611−genericToNamedSchemaBoundedIntegral opts proxy
612− = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
613−
614−-- | Declare a named schema for a @newtype@ wrapper.
615−genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
616− (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
617− => SchemaOptions -- ^ How to derive the name.
618− -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.
619− -> Proxy a
620− -> Declare (Definitions Schema) NamedSchema
621−genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
622−
623−-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
624−-- This makes a much more useful schema when there aren't many options for key values.
625−--
626−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
627−-- >>> instance ToJSON ButtonState
628−-- >>> instance ToSchema ButtonState
629−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
630−-- >>> type ImageUrl = T.Text
631−-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
632−-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
633−--
634−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
635−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
636−declareSchemaBoundedEnumKeyMapping :: forall map key value.
637− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
638− => Proxy (map key value) -> Declare (Definitions Schema) Schema
639−declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
640− ToJSONKeyText keyToText _ -> objectSchema keyToText
641− ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
642− where
643− objectSchema keyToText = do
644− valueRef <- declareSchemaRef (Proxy :: Proxy value)
645− let allKeys = [minBound..maxBound :: key]
646− mkPair k = (keyToText k, valueRef)
647− return $ mempty
648− & type_ ?~ SwaggerObject
649− & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
650−
651−-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
652−-- This makes a much more useful schema when there aren't many options for key values.
653−--
654−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
655−-- >>> instance ToJSON ButtonState
656−-- >>> instance ToSchema ButtonState
657−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
658−-- >>> type ImageUrl = T.Text
659−-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
660−-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
661−--
662−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
663−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
664−toSchemaBoundedEnumKeyMapping :: forall map key value.
665− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
666− => Proxy (map key value) -> Schema
667−toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
668−
669−-- | A configurable generic @'Schema'@ creator.
670−genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
671− SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
672−genericDeclareSchema = genericDeclareSchemaUnrestricted
673−
674−-- | A configurable generic @'NamedSchema'@ creator.
675−-- This function applied to @'defaultSchemaOptions'@
676−-- is used as the default for @'declareNamedSchema'@
677−-- 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
695−genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
696−
697−-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
698−genericNameSchema :: forall a d f.
699− (Generic a, Rep a ~ D1 d f, Datatype d)
700− => SchemaOptions -> Proxy a -> Schema -> NamedSchema
701−genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
702−
703−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
704−gdatatypeSchemaName opts _ = case orig of
705− (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
706− _ -> Nothing
707− where
708− orig = datatypeName (Proxy3 :: Proxy3 d f a)
709− name = datatypeNameModifier opts orig
710−
711−-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
712−paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
713− SchemaOptions -> Proxy a -> NamedSchema
714−paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
715−
716−-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
717−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
718−paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
719−
720−nullarySchema :: Schema
721−nullarySchema = mempty
722− & type_ ?~ SwaggerArray
723− & items ?~ SwaggerItemsArray []
724−
725−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
726−gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
727−
728−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
729−gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
730−
731−instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
732− gdeclareNamedSchema opts _ schema = do
733− NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema
734− gdeclareNamedSchema opts (Proxy :: Proxy g) gschema
735−
736−instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
737− gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
738− where
739− name = gdatatypeSchemaName opts (Proxy :: Proxy d)
740−
741−instance OVERLAPPABLE_ GToSchema f => GToSchema (C1 c f) where
742− gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)
743−
744−instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
745− gdeclareNamedSchema = gdeclareNamedSumSchema
746−
747−-- | Single field constructor.
748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
749− gdeclareNamedSchema opts _ s
750− | unwrapUnaryRecords opts = fieldSchema
751− | otherwise =
752− case schema ^. items of
753− Just (SwaggerItemsArray [_]) -> fieldSchema
754− _ -> do
755− declare defs
756− return (unnamed schema)
757− where
758− (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
759− recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
760− fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
761−
762−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
763−gdeclareSchemaRef opts proxy = do
764− case gtoNamedSchema opts proxy of
765− NamedSchema (Just name) schema -> do
766− -- This check is very important as it allows generically
767− -- derive used definitions for recursive schemas.
768− -- Lazy Declare monad allows toNamedSchema to ignore
769− -- any declarations (which would otherwise loop) and
770− -- retrieve the schema and its name to check if we
771− -- have already declared it.
772− -- If we have, we don't need to declare anything for
773− -- this schema this time and thus simply return the reference.
774− known <- looks (InsOrdHashMap.member name)
775− when (not known) $ do
776− declare [(name, schema)]
777− void $ gdeclareNamedSchema opts proxy mempty
778− return $ Ref (Reference name)
779− _ -> Inline <$> gdeclareSchema opts proxy
780−
781−appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
782−appendItem x Nothing = Just (SwaggerItemsArray [x])
783−appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
784−appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
785−
786−withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
787− SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
788−withFieldSchema opts _ isRequiredField schema = do
789− ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
790− return $
791− if T.null fname
792− then schema
793− & type_ ?~ SwaggerArray
794− & items %~ appendItem ref
795− & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796− & minItems %~ Just . maybe 1 (+1) -- increment minItems
797− else schema
798− & type_ ?~ SwaggerObject
799− & properties . at fname ?~ ref
800− & if isRequiredField
801− then required %~ (++ [fname])
802− else id
803− where
804− fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
805−
806−-- | Optional record fields.
807−instance OVERLAPPING_ (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
808− gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
809−
810−-- | Record fields.
811−instance OVERLAPPABLE_ (Selector s, GToSchema f) => GToSchema (S1 s f) where
812− gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
813−
814−instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
815− gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
816−
817−instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
818− gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
819−
820−instance ( GSumToSchema f
821− , GSumToSchema g
822− ) => GToSchema (f :+: g)
823− where
824− gdeclareNamedSchema = gdeclareNamedSumSchema
825−
826−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
827−gdeclareNamedSumSchema opts proxy s
828− | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
829− | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
830− where
831− declareSumSchema = gsumToSchema opts proxy s
832− (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
833−
834− toStringTag schema = mempty
835− & type_ ?~ SwaggerString
836− & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
837−
838−type AllNullary = All
839−
840−class GSumToSchema (f :: * -> *) where
841− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
842−
843−instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
844− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
845−
846−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
847− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
848−gsumConToSchemaWith ref opts _ schema = schema
849− & type_ ?~ SwaggerObject
850− & properties . at tag ?~ ref
851− & maxProperties ?~ 1
852− & minProperties ?~ 1
853− where
854− tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
855−
856−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
857− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
858−gsumConToSchema opts proxy schema = do
859− ref <- gdeclareSchemaRef opts proxy
860− return $ gsumConToSchemaWith ref opts proxy schema
861−
862−instance OVERLAPPABLE_ (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
863− gsumToSchema opts proxy schema = do
864− tell (All False)
865− lift $ gsumConToSchema opts proxy schema
866−
867−instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
868− gsumToSchema opts proxy schema = do
869− tell (All False)
870− lift $ gsumConToSchema opts proxy schema
871−
872−instance Constructor c => GSumToSchema (C1 c U1) where
873− gsumToSchema opts proxy = pure . gsumConToSchemaWith (Inline nullarySchema) opts proxy
874−
875−data Proxy2 a b = Proxy2
876−
877−data Proxy3 a b c = Proxy3
878−
879−-- $setup
880−-- >>> import Data.Swagger
881−-- >>> import Data.Aeson (encode)
882−-- >>> import Data.Aeson.Types (toJSONKeyText)
src/Data/Swagger/Internal/Schema/Validation.hsdeleted−511
@@ -1,511 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE PackageImports #-}
11−{-# LANGUAGE RankNTypes #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−-- |
16−-- Module: Data.Swagger.Internal.Schema.Validation
17−-- Copyright: (c) 2015 GetShopTV
18−-- License: BSD3
19−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
20−-- Stability: experimental
21−--
22−-- Validate JSON values with Swagger Schema.
23−module Data.Swagger.Internal.Schema.Validation where
24−
25−import Prelude ()
26−import Prelude.Compat
27−
28−import Control.Applicative
29−import Control.Lens
30−import Control.Monad (when)
31−
32−import Data.Aeson hiding (Result)
33−import Data.Aeson.Encode.Pretty (encodePretty)
34−import Data.Foldable (for_, sequenceA_,
35− traverse_)
36−import Data.HashMap.Strict (HashMap)
37−import qualified Data.HashMap.Strict as HashMap
38−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
39−import qualified "unordered-containers" Data.HashSet as HashSet
40−import Data.Proxy
41−import Data.Scientific (Scientific, isInteger)
42−import Data.Text (Text)
43−import qualified Data.Text as Text
44−import qualified Data.Text.Lazy as TL
45−import qualified Data.Text.Lazy.Encoding as TL
46−import Data.Vector (Vector)
47−import qualified Data.Vector as Vector
48−
49−import Data.Swagger.Declare
50−import Data.Swagger.Internal
51−import Data.Swagger.Internal.Schema
52−import Data.Swagger.Lens
53−
54−-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
55−-- This can be used with QuickCheck to ensure those instances are coherent:
56−--
57−-- prop> validateToJSON (x :: Int) == []
58−--
59−-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
60−-- See @'validateToJSONWithPatternChecker'@.
61−--
62−-- See 'renderValidationErrors' on how the output is structured.
63−validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String
64−validatePrettyToJSON = renderValidationErrors validateToJSON
65−
66−-- | Variant of 'validatePrettyToJSON' with typed output.
67−validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
68−validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
69−
70−-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
71−-- This can be used with QuickCheck to ensure those instances are coherent.
72−--
73−-- For validation without patterns see @'validateToJSON'@. See also:
74−-- 'renderValidationErrors'.
75−validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]
76−validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON
77− where
78− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
79−
80−-- | Pretty print validation errors
81−-- together with actual JSON and Swagger Schema
82−-- (using 'encodePretty').
83−--
84−-- >>> import Data.Aeson as Aeson
85−-- >>> import Data.Foldable (traverse_)
86−-- >>> import GHC.Generics
87−-- >>> data Phone = Phone { value :: String } deriving (Generic)
88−-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)
89−-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]
90−-- >>> instance ToSchema Phone
91−-- >>> instance ToSchema Person
92−-- >>> let person = Person { name = "John", phone = Phone "123456" }
93−-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person
94−-- Validation against the schema fails:
95−-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
96−-- <BLANKLINE>
97−-- JSON value:
98−-- {
99−-- "name": "John"
100−-- }
101−-- <BLANKLINE>
102−-- Swagger Schema:
103−-- {
104−-- "required": [
105−-- "name",
106−-- "phone"
107−-- ],
108−-- "type": "object",
109−-- "properties": {
110−-- "phone": {
111−-- "$ref": "#/definitions/Phone"
112−-- },
113−-- "name": {
114−-- "type": "string"
115−-- }
116−-- }
117−-- }
118−-- <BLANKLINE>
119−-- Swagger Description Context:
120−-- {
121−-- "Phone": {
122−-- "required": [
123−-- "value"
124−-- ],
125−-- "type": "object",
126−-- "properties": {
127−-- "value": {
128−-- "type": "string"
129−-- }
130−-- }
131−-- }
132−-- }
133−-- <BLANKLINE>
134−renderValidationErrors
135− :: forall a. (ToJSON a, ToSchema a)
136− => (a -> [ValidationError]) -> a -> Maybe String
137−renderValidationErrors f x =
138− case f x of
139− [] -> Nothing
140− errors -> Just $ unlines
141− [ "Validation against the schema fails:"
142− , unlines (map (" * " ++) errors)
143− , "JSON value:"
144− , ppJSONString (toJSON x)
145− , ""
146− , "Swagger Schema:"
147− , ppJSONString (toJSON schema_)
148− , ""
149− , "Swagger Description Context:"
150− , ppJSONString (toJSON refs_)
151− ]
152− where
153− ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty
154− (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
155−
156−-- | Validate JSON @'Value'@ against Swagger @'Schema'@.
157−--
158−-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []
159−--
160−-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.
161−-- See @'validateJSONWithPatternChecker'@.
162−validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]
163−validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True)
164−
165−-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker.
166−--
167−-- For validation without patterns see @'validateJSON'@.
168−validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]
169−validateJSONWithPatternChecker checker defs sch js =
170− case runValidation (validateWithSchema js) cfg sch of
171− Failed xs -> xs
172− Passed _ -> mempty
173− where
174− cfg = defaultConfig
175− { configPatternChecker = checker
176− , configDefinitions = defs }
177−
178−-- | Validation error message.
179−type ValidationError = String
180−
181−-- | Validation result type.
182−data Result a
183− = Failed [ValidationError] -- ^ Validation failed with a list of error messages.
184− | Passed a -- ^ Validation passed.
185− deriving (Eq, Show, Functor)
186−
187−instance Applicative Result where
188− pure = Passed
189− Passed f <*> Passed x = Passed (f x)
190− Failed xs <*> Failed ys = Failed (xs <> ys)
191− Failed xs <*> _ = Failed xs
192− _ <*> Failed ys = Failed ys
193−
194−instance Alternative Result where
195− empty = Failed mempty
196− Passed x <|> _ = Passed x
197− _ <|> y = y
198−
199−instance Monad Result where
200− return = pure
201− Passed x >>= f = f x
202− Failed xs >>= _ = Failed xs
203−
204−-- | Validation configuration.
205−data Config = Config
206− { -- | Pattern checker for @'_paramSchemaPattern'@ validation.
207− configPatternChecker :: Pattern -> Text -> Bool
208− -- | Schema definitions in scope to resolve references.
209− , configDefinitions :: Definitions Schema
210− }
211−
212−-- | Default @'Config'@:
213−--
214−-- @
215−-- defaultConfig = 'Config'
216−-- { 'configPatternChecker' = \\_pattern _str -> True
217−-- , 'configDefinitions' = mempty
218−-- }
219−-- @
220−defaultConfig :: Config
221−defaultConfig = Config
222− { configPatternChecker = \_pattern _str -> True
223− , configDefinitions = mempty
224− }
225−
226−-- | Value validation.
227−newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }
228− deriving (Functor)
229−
230−instance Applicative (Validation schema) where
231− pure x = Validation (\_ _ -> pure x)
232− Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)
233−
234−instance Alternative (Validation schema) where
235− empty = Validation (\_ _ -> empty)
236− Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)
237−
238−instance Profunctor Validation where
239− dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))
240−
241−instance Choice Validation where
242− left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))
243− right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))
244−
245−instance Monad (Validation s) where
246− return = pure
247− Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)
248− (>>) = (*>)
249−
250−withConfig :: (Config -> Validation s a) -> Validation s a
251−withConfig f = Validation (\c -> runValidation (f c) c)
252−
253−withSchema :: (s -> Validation s a) -> Validation s a
254−withSchema f = Validation (\c s -> runValidation (f s) c s)
255−
256−-- | Issue an error message.
257−invalid :: String -> Validation schema a
258−invalid msg = Validation (\_ _ -> Failed [msg])
259−
260−-- | Validation passed.
261−valid :: Validation schema ()
262−valid = pure ()
263−
264−-- | Validate schema's property given a lens into that property
265−-- and property checker.
266−checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
267−checkMissing missing l g = withSchema $ \sch ->
268− case sch ^. l of
269− Nothing -> missing
270− Just x -> g x
271−
272−-- | Validate schema's property given a lens into that property
273−-- and property checker.
274−-- If property is missing in schema, consider it valid.
275−check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
276−check = checkMissing valid
277−
278−-- | Validate same value with different schema.
279−sub :: t -> Validation t a -> Validation s a
280−sub = lmap . const
281−
282−-- | Validate same value with a part of the original schema.
283−sub_ :: Getting a s a -> Validation a r -> Validation s r
284−sub_ = lmap . view
285−
286−-- | Validate value against a schema given schema reference and validation function.
287−withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
288−withRef (Reference ref) f = withConfig $ \cfg ->
289− case InsOrdHashMap.lookup ref (configDefinitions cfg) of
290− Nothing -> invalid $ "unknown schema " ++ show ref
291− Just s -> f s
292−
293−validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
294−validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)
295−validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
296−
297−-- | Validate JSON @'Value'@ with Swagger @'Schema'@.
298−validateWithSchema :: Value -> Validation Schema ()
299−validateWithSchema value = do
300− validateSchemaType value
301− sub_ paramSchema $ validateEnum value
302−
303−-- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@.
304−validateWithParamSchema :: Value -> Validation (ParamSchema t) ()
305−validateWithParamSchema value = do
306− validateParamSchemaType value
307− validateEnum value
308−
309−validateInteger :: Scientific -> Validation (ParamSchema t) ()
310−validateInteger n = do
311− when (not (isInteger n)) $
312− invalid ("not an integer")
313− validateNumber n
314−
315−validateNumber :: Scientific -> Validation (ParamSchema t) ()
316−validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do
317− let exMax = Just True == sch ^. exclusiveMaximum
318− exMin = Just True == sch ^. exclusiveMinimum
319−
320− check maximum_ $ \m ->
321− when (if exMax then (n >= m) else (n > m)) $
322− invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")
323−
324− check minimum_ $ \m ->
325− when (if exMin then (n <= m) else (n < m)) $
326− invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")")
327−
328− check multipleOf $ \k ->
329− when (not (isInteger (n / k))) $
330− invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)
331−
332−validateString :: Text -> Validation (ParamSchema t) ()
333−validateString s = do
334− check maxLength $ \n ->
335− when (len > fromInteger n) $
336− invalid ("string is too long (length should be <=" ++ show n ++ ")")
337−
338− check minLength $ \n ->
339− when (len < fromInteger n) $
340− invalid ("string is too short (length should be >=" ++ show n ++ ")")
341−
342− check pattern $ \regex -> do
343− withConfig $ \cfg -> do
344− when (not (configPatternChecker cfg regex s)) $
345− invalid ("string does not match pattern " ++ show regex)
346− where
347− len = Text.length s
348−
349−validateArray :: Vector Value -> Validation (ParamSchema t) ()
350−validateArray xs = do
351− check maxItems $ \n ->
352− when (len > fromInteger n) $
353− invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")")
354−
355− check minItems $ \n ->
356− when (len < fromInteger n) $
357− invalid ("array is too short (size should be >=" ++ show n ++ ")")
358−
359− check items $ \case
360− SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs
361− SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs
362− SwaggerItemsArray itemSchemas -> do
363− when (len /= length itemSchemas) $
364− invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")
365− sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
366−
367− check uniqueItems $ \unique ->
368− when (unique && not allUnique) $
369− invalid ("array is expected to contain unique items, but it does not")
370− where
371− len = Vector.length xs
372− allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
373−
374−validateObject :: HashMap Text Value -> Validation Schema ()
375−validateObject o = withSchema $ \sch ->
376− case sch ^. discriminator of
377− Just pname -> case fromJSON <$> HashMap.lookup pname o of
378− Just (Success ref) -> validateWithSchemaRef ref (Object o)
379− Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)
380− Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing")
381− Nothing -> do
382− check maxProperties $ \n ->
383− when (size > n) $
384− invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")")
385−
386− check minProperties $ \n ->
387− when (size < n) $
388− invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")")
389−
390− validateRequired
391− validateProps
392− where
393− size = fromIntegral (HashMap.size o)
394−
395− validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)
396− validateReq n =
397− when (not (HashMap.member n o)) $
398− invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))
399−
400− validateProps = withSchema $ \sch -> do
401− for_ (HashMap.toList o) $ \(k, v) ->
402− case v of
403− Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
404− _ ->
405− case InsOrdHashMap.lookup k (sch ^. properties) of
406− Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
407− Just s -> validateWithSchemaRef s v
408−
409− validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid
410− validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"
411− validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v
412−
413− unknownProperty :: Text -> Validation s a
414− unknownProperty pname = invalid $
415− "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"
416−
417−validateEnum :: Value -> Validation (ParamSchema t) ()
418−validateEnum value = do
419− check enum_ $ \xs ->
420− when (value `notElem` xs) $
421− invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
422−
423−-- | Infer schema type based on used properties.
424−--
425−-- This is like 'inferParamSchemaTypes', but also works for objects:
426−--
427−-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"
428−-- Just [SwaggerObject]
429−inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema]
430−inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++
431− [ SwaggerObject | any ($ sch)
432− [ has (additionalProperties._Just)
433− , has (maxProperties._Just)
434− , has (minProperties._Just)
435− , has (properties.folded)
436− , has (required.folded) ] ]
437−
438−-- | Infer schema type based on used properties.
439−--
440−-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"
441−-- Just [SwaggerString]
442−--
443−-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"
444−-- Just [SwaggerArray]
445−--
446−-- From numeric properties 'SwaggerInteger' type is inferred.
447−-- If you want 'SwaggerNumber' instead, you must specify it explicitly.
448−--
449−-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"
450−-- Just [SwaggerInteger]
451−inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t]
452−inferParamSchemaTypes sch = concat
453− [ [ SwaggerArray | any ($ sch)
454− [ has (items._Just)
455− , has (maxItems._Just)
456− , has (minItems._Just)
457− , has (uniqueItems._Just) ] ]
458− , [ SwaggerInteger | any ($ sch)
459− [ has (exclusiveMaximum._Just)
460− , has (exclusiveMinimum._Just)
461− , has (maximum_._Just)
462− , has (minimum_._Just)
463− , has (multipleOf._Just) ] ]
464− , [ SwaggerString | any ($ sch)
465− [ has (maxLength._Just)
466− , has (minLength._Just)
467− , has (pattern._Just) ] ]
468− ]
469−
470−validateSchemaType :: Value -> Validation Schema ()
471−validateSchemaType value = withSchema $ \sch ->
472− case (sch ^. type_, value) of
473− (Just SwaggerNull, Null) -> valid
474− (Just SwaggerBoolean, Bool _) -> valid
475− (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
476− (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
477− (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)
478− (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
479− (Just SwaggerObject, Object o) -> validateObject o
480− (Nothing, Null) -> valid
481− (Nothing, Bool _) -> valid
482− -- Number by default
483− (Nothing, Number n) -> sub_ paramSchema (validateNumber n)
484− (Nothing, String s) -> sub_ paramSchema (validateString s)
485− (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)
486− (Nothing, Object o) -> validateObject o
487− bad -> invalid $ "expected JSON value of type " ++ showType bad
488−
489−validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
490−validateParamSchemaType value = withSchema $ \sch ->
491− case (sch ^. type_, value) of
492− (Just SwaggerBoolean, Bool _) -> valid
493− (Just SwaggerInteger, Number n) -> validateInteger n
494− (Just SwaggerNumber, Number n) -> validateNumber n
495− (Just SwaggerString, String s) -> validateString s
496− (Just SwaggerArray, Array xs) -> validateArray xs
497− (Nothing, Bool _) -> valid
498− -- Number by default
499− (Nothing, Number n) -> validateNumber n
500− (Nothing, String s) -> validateString s
501− (Nothing, Array xs) -> validateArray xs
502− bad -> invalid $ "expected JSON value of type " ++ showType bad
503−
504−showType :: (Maybe (SwaggerType t), Value) -> String
505−showType (Just type_, _) = show type_
506−showType (Nothing, Null) = "SwaggerNull"
507−showType (Nothing, Bool _) = "SwaggerBoolean"
508−showType (Nothing, Number _) = "SwaggerNumber"
509−showType (Nothing, String _) = "SwaggerString"
510−showType (Nothing, Array _) = "SwaggerArray"
511−showType (Nothing, Object _) = "SwaggerObject"
src/Data/Swagger/Internal/TypeShape.hsdeleted−66
@@ -1,66 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−
9−module Data.Swagger.Internal.TypeShape where
10−
11−import Data.Proxy
12−import GHC.Generics
13−import GHC.TypeLits
14−import GHC.Exts (Constraint)
15−
16−-- | Shape of a datatype.
17−data TypeShape
18− = Enumeration -- ^ A simple enumeration.
19− | SumOfProducts -- ^ A product or a sum of non-unit products.
20− | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.
21−
22−-- | A combined shape for a product type.
23−type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
24− ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products
25− ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products
26− ProdCombine a b = SumOfProducts
27−
28−-- | A combined shape for a sum type.
29−type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
30− SumCombine Enumeration Enumeration = Enumeration
31− SumCombine SumOfProducts SumOfProducts = SumOfProducts
32− SumCombine a b = Mixed
33−
34−type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where
35− TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))
36−
37−type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where
38− GenericHasSimpleShape t f Enumeration = ()
39− GenericHasSimpleShape t f SumOfProducts = ()
40−#if __GLASGOW_HASKELL__ < 800
41− GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t
42−
43−class CannotDeriveSchemaForMixedSumType t where
44−#else
45− GenericHasSimpleShape t f Mixed =
46− TypeError
47− ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t
48− :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."
49− :$$: Text "Swagger does not have a good representation for these types."
50− :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"
51− :$$: Text "that matches aeson's Generic-based toJSON,"
52− :$$: Text "but that's not supported by some Swagger tools."
53− )
54−#endif
55−
56−-- | Infer a 'TypeShape' for a generic representation of a type.
57−type family GenericShape (g :: * -> *) :: TypeShape
58−
59−type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)
60−type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)
61−type instance GenericShape (D1 d f) = GenericShape f
62−type instance GenericShape (C1 c U1) = Enumeration
63−type instance GenericShape (C1 c (S1 s f)) = SumOfProducts
64−type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
65−
66−
src/Data/Swagger/Internal/Utils.hs+42−52
@@ -1,55 +1,35 @@
11{-# LANGUAGE DefaultSignatures #-}
22{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
43{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE RankNTypes #-}
64{-# LANGUAGE TypeOperators #-}
75module Data.Swagger.Internal.Utils where
86
9−import Prelude ()
10−import Prelude.Compat
11−
12−import Control.Lens ((&), (%~))
13−import Control.Lens.TH
7+import Control.Arrow (first)
8+import Control.Applicative
149import Data.Aeson
15−import Data.Aeson.Types
10+import Data.Aeson.TH
11+import Data.Aeson.Types (Parser, Pair)
1612import Data.Char
17−import Data.Data
1813import Data.Hashable (Hashable)
1914import Data.HashMap.Strict (HashMap)
2015import qualified Data.HashMap.Strict as HashMap
21−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
22−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
23−import Data.Map (Map)
24−import Data.Set (Set)
16+import Data.Monoid
2517import Data.Text (Text)
18+import Data.Traversable
2619import GHC.Generics
27−import Language.Haskell.TH (mkName)
28−
29−swaggerFieldRules :: LensRules
30−swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
31− where
32− swaggerFieldNamer namer dname fnames fname =
33− map fixDefName (namer dname fnames fname)
34−
35− fixDefName (MethodName cname mname) = MethodName cname (fixName mname)
36− fixDefName (TopName name) = TopName (fixName name)
20+import Language.Haskell.TH
21+import Text.Read (readMaybe)
3722
38− fixName = mkName . fixName' . show
23+hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v
24+hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList
3925
40− fixName' "in" = "in_" -- keyword
41− fixName' "type" = "type_" -- keyword
42− fixName' "default" = "default_" -- keyword
43− fixName' "minimum" = "minimum_" -- Prelude conflict
44− fixName' "maximum" = "maximum_" -- Prelude conflict
45− fixName' "enum" = "enum_" -- Control.Lens conflict
46− fixName' "head" = "head_" -- Prelude conflict
47− fixName' n = n
26+hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)
27+hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList
28+ where
29+ g (x, y) = (\a -> (a, y)) <$> f x
4830
49−gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
50−gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of
51− Just x -> z x
52− Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
31+hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)
32+hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)
5333
5434jsonPrefix :: String -> Options
5535jsonPrefix prefix = defaultOptions
@@ -64,18 +44,37 @@ jsonPrefix prefix = defaultOptions
6444 lowerFirstUppers s = map toLower x ++ y
6545 where (x, y) = span isUpper s
6646
67−parseOneOf :: ToJSON a => [a] -> Value -> Parser a
68−parseOneOf xs js =
69− case lookup js ys of
70− Nothing -> fail $ "invalid json: " ++ show js ++ " (expected one of " ++ show (map fst ys) ++ ")"
71− Just x -> pure x
47+deriveToJSON' :: Name -> Q [Dec]
48+deriveToJSON' name = deriveToJSON (jsonPrefix (nameBase name)) name
49+
50+deriveJSONDefault :: Name -> Q [Dec]
51+deriveJSONDefault = deriveJSON (jsonPrefix "")
52+
53+deriveJSON' :: Name -> Q [Dec]
54+deriveJSON' name = deriveJSON (jsonPrefix (nameBase name)) name
55+
56+genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
57+genericToJSONWithSub sub opts x =
58+ case genericToJSON opts x of
59+ Object o ->
60+ let so = HashMap.lookupDefault (error "impossible") sub o
61+ in Object (HashMap.delete sub o) <+> so
62+ _ -> error "genericToJSONWithSub: subjson is not an object"
63+
64+genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
65+genericParseJSONWithSub sub opts (Object o) = genericParseJSON opts json
7266 where
73− ys = zip (map toJSON xs) xs
67+ json = Object (HashMap.insert sub (Object o) o)
68+genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"
7469
7570(<+>) :: Value -> Value -> Value
7671Object x <+> Object y = Object (x <> y)
7772_ <+> _ = error "<+>: merging non-objects"
7873
74+withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
75+withDefaults parser defs json@(Object _) = parser (json <+> object defs)
76+withDefaults _ _ _ = empty
77+
7978genericMempty :: (Generic a, GMonoid (Rep a)) => a
8079genericMempty = to gmempty
8180
@@ -111,16 +110,6 @@ class SwaggerMonoid m where
111110 swaggerMappend = mappend
112111
113112instance SwaggerMonoid [a]
114−instance Ord a => SwaggerMonoid (Set a)
115−instance Ord k => SwaggerMonoid (Map k v)
116−
117−instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
118− swaggerMempty = mempty
119− swaggerMappend = HashMap.unionWith (\_old new -> new)
120−
121−instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where
122− swaggerMempty = mempty
123− swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)
124113
125114instance SwaggerMonoid Text where
126115 swaggerMempty = mempty
@@ -131,3 +120,4 @@ instance SwaggerMonoid (Maybe a) where
131120 swaggerMempty = Nothing
132121 swaggerMappend x Nothing = x
133122 swaggerMappend _ y = y
123+
src/Data/Swagger/Lens.hs+95−174
@@ -1,186 +1,107 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleContexts #-}
31{-# LANGUAGE FlexibleInstances #-}
42{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE GADTs #-}
63{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE RankNTypes #-}
84{-# LANGUAGE TemplateHaskell #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE DataKinds #-}
11−{-# LANGUAGE UndecidableInstances #-}
12−{-# OPTIONS_GHC -fno-warn-orphans #-}
13−#include "overlapping-compat.h"
14−-- |
15−-- Module: Data.Swagger.Lens
16−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
17−-- Stability: experimental
18−--
19−-- Lenses and prisms for Swagger.
205module Data.Swagger.Lens where
216
227import Control.Lens
8+import Control.Lens.TH
239import Data.Aeson (Value)
24−import Data.Scientific (Scientific)
2510import Data.Swagger.Internal
26−import Data.Swagger.Internal.Utils
2711import Data.Text (Text)
2812
29−-- * Classy lenses
30−
31−makeFields ''Swagger
32−makeFields ''Host
33−makeFields ''Info
34−makeFields ''Contact
35−makeFields ''License
36−makeLensesWith swaggerFieldRules ''PathItem
37−makeFields ''Tag
38−makeFields ''Operation
39−makeFields ''Param
40−makeLensesWith swaggerFieldRules ''ParamOtherSchema
41−makeFields ''Header
42−makeFields ''Schema
43−makeFields ''NamedSchema
44−makeLensesWith swaggerFieldRules ''ParamSchema
45−makeFields ''Xml
46−makeLensesWith swaggerFieldRules ''Responses
47−makeFields ''Response
48−makeLensesWith swaggerFieldRules ''SecurityScheme
49−makeFields ''ApiKeyParams
50−makeFields ''OAuth2Params
51−makeFields ''ExternalDocs
52−
53−-- * Prisms
54−-- ** 'ParamAnySchema' prisms
55−makePrisms ''ParamAnySchema
56−-- ** 'SecuritySchemeType' prisms
13+-- =======================================================================
14+-- TH derived lenses
15+-- =======================================================================
16+
17+makeLenses ''Swagger
18+makeLenses ''Host
19+makeLenses ''Info
20+makeLenses ''Contact
21+makeLenses ''License
22+makeLenses ''Paths
23+makeLenses ''PathItem
24+makeLenses ''Tag
25+makeLenses ''Operation
26+makeLenses ''Parameter
27+makePrisms ''ParameterSchema
28+makeLenses ''ParameterOtherSchema
29+makeLenses ''Items
30+makeLenses ''Header
31+makeLenses ''Schema
32+makePrisms ''SchemaItems
33+makeLenses ''SchemaCommon
34+makeLenses ''Xml
35+makeLenses ''Responses
36+makeLenses ''Response
37+makeLenses ''SecurityScheme
5738makePrisms ''SecuritySchemeType
58−-- ** 'Referenced' prisms
59−makePrisms ''Referenced
60−
61−-- ** 'SwaggerItems' prisms
62−
63−_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]
64−_SwaggerItemsArray
65− = unto (\x -> SwaggerItemsArray x)
66−{- \x -> case x of
67− SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
68− SwaggerItemsObject o -> Left (SwaggerItemsObject o)
69− SwaggerItemsArray a -> Right a
70−-}
71−
72−_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)
73−_SwaggerItemsObject
74− = unto (\x -> SwaggerItemsObject x)
75−{- \x -> case x of
76− SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
77− SwaggerItemsObject o -> Right o
78− SwaggerItemsArray a -> Left (SwaggerItemsArray a)
79−-}
80−
81−_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)
83−
84−-- =============================================================
85−-- More helpful instances for easier access to schema properties
86−
87−type instance Index Responses = HttpStatusCode
88−type instance Index Operation = HttpStatusCode
89−
90−type instance IxValue Responses = Referenced Response
91−type instance IxValue Operation = Referenced Response
92−
93−instance Ixed Responses where ix n = responses . ix n
94−instance At Responses where at n = responses . at n
95−
96−instance Ixed Operation where ix n = responses . ix n
97−instance At Operation where at n = responses . at n
98−
99−type instance Index SecurityDefinitions = Text
100−type instance IxValue SecurityDefinitions = SecurityScheme
101−
102−instance Ixed SecurityDefinitions where ix n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). ix n
103−instance At SecurityDefinitions where at n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). at n
104−
105−instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema
106−
107−-- HasType instances
108−instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_
109−instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
110−instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
111−instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_
112−
113−-- HasDefault instances
114−instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
115−instance HasDefault Schema (Maybe Value) where default_ = paramSchema.default_
116−instance HasDefault ParamOtherSchema (Maybe Value) where default_ = paramSchema.default_
117−
118−-- OVERLAPPABLE instances
119−
120−instance
121−#if __GLASGOW_HASKELL__ >= 710
122− OVERLAPPABLE_
123−#endif
124− HasParamSchema s (ParamSchema t)
125− => HasFormat s (Maybe Format) where
126− format = paramSchema.format
127−
128−instance
129−#if __GLASGOW_HASKELL__ >= 710
130− OVERLAPPABLE_
131−#endif
132− HasParamSchema s (ParamSchema t)
133− => HasItems s (Maybe (SwaggerItems t)) where
134− items = paramSchema.items
135−
136−instance
137−#if __GLASGOW_HASKELL__ >= 710
138− OVERLAPPABLE_
139−#endif
140− HasParamSchema s (ParamSchema t)
141− => HasMaximum s (Maybe Scientific) where
142− maximum_ = paramSchema.maximum_
143−
144−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
145− => HasExclusiveMaximum s (Maybe Bool) where
146− exclusiveMaximum = paramSchema.exclusiveMaximum
147−
148−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
149− => HasMinimum s (Maybe Scientific) where
150− minimum_ = paramSchema.minimum_
151−
152−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
153− => HasExclusiveMinimum s (Maybe Bool) where
154− exclusiveMinimum = paramSchema.exclusiveMinimum
155−
156−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
157− => HasMaxLength s (Maybe Integer) where
158− maxLength = paramSchema.maxLength
159−
160−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
161− => HasMinLength s (Maybe Integer) where
162− minLength = paramSchema.minLength
163−
164−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
165− => HasPattern s (Maybe Text) where
166− pattern = paramSchema.pattern
167−
168−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
169− => HasMaxItems s (Maybe Integer) where
170− maxItems = paramSchema.maxItems
171−
172−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
173− => HasMinItems s (Maybe Integer) where
174− minItems = paramSchema.minItems
175−
176−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
177− => HasUniqueItems s (Maybe Bool) where
178− uniqueItems = paramSchema.uniqueItems
179−
180−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
181− => HasEnum s (Maybe [Value]) where
182− enum_ = paramSchema.enum_
183−
184−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
185− => HasMultipleOf s (Maybe Scientific) where
186− multipleOf = paramSchema.multipleOf
39+makeLenses ''ApiKeyParams
40+makeLenses ''OAuth2Params
41+makeLenses ''ExternalDocs
42+
43+-- =======================================================================
44+-- Helper classy lenses
45+-- =======================================================================
46+
47+class HasDescription s d | s -> d where
48+ description :: Lens' s d
49+
50+instance HasDescription Response Text where description = responseDescription
51+instance HasDescription Info (Maybe Text) where description = infoDescription
52+instance HasDescription Tag (Maybe Text) where description = tagDescription
53+instance HasDescription Operation (Maybe Text) where description = operationDescription
54+instance HasDescription Parameter (Maybe Text) where description = parameterDescription
55+instance HasDescription Header (Maybe Text) where description = headerDescription
56+instance HasDescription Schema (Maybe Text) where description = schemaDescription
57+instance HasDescription SecurityScheme (Maybe Text) where description = securitySchemeDescription
58+instance HasDescription ExternalDocs (Maybe Text) where description = externalDocsDescription
59+
60+class HasSchemaCommon s where
61+ schemaCommon :: Lens' s SchemaCommon
62+
63+instance HasSchemaCommon Schema where schemaCommon = schemaSchemaCommon
64+instance HasSchemaCommon ParameterOtherSchema where schemaCommon = parameterOtherSchemaCommon
65+instance HasSchemaCommon Items where schemaCommon = itemsCommon
66+instance HasSchemaCommon Header where schemaCommon = headerCommon
67+instance HasSchemaCommon SchemaCommon where schemaCommon = id
68+
69+schemaDefault :: HasSchemaCommon s => Lens' s (Maybe Value)
70+schemaDefault = schemaCommon.schemaCommonDefault
71+
72+schemaMaximum :: HasSchemaCommon s => Lens' s (Maybe Integer)
73+schemaMaximum = schemaCommon.schemaCommonMaximum
74+
75+schemaExclusiveMaximum :: HasSchemaCommon s => Lens' s (Maybe Bool)
76+schemaExclusiveMaximum = schemaCommon.schemaCommonExclusiveMaximum
77+
78+schemaMinimum :: HasSchemaCommon s => Lens' s (Maybe Integer)
79+schemaMinimum = schemaCommon.schemaCommonMinimum
80+
81+schemaExclusiveMinimum :: HasSchemaCommon s => Lens' s (Maybe Bool)
82+schemaExclusiveMinimum = schemaCommon.schemaCommonExclusiveMinimum
83+
84+schemaMaxLength :: HasSchemaCommon s => Lens' s (Maybe Integer)
85+schemaMaxLength = schemaCommon.schemaCommonMaxLength
86+
87+schemaMinLength :: HasSchemaCommon s => Lens' s (Maybe Integer)
88+schemaMinLength = schemaCommon.schemaCommonMinLength
89+
90+schemaPattern :: HasSchemaCommon s => Lens' s (Maybe Text)
91+schemaPattern = schemaCommon.schemaCommonPattern
92+
93+schemaMaxItems :: HasSchemaCommon s => Lens' s (Maybe Integer)
94+schemaMaxItems = schemaCommon.schemaCommonMaxItems
95+
96+schemaMinItems :: HasSchemaCommon s => Lens' s (Maybe Integer)
97+schemaMinItems = schemaCommon.schemaCommonMinItems
98+
99+schemaUniqueItems :: HasSchemaCommon s => Lens' s (Maybe Bool)
100+schemaUniqueItems = schemaCommon.schemaCommonUniqueItems
101+
102+schemaEnum :: HasSchemaCommon s => Lens' s (Maybe [Value])
103+schemaEnum = schemaCommon.schemaCommonEnum
104+
105+schemaMultipleOf :: HasSchemaCommon s => Lens' s (Maybe Integer)
106+schemaMultipleOf = schemaCommon.schemaCommonMultipleOf
107+
src/Data/Swagger/Operation.hsdeleted−193
@@ -1,193 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−-- |
3−-- Module: Data.Swagger.Operation
4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5−-- Stability: experimental
6−--
7−-- Helper traversals and functions for Swagger operations manipulations.
8−-- These might be useful when you already have Swagger specification
9−-- generated by something else.
10−module Data.Swagger.Operation (
11− -- * Operation traversals
12− allOperations,
13− operationsOf,
14−
15− -- * Manipulation
16− -- ** Tags
17− applyTags,
18− applyTagsFor,
19−
20− -- ** Responses
21− setResponse,
22− setResponseWith,
23− setResponseFor,
24− setResponseForWith,
25−
26− -- ** Paths
27− prependPath,
28−
29− -- * Miscellaneous
30− declareResponse,
31−) where
32−
33−import Prelude ()
34−import Prelude.Compat
35−
36−import Control.Lens
37−import Data.Data.Lens
38−import Data.List.Compat
39−import Data.Maybe (mapMaybe)
40−import Data.Proxy
41−import qualified Data.Set as Set
42−
43−import Data.Swagger.Declare
44−import Data.Swagger.Internal
45−import Data.Swagger.Lens
46−import Data.Swagger.Schema
47−
48−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
49−import qualified Data.HashSet.InsOrd as InsOrdHS
50−
51−-- $setup
52−-- >>> import Data.Aeson
53−-- >>> import Data.Proxy
54−-- >>> import Data.Time
55−
56−-- | Prepend path piece to all operations of the spec.
57−-- Leading and trailing slashes are trimmed/added automatically.
58−--
59−-- >>> let api = (mempty :: Swagger) & paths .~ [("/info", mempty)]
60−-- >>> encode $ prependPath "user/{user_id}" api ^. paths
61−-- "{\"/user/{user_id}/info\":{}}"
62−prependPath :: FilePath -> Swagger -> Swagger
63−prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)
64− where
65− x </> y = case trim y of
66− "" -> "/" <> trim x
67− y' -> "/" <> trim x <> "/" <> y'
68−
69− trim = dropWhile (== '/') . dropWhileEnd (== '/')
70−
71−-- | All operations of a Swagger spec.
72−allOperations :: Traversal' Swagger Operation
73−allOperations = paths.traverse.template
74−
75−-- | @'operationsOf' sub@ will traverse only those operations
76−-- that are present in @sub@. Note that @'Operation'@ is determined
77−-- by both path and method.
78−--
79−-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"
80−-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
81−-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
82−-- >>> encode api
83−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
84−-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"
85−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
86−operationsOf :: Swagger -> Traversal' Swagger Operation
87−operationsOf sub = paths.itraversed.withIndex.subops
88− where
89− -- | Traverse operations that correspond to paths and methods of the sub API.
90− subops :: Traversal' (FilePath, PathItem) Operation
91− subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of
92− Just subitem -> (,) path <$> methodsOf subitem f item
93− Nothing -> pure (path, item)
94−
95− -- | Traverse operations that exist in a given @'PathItem'@
96− -- This is used to traverse only the operations that exist in sub API.
97− methodsOf :: PathItem -> Traversal' PathItem Operation
98− methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just
99− where
100− ops = pathItem ^.. template :: [Maybe Operation]
101− ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops
102−
103−-- | Apply tags to all operations and update the global list of tags.
104−--
105−-- @
106−-- 'applyTags' = 'applyTagsFor' 'allOperations'
107−-- @
108−applyTags :: [Tag] -> Swagger -> Swagger
109−applyTags = applyTagsFor allOperations
110−
111−-- | Apply tags to a part of Swagger spec and update the global
112−-- list of tags.
113−applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
114−applyTagsFor ops ts swag = swag
115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
116− & tags %~ (<> InsOrdHS.fromList ts)
117−
118−-- | Construct a response with @'Schema'@ while declaring all
119−-- necessary schema definitions.
120−--
121−-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
122−-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"
123−declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response
124−declareResponse proxy = do
125− s <- declareSchemaRef proxy
126− return (mempty & schema ?~ s)
127−
128−-- | Set response for all operations.
129−-- This will also update global schema definitions.
130−--
131−-- If the response already exists it will be overwritten.
132−--
133−-- @
134−-- 'setResponse' = 'setResponseFor' 'allOperations'
135−-- @
136−--
137−-- Example:
138−--
139−-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
140−-- >>> let res = declareResponse (Proxy :: Proxy Day)
141−-- >>> encode $ api & setResponse 200 res
142−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}"
143−--
144−-- See also @'setResponseWith'@.
145−setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
146−setResponse = setResponseFor allOperations
147−
148−-- | Set or update response for all operations.
149−-- This will also update global schema definitions.
150−--
151−-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
152−-- then just the new response is used.
153−--
154−-- @
155−-- 'setResponseWith' = 'setResponseForWith' 'allOperations'
156−-- @
157−--
158−-- See also @'setResponse'@.
159−setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
160−setResponseWith = setResponseForWith allOperations
161−
162−-- | Set response for specified operations.
163−-- This will also update global schema definitions.
164−--
165−-- If the response already exists it will be overwritten.
166−--
167−-- See also @'setResponseForWith'@.
168−setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
169−setResponseFor ops code dres swag = swag
170− & definitions %~ (<> defs)
171− & ops . at code ?~ Inline res
172− where
173− (defs, res) = runDeclare dres mempty
174−
175−-- | Set or update response for specified operations.
176−-- This will also update global schema definitions.
177−--
178−-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
179−-- then just the new response is used.
180−--
181−-- See also @'setResponseFor'@.
182−setResponseForWith :: Traversal' Swagger Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
183−setResponseForWith ops f code dres swag = swag
184− & definitions %~ (<> defs)
185− & ops . at code %~ Just . Inline . combine
186− where
187− (defs, new) = runDeclare dres mempty
188−
189− combine (Just (Ref (Reference n))) = case swag ^. responses.at n of
190− Just old -> f old new
191− Nothing -> new -- response name can't be dereferenced, replacing with new response
192− combine (Just (Inline old)) = f old new
193− combine Nothing = new
src/Data/Swagger/Optics.hsdeleted−597
@@ -1,597 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE OverloadedLabels #-}
5−{-# LANGUAGE TemplateHaskell #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−{-# OPTIONS_GHC -fno-warn-orphans #-}
9−-- |
10−-- Module: Data.Swagger.Optics
11−-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>
12−-- Stability: experimental
13−--
14−-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>
15−-- library.
16−--
17−-- >>> import Data.Aeson
18−-- >>> import Optics.Core
19−-- >>> :set -XOverloadedLabels
20−--
21−-- Example from the "Data.Swagger" module using @optics@:
22−--
23−-- >>> :{
24−-- encode $ (mempty :: Swagger)
25−-- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]
26−-- & #paths .~
27−-- [ ("/user", mempty & #get ?~ (mempty
28−-- & #produces ?~ MimeList ["application/json"]
29−-- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))
30−-- & at 404 ?~ "User info not found")) ]
31−-- :}
32−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"
33−--
34−-- For convenience optics are defined as /labels/. It means that field accessor
35−-- names can be overloaded for different types. One such common field is
36−-- @#description@. Many components of a Swagger specification can have
37−-- descriptions, and you can use the same name for them:
38−--
39−-- >>> encode $ (mempty :: Response) & #description .~ "No content"
40−-- "{\"description\":\"No content\"}"
41−-- >>> :{
42−-- encode $ (mempty :: Schema)
43−-- & #type ?~ SwaggerBoolean
44−-- & #description ?~ "To be or not to be"
45−-- :}
46−-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
47−--
48−-- @'ParamSchema'@ is basically the /base schema specification/ and many types
49−-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively
50−-- made fields of the type that has it. For example, you can use @#type@ to
51−-- access @'SwaggerType'@ of @'Header'@ schema without having to use
52−-- @#paramSchema@:
53−--
54−-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber
55−-- "{\"type\":\"number\"}"
56−--
57−-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and
58−-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:
59−--
60−-- >>> :{
61−-- encode $ (mempty :: Operation)
62−-- & at 404 ?~ "Not found"
63−-- :}
64−-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"
65−--
66−module Data.Swagger.Optics () where
67−
68−import Data.Aeson (Value)
69−import Data.Scientific (Scientific)
70−import Data.Swagger.Internal
71−import Data.Text (Text)
72−import Optics.Core
73−import Optics.TH
74−
75−-- Lenses
76−
77−makeFieldLabels ''Swagger
78−makeFieldLabels ''Host
79−makeFieldLabels ''Info
80−makeFieldLabels ''Contact
81−makeFieldLabels ''License
82−makeFieldLabels ''PathItem
83−makeFieldLabels ''Tag
84−makeFieldLabels ''Operation
85−makeFieldLabels ''Param
86−makeFieldLabels ''ParamOtherSchema
87−makeFieldLabels ''Header
88−makeFieldLabels ''Schema
89−makeFieldLabels ''NamedSchema
90−makeFieldLabels ''ParamSchema
91−makeFieldLabels ''Xml
92−makeFieldLabels ''Responses
93−makeFieldLabels ''Response
94−makeFieldLabels ''SecurityScheme
95−makeFieldLabels ''ApiKeyParams
96−makeFieldLabels ''OAuth2Params
97−makeFieldLabels ''ExternalDocs
98−
99−-- Prisms
100−
101−makePrismLabels ''ParamAnySchema
102−makePrismLabels ''SecuritySchemeType
103−makePrismLabels ''Referenced
104−
105−-- SwaggerItems prisms
106−
107−instance
108− ( a ~ [Referenced Schema]
109− , b ~ [Referenced Schema]
110− ) => LabelOptic "_SwaggerItemsArray"
111− A_Review
112− (SwaggerItems 'SwaggerKindSchema)
113− (SwaggerItems 'SwaggerKindSchema)
114− a
115− b where
116− labelOptic = unto (\x -> SwaggerItemsArray x)
117− {-# INLINE labelOptic #-}
118−
119−instance
120− ( a ~ Referenced Schema
121− , b ~ Referenced Schema
122− ) => LabelOptic "_SwaggerItemsObject"
123− A_Review
124− (SwaggerItems 'SwaggerKindSchema)
125− (SwaggerItems 'SwaggerKindSchema)
126− a
127− b where
128− labelOptic = unto (\x -> SwaggerItemsObject x)
129− {-# INLINE labelOptic #-}
130−
131−instance
132− ( a ~ (Maybe (CollectionFormat t), ParamSchema t)
133− , b ~ (Maybe (CollectionFormat t), ParamSchema t)
134− ) => LabelOptic "_SwaggerItemsPrimitive"
135− A_Review
136− (SwaggerItems t)
137− (SwaggerItems t)
138− a
139− b where
140− labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)
141− {-# INLINE labelOptic #-}
142−
143−-- =============================================================
144−-- More helpful instances for easier access to schema properties
145−
146−type instance Index Responses = HttpStatusCode
147−type instance Index Operation = HttpStatusCode
148−
149−type instance IxValue Responses = Referenced Response
150−type instance IxValue Operation = Referenced Response
151−
152−instance Ixed Responses where
153− ix n = #responses % ix n
154− {-# INLINE ix #-}
155−instance At Responses where
156− at n = #responses % at n
157− {-# INLINE at #-}
158−
159−instance Ixed Operation where
160− ix n = #responses % ix n
161− {-# INLINE ix #-}
162−instance At Operation where
163− at n = #responses % at n
164− {-# INLINE at #-}
165−
166−-- #paramSchema
167−
168−instance
169− ( a ~ ParamSchema 'SwaggerKindSchema
170− , b ~ ParamSchema 'SwaggerKindSchema
171− ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where
172− labelOptic = #schema % #paramSchema
173− {-# INLINE labelOptic #-}
174−
175−-- #type
176−
177−instance
178− ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))
179− , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))
180− ) => LabelOptic "type" A_Lens Header Header a b where
181− labelOptic = #paramSchema % #type
182− {-# INLINE labelOptic #-}
183−
184−instance
185− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)
186− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)
187− ) => LabelOptic "type" A_Lens Schema Schema a b where
188− labelOptic = #paramSchema % #type
189− {-# INLINE labelOptic #-}
190−
191−instance
192− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)
193− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)
194− ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where
195− labelOptic = #paramSchema % #type
196− {-# INLINE labelOptic #-}
197−
198−instance
199− ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
200− , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
201− ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where
202− labelOptic = #paramSchema % #type
203− {-# INLINE labelOptic #-}
204−
205−-- #default
206−
207−instance
208− ( a ~ Maybe Value, b ~ Maybe Value
209− ) => LabelOptic "default" A_Lens Header Header a b where
210− labelOptic = #paramSchema % #default
211− {-# INLINE labelOptic #-}
212−
213−instance
214− ( a ~ Maybe Value, b ~ Maybe Value
215− ) => LabelOptic "default" A_Lens Schema Schema a b where
216− labelOptic = #paramSchema % #default
217− {-# INLINE labelOptic #-}
218−
219−instance
220− ( a ~ Maybe Value, b ~ Maybe Value
221− ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where
222− labelOptic = #paramSchema % #default
223− {-# INLINE labelOptic #-}
224−
225−instance
226− ( a ~ Maybe Value, b ~ Maybe Value
227− ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where
228− labelOptic = #paramSchema % #default
229− {-# INLINE labelOptic #-}
230−
231−-- #format
232−
233−instance
234− ( a ~ Maybe Format, b ~ Maybe Format
235− ) => LabelOptic "format" A_Lens Header Header a b where
236− labelOptic = #paramSchema % #format
237− {-# INLINE labelOptic #-}
238−
239−instance
240− ( a ~ Maybe Format, b ~ Maybe Format
241− ) => LabelOptic "format" A_Lens Schema Schema a b where
242− labelOptic = #paramSchema % #format
243− {-# INLINE labelOptic #-}
244−
245−instance
246− ( a ~ Maybe Format, b ~ Maybe Format
247− ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where
248− labelOptic = #paramSchema % #format
249− {-# INLINE labelOptic #-}
250−
251−instance
252− ( a ~ Maybe Format, b ~ Maybe Format
253− ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where
254− labelOptic = #paramSchema % #format
255− {-# INLINE labelOptic #-}
256−
257−-- #items
258−
259−instance
260− ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))
261− , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))
262− ) => LabelOptic "items" A_Lens Header Header a b where
263− labelOptic = #paramSchema % #items
264− {-# INLINE labelOptic #-}
265−
266−instance
267− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)
268− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)
269− ) => LabelOptic "items" A_Lens Schema Schema a b where
270− labelOptic = #paramSchema % #items
271− {-# INLINE labelOptic #-}
272−
273−instance
274− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)
275− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)
276− ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where
277− labelOptic = #paramSchema % #items
278− {-# INLINE labelOptic #-}
279−
280−instance
281− ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)
282− , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)
283− ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where
284− labelOptic = #paramSchema % #items
285− {-# INLINE labelOptic #-}
286−
287−-- #maximum
288−
289−instance
290− ( a ~ Maybe Scientific, b ~ Maybe Scientific
291− ) => LabelOptic "maximum" A_Lens Header Header a b where
292− labelOptic = #paramSchema % #maximum
293− {-# INLINE labelOptic #-}
294−
295−instance
296− ( a ~ Maybe Scientific, b ~ Maybe Scientific
297− ) => LabelOptic "maximum" A_Lens Schema Schema a b where
298− labelOptic = #paramSchema % #maximum
299− {-# INLINE labelOptic #-}
300−
301−instance
302− ( a ~ Maybe Scientific, b ~ Maybe Scientific
303− ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where
304− labelOptic = #paramSchema % #maximum
305− {-# INLINE labelOptic #-}
306−
307−instance
308− ( a ~ Maybe Scientific, b ~ Maybe Scientific
309− ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where
310− labelOptic = #paramSchema % #maximum
311− {-# INLINE labelOptic #-}
312−
313−-- #exclusiveMaximum
314−
315−instance
316− ( a ~ Maybe Bool, b ~ Maybe Bool
317− ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where
318− labelOptic = #paramSchema % #exclusiveMaximum
319− {-# INLINE labelOptic #-}
320−
321−instance
322− ( a ~ Maybe Bool, b ~ Maybe Bool
323− ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where
324− labelOptic = #paramSchema % #exclusiveMaximum
325− {-# INLINE labelOptic #-}
326−
327−instance
328− ( a ~ Maybe Bool, b ~ Maybe Bool
329− ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where
330− labelOptic = #paramSchema % #exclusiveMaximum
331− {-# INLINE labelOptic #-}
332−
333−instance
334− ( a ~ Maybe Bool, b ~ Maybe Bool
335− ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where
336− labelOptic = #paramSchema % #exclusiveMaximum
337− {-# INLINE labelOptic #-}
338−
339−-- #minimum
340−
341−instance
342− ( a ~ Maybe Scientific, b ~ Maybe Scientific
343− ) => LabelOptic "minimum" A_Lens Header Header a b where
344− labelOptic = #paramSchema % #minimum
345− {-# INLINE labelOptic #-}
346−
347−instance
348− ( a ~ Maybe Scientific, b ~ Maybe Scientific
349− ) => LabelOptic "minimum" A_Lens Schema Schema a b where
350− labelOptic = #paramSchema % #minimum
351− {-# INLINE labelOptic #-}
352−
353−instance
354− ( a ~ Maybe Scientific, b ~ Maybe Scientific
355− ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where
356− labelOptic = #paramSchema % #minimum
357− {-# INLINE labelOptic #-}
358−
359−instance
360− ( a ~ Maybe Scientific, b ~ Maybe Scientific
361− ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where
362− labelOptic = #paramSchema % #minimum
363− {-# INLINE labelOptic #-}
364−
365−-- #exclusiveMinimum
366−
367−instance
368− ( a ~ Maybe Bool, b ~ Maybe Bool
369− ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where
370− labelOptic = #paramSchema % #exclusiveMinimum
371− {-# INLINE labelOptic #-}
372−
373−instance
374− ( a ~ Maybe Bool, b ~ Maybe Bool
375− ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where
376− labelOptic = #paramSchema % #exclusiveMinimum
377− {-# INLINE labelOptic #-}
378−
379−instance
380− ( a ~ Maybe Bool, b ~ Maybe Bool
381− ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where
382− labelOptic = #paramSchema % #exclusiveMinimum
383− {-# INLINE labelOptic #-}
384−
385−instance
386− ( a ~ Maybe Bool, b ~ Maybe Bool
387− ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where
388− labelOptic = #paramSchema % #exclusiveMinimum
389− {-# INLINE labelOptic #-}
390−
391−-- #maxLength
392−
393−instance
394− ( a ~ Maybe Integer, b ~ Maybe Integer
395− ) => LabelOptic "maxLength" A_Lens Header Header a b where
396− labelOptic = #paramSchema % #maxLength
397− {-# INLINE labelOptic #-}
398−
399−instance
400− ( a ~ Maybe Integer, b ~ Maybe Integer
401− ) => LabelOptic "maxLength" A_Lens Schema Schema a b where
402− labelOptic = #paramSchema % #maxLength
403− {-# INLINE labelOptic #-}
404−
405−instance
406− ( a ~ Maybe Integer, b ~ Maybe Integer
407− ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where
408− labelOptic = #paramSchema % #maxLength
409− {-# INLINE labelOptic #-}
410−
411−instance
412− ( a ~ Maybe Integer, b ~ Maybe Integer
413− ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where
414− labelOptic = #paramSchema % #maxLength
415− {-# INLINE labelOptic #-}
416−
417−-- #minLength
418−
419−instance
420− ( a ~ Maybe Integer, b ~ Maybe Integer
421− ) => LabelOptic "minLength" A_Lens Header Header a b where
422− labelOptic = #paramSchema % #minLength
423− {-# INLINE labelOptic #-}
424−
425−instance
426− ( a ~ Maybe Integer, b ~ Maybe Integer
427− ) => LabelOptic "minLength" A_Lens Schema Schema a b where
428− labelOptic = #paramSchema % #minLength
429− {-# INLINE labelOptic #-}
430−
431−instance
432− ( a ~ Maybe Integer, b ~ Maybe Integer
433− ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where
434− labelOptic = #paramSchema % #minLength
435− {-# INLINE labelOptic #-}
436−
437−instance
438− ( a ~ Maybe Integer, b ~ Maybe Integer
439− ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where
440− labelOptic = #paramSchema % #minLength
441− {-# INLINE labelOptic #-}
442−
443−-- #pattern
444−
445−instance
446− ( a ~ Maybe Text, b ~ Maybe Text
447− ) => LabelOptic "pattern" A_Lens Header Header a b where
448− labelOptic = #paramSchema % #pattern
449− {-# INLINE labelOptic #-}
450−
451−instance
452− ( a ~ Maybe Text, b ~ Maybe Text
453− ) => LabelOptic "pattern" A_Lens Schema Schema a b where
454− labelOptic = #paramSchema % #pattern
455− {-# INLINE labelOptic #-}
456−
457−instance
458− ( a ~ Maybe Text, b ~ Maybe Text
459− ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where
460− labelOptic = #paramSchema % #pattern
461− {-# INLINE labelOptic #-}
462−
463−instance
464− ( a ~ Maybe Text, b ~ Maybe Text
465− ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where
466− labelOptic = #paramSchema % #pattern
467− {-# INLINE labelOptic #-}
468−
469−-- #maxItems
470−
471−instance
472− ( a ~ Maybe Integer, b ~ Maybe Integer
473− ) => LabelOptic "maxItems" A_Lens Header Header a b where
474− labelOptic = #paramSchema % #maxItems
475− {-# INLINE labelOptic #-}
476−
477−instance
478− ( a ~ Maybe Integer, b ~ Maybe Integer
479− ) => LabelOptic "maxItems" A_Lens Schema Schema a b where
480− labelOptic = #paramSchema % #maxItems
481− {-# INLINE labelOptic #-}
482−
483−instance
484− ( a ~ Maybe Integer, b ~ Maybe Integer
485− ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where
486− labelOptic = #paramSchema % #maxItems
487− {-# INLINE labelOptic #-}
488−
489−instance
490− ( a ~ Maybe Integer, b ~ Maybe Integer
491− ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
492− labelOptic = #paramSchema % #maxItems
493− {-# INLINE labelOptic #-}
494−
495−-- #minItems
496−
497−instance
498− ( a ~ Maybe Integer, b ~ Maybe Integer
499− ) => LabelOptic "minItems" A_Lens Header Header a b where
500− labelOptic = #paramSchema % #minItems
501− {-# INLINE labelOptic #-}
502−
503−instance
504− ( a ~ Maybe Integer, b ~ Maybe Integer
505− ) => LabelOptic "minItems" A_Lens Schema Schema a b where
506− labelOptic = #paramSchema % #minItems
507− {-# INLINE labelOptic #-}
508−
509−instance
510− ( a ~ Maybe Integer, b ~ Maybe Integer
511− ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where
512− labelOptic = #paramSchema % #minItems
513− {-# INLINE labelOptic #-}
514−
515−instance
516− ( a ~ Maybe Integer, b ~ Maybe Integer
517− ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
518− labelOptic = #paramSchema % #minItems
519− {-# INLINE labelOptic #-}
520−
521−-- #uniqueItems
522−
523−instance
524− ( a ~ Maybe Bool, b ~ Maybe Bool
525− ) => LabelOptic "uniqueItems" A_Lens Header Header a b where
526− labelOptic = #paramSchema % #uniqueItems
527− {-# INLINE labelOptic #-}
528−
529−instance
530− ( a ~ Maybe Bool, b ~ Maybe Bool
531− ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where
532− labelOptic = #paramSchema % #uniqueItems
533− {-# INLINE labelOptic #-}
534−
535−instance
536− ( a ~ Maybe Bool, b ~ Maybe Bool
537− ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where
538− labelOptic = #paramSchema % #uniqueItems
539− {-# INLINE labelOptic #-}
540−
541−instance
542− ( a ~ Maybe Bool, b ~ Maybe Bool
543− ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
544− labelOptic = #paramSchema % #uniqueItems
545− {-# INLINE labelOptic #-}
546−
547−-- #enum
548−
549−instance
550− ( a ~ Maybe [Value], b ~ Maybe [Value]
551− ) => LabelOptic "enum" A_Lens Header Header a b where
552− labelOptic = #paramSchema % #enum
553− {-# INLINE labelOptic #-}
554−
555−instance
556− ( a ~ Maybe [Value], b ~ Maybe [Value]
557− ) => LabelOptic "enum" A_Lens Schema Schema a b where
558− labelOptic = #paramSchema % #enum
559− {-# INLINE labelOptic #-}
560−
561−instance
562− ( a ~ Maybe [Value], b ~ Maybe [Value]
563− ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where
564− labelOptic = #paramSchema % #enum
565− {-# INLINE labelOptic #-}
566−
567−instance
568− ( a ~ Maybe [Value], b ~ Maybe [Value]
569− ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where
570− labelOptic = #paramSchema % #enum
571− {-# INLINE labelOptic #-}
572−
573−-- #multipleOf
574−
575−instance
576− ( a ~ Maybe Scientific, b ~ Maybe Scientific
577− ) => LabelOptic "multipleOf" A_Lens Header Header a b where
578− labelOptic = #paramSchema % #multipleOf
579− {-# INLINE labelOptic #-}
580−
581−instance
582− ( a ~ Maybe Scientific, b ~ Maybe Scientific
583− ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where
584− labelOptic = #paramSchema % #multipleOf
585− {-# INLINE labelOptic #-}
586−
587−instance
588− ( a ~ Maybe Scientific, b ~ Maybe Scientific
589− ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where
590− labelOptic = #paramSchema % #multipleOf
591− {-# INLINE labelOptic #-}
592−
593−instance
594− ( a ~ Maybe Scientific, b ~ Maybe Scientific
595− ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where
596− labelOptic = #paramSchema % #multipleOf
597− {-# INLINE labelOptic #-}
src/Data/Swagger/ParamSchema.hsdeleted−26
@@ -1,26 +0,0 @@
1−-- |
2−-- Module: Data.Swagger.ParamSchema
3−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4−-- Stability: experimental
5−--
6−-- Types and functions for working with Swagger parameter schema.
7−module Data.Swagger.ParamSchema (
8− -- * Encoding
9− ToParamSchema(..),
10−
11− -- * Generic schema encoding
12− genericToParamSchema,
13− toParamSchemaBoundedIntegral,
14−
15− -- * Schema templates
16− passwordParamSchema,
17− binaryParamSchema,
18− byteParamSchema,
19−
20− -- * Generic encoding configuration
21− SchemaOptions(..),
22− defaultSchemaOptions,
23−) where
24−
25−import Data.Swagger.Internal.ParamSchema
26−import Data.Swagger.SchemaOptions
src/Data/Swagger/Schema.hs+8−51
@@ -1,61 +1,18 @@
1−-- |
2−-- Module: Data.Swagger.Schema
3−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4−-- Stability: experimental
5−--
6−-- Types and functions for working with Swagger schema.
71module Data.Swagger.Schema (
8− -- * Encoding
92 ToSchema(..),
10− declareSchema,
11− declareSchemaRef,
123 toSchema,
134 toSchemaRef,
145 schemaName,
15− toInlinedSchema,
166
17− -- * Generic schema encoding
18− genericDeclareNamedSchema,
19− genericDeclareSchema,
20− genericDeclareNamedSchemaNewtype,
21− genericNameSchema,
22−
23− -- ** 'Bounded' 'Integral'
24− genericToNamedSchemaBoundedIntegral,
25− toSchemaBoundedIntegral,
26−
27− -- ** 'Bounded' 'Enum' key mappings
28− declareSchemaBoundedEnumKeyMapping,
29− toSchemaBoundedEnumKeyMapping,
30−
31− -- ** Reusing 'ToParamSchema'
32− paramSchemaToNamedSchema,
33− paramSchemaToSchema,
34−
35− -- ** Unrestricted versions
36− genericDeclareNamedSchemaUnrestricted,
37− genericDeclareSchemaUnrestricted,
38−
39− -- * Schema templates
40− passwordSchema,
41− binarySchema,
42− byteSchema,
43−
44− -- * Sketching @'Schema'@s using @'ToJSON'@
45− sketchSchema,
46− sketchStrictSchema,
47−
48− -- * Inlining @'Schema'@s
49− inlineNonRecursiveSchemas,
50− inlineAllSchemas,
51− inlineSchemas,
52− inlineSchemasWhen,
53−
54− -- * Generic encoding configuration
557 SchemaOptions(..),
568 defaultSchemaOptions,
57− fromAesonOptions,
9+
10+ genericToSchema,
11+ genericToNamedSchema,
12+ genericToNamedSchemaBoundedEnum,
13+
14+ toSchemaBoundedIntegral,
15+ toSchemaBoundedEnum,
5816) where
5917
60−import Data.Swagger.Internal.Schema
61−import Data.Swagger.SchemaOptions
18+import Data.Swagger.Schema.Internal
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/Internal.hsnew file+236
@@ -0,0 +1,236 @@
1+{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE TypeSynonymInstances #-}
11+module Data.Swagger.Schema.Internal where
12+
13+import Control.Lens
14+import Data.Aeson
15+import Data.Char
16+import Data.HashMap.Strict (HashMap)
17+import Data.HashSet (HashSet)
18+import Data.Int
19+import Data.Map (Map)
20+import Data.Monoid
21+import Data.Proxy
22+import Data.Set (Set)
23+import qualified Data.Text as T
24+import qualified Data.Text.Lazy as TL
25+import Data.Word
26+import GHC.Generics
27+
28+import Data.Swagger.Internal
29+import Data.Swagger.Lens
30+
31+type NamedSchema = (Maybe String, Schema)
32+
33+unnamed :: Schema -> NamedSchema
34+unnamed schema = (Nothing, schema)
35+
36+named :: String -> Schema -> NamedSchema
37+named name schema = (Just name, schema)
38+
39+class ToSchema a where
40+ toNamedSchema :: proxy a -> NamedSchema
41+ default toNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> NamedSchema
42+ toNamedSchema = genericToNamedSchema defaultSchemaOptions
43+
44+schemaName :: ToSchema a => proxy a -> Maybe String
45+schemaName = fst . toNamedSchema
46+
47+toSchema :: ToSchema a => proxy a -> Schema
48+toSchema = snd . toNamedSchema
49+
50+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
51+toSchemaRef proxy = case toNamedSchema proxy of
52+ (Just name, _) -> Ref (Reference ("#/definitions/" <> T.pack name))
53+ (_, schema) -> Inline schema
54+
55+class GToSchema (f :: * -> *) where
56+ gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema
57+
58+gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema
59+gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
60+
61+instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
62+ toNamedSchema _ = unnamed $ mempty
63+ & schemaType .~ SchemaArray
64+ & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
65+
66+instance {-# OVERLAPPING #-} ToSchema String where
67+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaString
68+
69+instance ToSchema Bool where
70+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaBoolean
71+
72+instance ToSchema Integer where
73+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaInteger
74+
75+instance ToSchema Int where toNamedSchema = unnamed . toSchemaBoundedIntegral
76+instance ToSchema Int8 where toNamedSchema = unnamed . toSchemaBoundedIntegral
77+instance ToSchema Int16 where toNamedSchema = unnamed . toSchemaBoundedIntegral
78+instance ToSchema Int32 where toNamedSchema = unnamed . toSchemaBoundedIntegral
79+instance ToSchema Int64 where toNamedSchema = unnamed . toSchemaBoundedIntegral
80+
81+instance ToSchema Word where toNamedSchema = unnamed . toSchemaBoundedIntegral
82+instance ToSchema Word8 where toNamedSchema = unnamed . toSchemaBoundedIntegral
83+instance ToSchema Word16 where toNamedSchema = unnamed . toSchemaBoundedIntegral
84+instance ToSchema Word32 where toNamedSchema = unnamed . toSchemaBoundedIntegral
85+instance ToSchema Word64 where toNamedSchema = unnamed . toSchemaBoundedIntegral
86+
87+instance ToSchema Double where
88+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
89+
90+instance ToSchema Float where
91+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
92+
93+instance ToSchema a => ToSchema (Maybe a) where
94+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
95+
96+instance (ToSchema a, ToSchema b) => ToSchema (a, b)
97+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
98+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
99+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
100+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
101+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
102+
103+instance ToSchema T.Text where
104+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String)
105+
106+instance ToSchema TL.Text where
107+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String)
108+
109+instance ToSchema a => ToSchema (Map String a) where
110+ toNamedSchema _ = unnamed $ mempty
111+ & schemaType .~ SchemaObject
112+ & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
113+
114+instance ToSchema a => ToSchema (Map T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
115+instance ToSchema a => ToSchema (Map TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
116+
117+instance ToSchema a => ToSchema (HashMap String a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
118+instance ToSchema a => ToSchema (HashMap T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
119+instance ToSchema a => ToSchema (HashMap TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
120+
121+instance ToSchema a => ToSchema (Set a) where
122+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy [a])
123+ & schemaUniqueItems ?~ True
124+
125+instance ToSchema a => ToSchema (HashSet a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Set a))
126+
127+instance ToSchema All where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool)
128+instance ToSchema Any where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool)
129+instance ToSchema a => ToSchema (Sum a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
130+instance ToSchema a => ToSchema (Product a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
131+instance ToSchema a => ToSchema (First a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
132+instance ToSchema a => ToSchema (Last a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
133+instance ToSchema a => ToSchema (Dual a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
134+
135+data SchemaOptions = SchemaOptions
136+ { fieldLabelModifier :: String -> String
137+ , datatypeNameModifier :: String -> String
138+ , unwrapUnaryRecords :: Bool
139+ }
140+
141+defaultSchemaOptions :: SchemaOptions
142+defaultSchemaOptions = SchemaOptions
143+ { fieldLabelModifier = id
144+ , datatypeNameModifier = id
145+ , unwrapUnaryRecords = False
146+ }
147+
148+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
149+toSchemaBoundedIntegral _ = mempty
150+ & schemaType .~ SchemaInteger
151+ & schemaMinimum ?~ toInteger (minBound :: a)
152+ & schemaMaximum ?~ toInteger (maxBound :: a)
153+
154+toSchemaBoundedEnum :: forall a proxy. (ToJSON a, Bounded a, Enum a) => proxy a -> Schema
155+toSchemaBoundedEnum _ = mempty
156+ & schemaType .~ SchemaString
157+ & schemaEnum ?~ map toJSON [minBound..maxBound :: a]
158+
159+genericToNamedSchemaBoundedEnum :: (ToJSON a, Bounded a, Enum a, Generic a) => proxy a -> NamedSchema
160+genericToNamedSchemaBoundedEnum = unnamed . toSchemaBoundedEnum
161+
162+genericToSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Schema
163+genericToSchema opts = snd . genericToNamedSchema opts
164+
165+genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
166+genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
167+
168+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String
169+gdatatypeSchemaName opts _ = case name of
170+ (c:_) | isAlpha c && isUpper c -> Just name
171+ _ -> Nothing
172+ where
173+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
174+
175+instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
176+ gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g)
177+
178+-- | Single constructor data type.
179+instance {-# OVERLAPPABLE #-} (Datatype d, GToSchema f) => GToSchema (D1 d (C1 c f)) where
180+ gtoNamedSchema opts _ s = (schemaName, gtoSchema opts (Proxy :: Proxy f) s)
181+ where
182+ schemaName = gdatatypeSchemaName opts (Proxy :: Proxy d)
183+
184+-- | Single field single constructor data type.
185+instance (Datatype d, Selector s, GToSchema f) => GToSchema (D1 d (C1 c (S1 s f))) where
186+ gtoNamedSchema opts _ s
187+ | unwrapUnaryRecords opts = (schemaName, gtoSchema opts (Proxy :: Proxy f) s)
188+ | otherwise = (schemaName,) $
189+ case schema ^. schemaItems of
190+ Just (SchemaItemsArray [_]) -> fieldSchema
191+ _ -> schema
192+ where
193+ schemaName = gdatatypeSchemaName opts (Proxy :: Proxy d)
194+ schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s
195+ fieldSchema = gtoSchema opts (Proxy :: Proxy f) s
196+
197+gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> Referenced Schema
198+gtoSchemaRef opts proxy = case gtoNamedSchema opts proxy mempty of
199+ (Just name, _) -> Ref (Reference ("#/definitions/" <> T.pack name))
200+ (_, schema) -> Inline schema
201+
202+appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
203+appendItem x Nothing = Just (SchemaItemsArray [x])
204+appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
205+appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
206+
207+withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Schema
208+withFieldSchema opts _ isRequiredField schema
209+ | T.null fieldName = schema
210+ & schemaType .~ SchemaArray
211+ & schemaItems %~ appendItem fieldSchemaRef
212+ | otherwise = schema
213+ & schemaType .~ SchemaObject
214+ & schemaProperties . at fieldName ?~ fieldSchemaRef
215+ & if isRequiredField
216+ then schemaRequired %~ (fieldName :)
217+ else id
218+ where
219+ fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
220+ fieldSchemaRef = gtoSchemaRef opts (Proxy :: Proxy f)
221+
222+-- | Optional record fields.
223+instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
224+ gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
225+
226+-- | Record fields.
227+instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
228+ gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
229+
230+instance ToSchema c => GToSchema (K1 i c) where
231+ gtoNamedSchema _ _ _ = toNamedSchema (Proxy :: Proxy c)
232+
233+data Proxy2 a b = Proxy2
234+
235+data Proxy3 a b c = Proxy3
236+
src/Data/Swagger/Schema/Validation.hsdeleted−90
@@ -1,90 +0,0 @@
1−-- |
2−-- Module: Data.Swagger.Schema.Validation
3−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4−-- Stability: experimental
5−--
6−-- Validate JSON values with Swagger Schema.
7−module Data.Swagger.Schema.Validation (
8− -- * How to use validation
9− -- $howto
10−
11− -- ** Examples
12− -- $examples
13−
14− -- ** Validating @'Maybe'@
15− -- $maybe
16−
17− -- * JSON validation
18−
19− ValidationError,
20−
21− -- ** Using 'ToJSON' and 'ToSchema'
22− validatePrettyToJSON,
23− validateToJSON,
24− validateToJSONWithPatternChecker,
25− renderValidationErrors,
26−
27− -- ** Using 'Value' and 'Schema'
28− validateJSON,
29− validateJSONWithPatternChecker,
30−) where
31−
32−import Data.Swagger.Internal.Schema.Validation
33−
34−-- $setup
35−-- >>> import Control.Lens
36−-- >>> import Data.Aeson
37−-- >>> import Data.Proxy
38−-- >>> import Data.Swagger
39−-- >>> import GHC.Generics
40−-- >>> :set -XDeriveGeneric
41−
42−-- $howto
43−--
44−-- This module provides helpful functions for JSON validation.
45−-- These functions are meant to be used in test suites for your application
46−-- to ensure that JSON respresentation for your data corresponds to
47−-- schemas you're using for the Swagger specification.
48−--
49−-- It is recommended to use validation functions as QuickCheck properties
50−-- (see <http://hackage.haskell.org/package/QuickCheck>).
51−
52−-- $examples
53−--
54−-- >>> validateToJSON "hello"
55−-- []
56−--
57−-- >>> validateToJSON False
58−-- []
59−--
60−-- >>> newtype Nat = Nat Integer deriving Generic
61−-- >>> instance ToJSON Nat where toJSON (Nat n) = toJSON n
62−-- >>> instance ToSchema Nat where declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy & mapped.minimum_ ?~ 0
63−-- >>> validateToJSON (Nat 10)
64−-- []
65−-- >>> validateToJSON (Nat (-5))
66−-- ["value -5.0 falls below minimum (should be >=0.0)"]
67−
68−-- $maybe
69−--
70−-- Because @'Maybe' a@ has the same schema as @a@, validation
71−-- generally fails for @null@ JSON:
72−--
73−-- >>> validateToJSON (Nothing :: Maybe String)
74−-- ["expected JSON value of type SwaggerString"]
75−-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])
76−-- ["expected JSON value of type SwaggerString"]
77−-- >>> validateToJSON (123, Nothing :: Maybe String)
78−-- ["expected JSON value of type SwaggerString"]
79−--
80−-- However, when @'Maybe' a@ is a type of a record field,
81−-- validation takes @'required'@ property of the @'Schema'@
82−-- into account:
83−--
84−-- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic
85−-- >>> instance ToJSON Person
86−-- >>> instance ToSchema Person
87−-- >>> validateToJSON (Person "Nick" (Just 24))
88−-- []
89−-- >>> validateToJSON (Person "Nick" Nothing)
90−-- []
src/Data/Swagger/SchemaOptions.hsdeleted−72
@@ -1,72 +0,0 @@
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'@.
8−module Data.Swagger.SchemaOptions where
9−
10−import qualified Data.Aeson.Types as Aeson
11−
12−-- | Options that specify how to encode your type to Swagger schema.
13−data SchemaOptions = SchemaOptions
14− { -- | Function applied to field labels. Handy for removing common record prefixes for example.
15− fieldLabelModifier :: String -> String
16− -- | Function applied to constructor tags which could be handy for lower-casing them for example.
17− , constructorTagModifier :: String -> String
18− -- | Function applied to datatype name.
19− , datatypeNameModifier :: String -> String
20− -- | If @'True'@ the constructors of a datatype, with all nullary constructors,
21− -- will be encoded to a string enumeration schema with the constructor tags as possible values.
22− , allNullaryToStringTag :: Bool
23− -- | Hide the field name when a record constructor has only one field, like a newtype.
24− , unwrapUnaryRecords :: Bool
25− }
26−
27−-- | Default encoding @'SchemaOptions'@.
28−--
29−-- @
30−-- 'SchemaOptions'
31−-- { 'fieldLabelModifier' = id
32−-- , 'constructorTagModifier' = id
33−-- , 'datatypeNameModifier' = id
34−-- , 'allNullaryToStringTag' = True
35−-- , 'unwrapUnaryRecords' = False
36−-- }
37−-- @
38−defaultSchemaOptions :: SchemaOptions
39−defaultSchemaOptions = SchemaOptions
40− { fieldLabelModifier = id
41− , constructorTagModifier = id
42− , datatypeNameModifier = id
43− , allNullaryToStringTag = True
44− , unwrapUnaryRecords = False
45− }
46−
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-7.8.yamlnew file+5
@@ -0,0 +1,5 @@
1+flags: {}
2+packages:
3+- '.'
4+extra-deps:
5+resolver: lts-2.22
stack-head.yamlnew file+5
@@ -0,0 +1,5 @@
1+flags: {}
2+packages:
3+- '.'
4+extra-deps:
5+resolver: nightly-2015-11-08
stack.yaml+2−6
@@ -1,9 +1,5 @@
1−resolver: lts-14.3
1+flags: {}
22packages:
33- '.'
44extra-deps:
5−- optics-core-0.2
6−- optics-th-0.2
7−- optics-extra-0.2
8−- indexed-profunctors-0.1
9−- insert-ordered-containers-0.2.3
5+resolver: lts-3.12
swagger2.cabal+27−117
@@ -1,154 +1,64 @@
1−cabal-version: >=1.10
21name: swagger2
3−version: 2.5
4−
2+version: 0.3
53synopsis: Swagger 2.0 data model
6−category: Web, Swagger
7−description:
8− This library is intended to be used for decoding and encoding Swagger 2.0 API
9− specifications as well as manipulating them.
10− .
11− The original Swagger 2.0 specification is available at http://swagger.io/specification/.
12−
4+description: Please see README.md
135homepage: https://github.com/GetShopTV/swagger2
146bug-reports: https://github.com/GetShopTV/swagger2/issues
157license: BSD3
168license-file: LICENSE
179author: Nickolay Kudasov
1810maintainer: nickolay@getshoptv.com
19−copyright: (c) 2015-2016, GetShopTV
20−build-type: Custom
11+copyright: (c) 2015, GetShopTV
12+category: Web
13+build-type: Simple
2114extra-source-files:
2215 README.md
2316 , CHANGELOG.md
24− , examples/*.hs
25− , include/overlapping-compat.h
26−tested-with:
27− GHC ==8.0.2
28− || ==8.2.2
29− || ==8.4.4
30− || ==8.6.5
31− || ==8.8.1
32−
33−custom-setup
34− setup-depends:
35− base, Cabal, cabal-doctest >=1.0.6 && <1.1
17+cabal-version: >=1.10
3618
3719library
3820 hs-source-dirs: src
39− include-dirs: include
4021 exposed-modules:
4122 Data.Swagger
42− Data.Swagger.Declare
4323 Data.Swagger.Lens
44− Data.Swagger.Operation
45− Data.Swagger.Optics
46− Data.Swagger.ParamSchema
4724 Data.Swagger.Schema
48− Data.Swagger.Schema.Generator
49− Data.Swagger.Schema.Validation
50− Data.Swagger.SchemaOptions
5125
5226 -- internal modules
5327 Data.Swagger.Internal
54− Data.Swagger.Internal.Schema
55− Data.Swagger.Internal.Schema.Validation
56− Data.Swagger.Internal.ParamSchema
5728 Data.Swagger.Internal.Utils
58− Data.Swagger.Internal.AesonUtils
59− Data.Swagger.Internal.TypeShape
60−
61− -- GHC boot libraries
62− build-depends:
63− base >=4.9 && <4.14
64− , aeson-pretty >=0.8.7 && <0.9
65− , bytestring >=0.10.4.0 && <0.11
66− , containers >=0.5.5.1 && <0.7
67− , template-haskell >=2.9.0.0 && <2.16
68− , time >=1.4.2 && <1.10
69− , transformers >=0.3.0.0 && <0.6
70−
71− build-depends:
72− mtl >=2.1 && <2.3
73− , text >=1.2.3.0 && <1.3
74−
75− -- other dependencies
76− build-depends:
77− base-compat-batteries >=0.10.4 && <0.12
78− , aeson >=1.4.2.0 && <1.5
79− -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
80− , cookie >=0.4.3 && <0.5
81− , generics-sop >=0.3.2.0 && <0.6
82− , hashable >=1.2.7.0 && <1.4
83− , http-media >=0.7.1.2 && <0.9
84− , insert-ordered-containers >=0.2.3 && <0.3
85− , lens >=4.16.1 && <4.19
86− , network >=2.6.3.5 && <3.2
87− , optics-core >=0.2 && <0.3
88− , optics-th >=0.2 && <0.3
89− , scientific >=0.3.6.2 && <0.4
90− , transformers-compat >=0.3 && <0.7
91− , unordered-containers >=0.2.9.0 && <0.3
92− , uuid-types >=1.0.3 && <1.1
93− , vector >=0.12.0.1 && <0.13
94− , QuickCheck >=2.10.1 && <2.14
95−
29+ Data.Swagger.Schema.Internal
30+ build-depends: base == 4.*
31+ , aeson
32+ , containers
33+ , hashable
34+ , http-media
35+ , network
36+ , template-haskell
37+ , text
38+ , unordered-containers
39+ , lens
9640 default-language: Haskell2010
9741
9842test-suite spec
9943 type: exitcode-stdio-1.0
10044 hs-source-dirs: test
10145 main-is: Spec.hs
102−
103− -- From library parat
104− -- We need aeson's toEncoding for doctests too
105− build-depends:
106− base
107− , swagger2
108− , aeson
109− , base-compat-batteries
110− , bytestring
111− , containers
112− , hashable
113− , insert-ordered-containers
114− , lens
115− , mtl
116− , template-haskell
117− , text
118− , time
119− , unordered-containers
120− , vector
121− , QuickCheck
122−
123− -- test-suite only dependencies
124− build-depends:
125− hspec >=2.5.5 && <2.8
126− , HUnit >=1.6.0.0 && <1.7
127− , quickcheck-instances >=0.3.19 && <0.14
128− , utf8-string >=1.0.1.1 && <1.1
129−
130− -- https://github.com/haskell/cabal/issues/3708
131− build-tool-depends:
132− hspec-discover:hspec-discover >=2.5.5 && <2.8
133−
46+ build-depends: base == 4.*
47+ , swagger2
48+ , hspec
49+ , HUnit
50+ , QuickCheck
51+ , text
52+ , aeson
53+ , aeson-qq
54+ , unordered-containers
55+ , vector
13456 other-modules:
13557 SpecCommon
13658 Data.SwaggerSpec
137− Data.Swagger.CommonTestTypes
138− Data.Swagger.ParamSchemaSpec
13959 Data.Swagger.SchemaSpec
140− Data.Swagger.Schema.ValidationSpec
141− Data.Swagger.Schema.GeneratorSpec
14260 default-language: Haskell2010
14361
144−test-suite doctests
145− -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes
146− build-depends: base, doctest, Glob, QuickCheck
147− default-language: Haskell2010
148− hs-source-dirs: test
149− main-is: doctests.hs
150− type: exitcode-stdio-1.0
151−
15262source-repository head
15363 type: git
15464 location: https://github.com/GetShopTV/swagger2.git
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.hsdeleted−40
@@ -1,40 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE QuasiQuotes #-}
6−{-# LANGUAGE OverloadedStrings #-}
7−module Data.Swagger.ParamSchemaSpec where
8−
9−import Data.Aeson
10−import Data.Aeson.QQ.Simple
11−import Data.Char
12−import Data.Proxy
13−import GHC.Generics
14−
15−import Data.Swagger
16−import Data.Swagger.Internal (SwaggerKind(..))
17−
18−import Data.Swagger.CommonTestTypes
19−import SpecCommon
20−import Test.Hspec
21−import Data.Time.LocalTime
22−
23−import qualified Data.HashMap.Strict as HM
24−
25−checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
26−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
27−
28−spec :: Spec
29−spec = do
30− describe "Generic ToParamSchema" $ do
31− context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON
32− context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON
33− context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON
34− context "Unary records" $ do
35− context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
36− context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
38−
39−main :: IO ()
40−main = hspec spec
test/Data/Swagger/Schema/GeneratorSpec.hsdeleted−168
@@ -1,168 +0,0 @@
1−{-# LANGUAGE OverloadedLists #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE PackageImports #-}
4−module Data.Swagger.Schema.GeneratorSpec where
5−
6−import Prelude ()
7−import Prelude.Compat
8−
9−import Data.Swagger
10−import Data.Swagger.Schema.Generator
11−
12−import Control.Lens.Operators
13−import Data.Aeson
14−import Data.Hashable (Hashable)
15−import Data.HashMap.Strict (HashMap)
16−import qualified Data.HashMap.Strict as HashMap
17−import "unordered-containers" Data.HashSet (HashSet)
18−import qualified "unordered-containers" Data.HashSet as HashSet
19−import Data.Int
20−import Data.IntMap (IntMap)
21−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
22−import Data.Map (Map, fromList)
23−import Data.Monoid (mempty)
24−import Data.Proxy
25−import Data.Proxy
26−import Data.Set (Set)
27−import qualified Data.Text as T
28−import qualified Data.Text.Lazy as TL
29−import Data.Time
30−import Data.Version (Version)
31−import Data.Word
32−import GHC.Generics
33−
34−import Test.Hspec
35−import Test.Hspec.QuickCheck
36−import Test.QuickCheck
37−
38−shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
39−shouldValidate = validateFromJSON
40−
41−
42−shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
43−shouldNotValidate = expectFailure . shouldValidate
44−
45−
46−spec :: Spec
47−spec = do
48− describe "FromJSON validation" $ do
49− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
50− prop "Char" $ shouldValidate (Proxy :: Proxy Char)
51− prop "Double" $ shouldValidate (Proxy :: Proxy Double)
52− prop "Float" $ shouldValidate (Proxy :: Proxy Float)
53− prop "Int" $ shouldValidate (Proxy :: Proxy Int)
54− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
55− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
56− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
57− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
58− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
59− prop "Word" $ shouldValidate (Proxy :: Proxy Word)
60− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
61− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
62− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
63− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
64− prop "String" $ shouldValidate (Proxy :: Proxy String)
65− prop "()" $ shouldValidate (Proxy :: Proxy ())
66−-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
67−-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
68− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
69− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
70− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
71− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
72− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
73− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
74− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
75− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
76− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
77− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
78− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
79− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
80− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
81− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
82− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
83− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
84− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
85− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
86− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
87− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
88− describe "Invalid FromJSON validation" $ do
89− prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)
90− prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)
91− prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)
92− prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)
93−
94−-- =============================
95−-- Data types and bunk instances
96−-- =============================
97−
98−data WrongType = WrongType Bool
99−
100−instance FromJSON WrongType where
101− parseJSON = withBool "WrongType" $ return . WrongType
102−
103−instance ToSchema WrongType where
104− declareNamedSchema _ = return . NamedSchema (Just "WrongType") $
105− mempty
106− & type_ ?~ SwaggerObject
107−
108−
109−data MissingRequired = MissingRequired
110− { propA :: String
111− , propB :: Bool
112− }
113−
114−instance FromJSON MissingRequired where
115− parseJSON = withObject "MissingRequired" $ \o ->
116− MissingRequired
117− <$> o .: "propA"
118− <*> o .: "propB"
119−
120−instance ToSchema MissingRequired where
121− declareNamedSchema _ = do
122− stringSchema <- declareSchemaRef (Proxy :: Proxy String)
123− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
124− return . NamedSchema (Just "MissingRequired") $
125− mempty
126− & type_ ?~ SwaggerObject
127− & properties .~ [("propA", stringSchema)
128− ,("propB", boolSchema)
129− ]
130− & required .~ ["propA"]
131−
132−data MissingProperty = MissingProperty
133− { propC :: String
134− , propD :: Bool
135− }
136−
137−instance FromJSON MissingProperty where
138− parseJSON = withObject "MissingProperty" $ \o ->
139− MissingProperty
140− <$> o .: "propC"
141− <*> o .: "propD"
142−
143−instance ToSchema MissingProperty where
144− declareNamedSchema _ = do
145− stringSchema <- declareSchemaRef (Proxy :: Proxy String)
146− return . NamedSchema (Just "MissingProperty") $
147− mempty
148− & type_ ?~ SwaggerObject
149− & properties .~ [("propC", stringSchema)]
150− & required .~ ["propC"]
151−
152−data WrongPropType = WrongPropType
153− { propE :: String
154− }
155−
156−instance FromJSON WrongPropType where
157− parseJSON = withObject "WrongPropType" $ \o ->
158− WrongPropType
159− <$> o .: "propE"
160−
161−instance ToSchema WrongPropType where
162− declareNamedSchema _ = do
163− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
164− return . NamedSchema (Just "WrongPropType") $
165− mempty
166− & type_ ?~ SwaggerObject
167− & properties .~ [("propE", boolSchema)]
168− & required .~ ["propE"]
test/Data/Swagger/Schema/ValidationSpec.hsdeleted−278
@@ -1,278 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE PackageImports #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# OPTIONS_GHC -fno-warn-orphans #-}
7−module Data.Swagger.Schema.ValidationSpec where
8−
9−import Control.Applicative
10−import Control.Lens ((&), (.~), (?~))
11−import Data.Aeson
12−import Data.Aeson.Types
13−import Data.Hashable (Hashable)
14−import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashMap.Strict as HashMap
16−import "unordered-containers" Data.HashSet (HashSet)
17−import qualified "unordered-containers" Data.HashSet as HashSet
18−import Data.Int
19−import Data.IntMap (IntMap)
20−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
21−import Data.Map (Map, fromList)
22−import Data.Monoid (mempty)
23−import Data.Proxy
24−import Data.Set (Set)
25−import qualified Data.Text as T
26−import qualified Data.Text.Lazy as TL
27−import Data.Time
28−import Data.Version (Version)
29−import Data.Word
30−import GHC.Generics
31−
32−import Data.Swagger
33−import Data.Swagger.Declare
34−
35−import Test.Hspec
36−import Test.Hspec.QuickCheck
37−import Test.QuickCheck
38−import Test.QuickCheck.Instances ()
39−
40−shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
41−shouldValidate _ x = validateToJSON x == []
42−
43−shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool
44−shouldNotValidate f = not . null . validateJSON defs sch . f
45− where
46− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
47−
48−spec :: Spec
49−spec = do
50− describe "Validation" $ do
51− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
52− prop "Char" $ shouldValidate (Proxy :: Proxy Char)
53− prop "Double" $ shouldValidate (Proxy :: Proxy Double)
54− prop "Float" $ shouldValidate (Proxy :: Proxy Float)
55− prop "Int" $ shouldValidate (Proxy :: Proxy Int)
56− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
57− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
58− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
59− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
60− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
61− prop "Word" $ shouldValidate (Proxy :: Proxy Word)
62− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
63− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
64− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
65− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
66− prop "String" $ shouldValidate (Proxy :: Proxy String)
67− prop "()" $ shouldValidate (Proxy :: Proxy ())
68− prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
69− prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
70− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
71− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
72− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
73− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
74− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
75− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
76− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
77− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
78− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
79− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
80− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
81− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
82− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
83− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
84− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
85− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
86− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
87− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
88− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
89− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
90− prop "Person" $ shouldValidate (Proxy :: Proxy Person)
91− prop "Color" $ shouldValidate (Proxy :: Proxy Color)
92− prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
93− prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
94− prop "Light" $ shouldValidate (Proxy :: Proxy Light)
95− prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)
96− prop "Version" $ shouldValidate (Proxy :: Proxy Version)
97− prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)
98−
99− describe "invalid cases" $ do
100− prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON
101− prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON
102− prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON
103− prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON
104− prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON
105−
106−main :: IO ()
107−main = hspec spec
108−
109−-- ========================================================================
110−-- Person (simple record with optional fields)
111−-- ========================================================================
112−data Person = Person
113− { name :: String
114− , phone :: Integer
115− , email :: Maybe String
116− } deriving (Show, Generic)
117−
118−instance ToJSON Person
119−instance ToSchema Person
120−
121−instance Arbitrary Person where
122− arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
123−
124−invalidPersonToJSON :: Person -> Value
125−invalidPersonToJSON Person{..} = object
126− [ T.pack "personName" .= toJSON name
127− , T.pack "personPhone" .= toJSON phone
128− , T.pack "personEmail" .= toJSON email
129− ]
130−
131−-- ========================================================================
132−-- Color (enum)
133−-- ========================================================================
134−data Color = Red | Green | Blue deriving (Show, Generic, Bounded, Enum)
135−
136−instance ToJSON Color
137−instance ToSchema Color
138−
139−instance Arbitrary Color where
140− arbitrary = arbitraryBoundedEnum
141−
142−invalidColorToJSON :: Color -> Value
143−invalidColorToJSON Red = toJSON "red"
144−invalidColorToJSON Green = toJSON "green"
145−invalidColorToJSON Blue = toJSON "blue"
146−
147−-- ========================================================================
148−-- Paint (record with bounded enum property)
149−-- ========================================================================
150−
151−newtype Paint = Paint { color :: Color }
152− deriving (Show, Generic)
153−
154−instance ToJSON Paint
155−instance ToSchema Paint
156−
157−instance Arbitrary Paint where
158− arbitrary = Paint <$> arbitrary
159−
160−invalidPaintToJSON :: Paint -> Value
161−invalidPaintToJSON = toJSON . color
162−
163−-- ========================================================================
164−-- MyRoseTree (custom datatypeNameModifier)
165−-- ========================================================================
166−
167−data MyRoseTree = MyRoseTree
168− { root :: String
169− , trees :: [MyRoseTree]
170− } deriving (Show, Generic)
171−
172−instance ToJSON MyRoseTree
173−
174−instance ToSchema MyRoseTree where
175− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
176− { datatypeNameModifier = drop (length "My") }
177−
178−instance Arbitrary MyRoseTree where
179− arbitrary = fmap (cut limit) $ MyRoseTree <$> arbitrary <*> (take limit <$> arbitrary)
180− where
181− limit = 4
182− cut 0 (MyRoseTree x _ ) = MyRoseTree x []
183− cut n (MyRoseTree x xs) = MyRoseTree x (map (cut (n - 1)) xs)
184−
185−-- ========================================================================
186−-- Light (sum type)
187−-- ========================================================================
188−
189−data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
190−
191−instance ToSchema Light where
192− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
193−
194−instance ToJSON Light where
195− toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
196−
197−instance Arbitrary Light where
198− arbitrary = oneof
199− [ return NoLight
200− , LightFreq <$> arbitrary
201− , LightColor <$> arbitrary
202− ]
203−
204−invalidLightToJSON :: Light -> Value
205−invalidLightToJSON = genericToJSON defaultOptions
206−
207−-- ========================================================================
208−-- ButtonImages (bounded enum key mapping)
209−-- ========================================================================
210−
211−data ButtonState = Neutral | Focus | Active | Hover | Disabled
212− deriving (Show, Eq, Ord, Bounded, Enum, Generic)
213−
214−instance ToJSON ButtonState
215−instance ToSchema ButtonState
216−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
217−
218−instance Arbitrary ButtonState where
219− arbitrary = arbitraryBoundedEnum
220−
221−type ImageUrl = T.Text
222−
223−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
224− deriving (Show, Generic)
225−
226−instance ToJSON ButtonImages where
227− toJSON = toJSON . getButtonImages
228−
229−instance ToSchema ButtonImages where
230− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
231− declareSchemaBoundedEnumKeyMapping
232−
233−invalidButtonImagesToJSON :: ButtonImages -> Value
234−invalidButtonImagesToJSON = genericToJSON defaultOptions
235−
236−instance Arbitrary ButtonImages where
237− arbitrary = ButtonImages <$> arbitrary
238−
239−-- ========================================================================
240−-- FreeForm (wraps a raw JSON Value)
241−-- ========================================================================
242−
243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
244− deriving (Show, Generic)
245−
246−instance ToJSON FreeForm where
247− toJSON = toJSON . jsonContent
248−
249−instance ToSchema FreeForm where
250− declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
251− & type_ ?~ SwaggerObject
252− & additionalProperties ?~ AdditionalPropertiesAllowed True
253−
254−instance Arbitrary FreeForm where
255− arbitrary = (FreeForm . fromList) <$> genObj
256− where
257− genObj = listOf $ do
258− k <- arbitrary
259− v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]
260− pure (k, v)
261−
262−instance Eq ZonedTime where
263− ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
264−
265−-- ========================================================================
266−-- Arbitrary instance for Data.Aeson.Value
267−-- ========================================================================
268−
269−instance Arbitrary Value where
270− -- Weights are almost random
271− -- Uniform oneof tends not to build complex objects cause of recursive call.
272− arbitrary = resize 4 $ frequency
273− [ (3, Object <$> arbitrary)
274− , (3, Array <$> arbitrary)
275− , (3, String <$> arbitrary)
276− , (3, Number <$> arbitrary)
277− , (3, Bool <$> arbitrary)
278− , (1, return Null) ]
test/Data/Swagger/SchemaSpec.hs+154−81
@@ -1,114 +1,187 @@
11{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE DeriveAnyClass #-}
33{-# LANGUAGE TemplateHaskell #-}
44{-# LANGUAGE QuasiQuotes #-}
55module Data.Swagger.SchemaSpec where
66
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens ((^.))
11−import Data.Aeson (Value)
12−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
7+import Data.Aeson
8+import Data.Aeson.QQ
9+import Data.Char
1310import Data.Proxy
14−import Data.Set (Set)
15−import qualified Data.Text as Text
11+import GHC.Generics
1612
1713import Data.Swagger
18−import Data.Swagger.Declare
14+import Data.Swagger.Schema
1915
20−import Data.Swagger.CommonTestTypes
2116import SpecCommon
2217import Test.Hspec
2318
24−import qualified Data.HashMap.Strict as HM
25−import Data.Time.LocalTime
26−
2719checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
28−checkToSchema proxy js = toSchema proxy <=> js
20+checkToSchema proxy js = toSchema proxy <~> js
2921
3022checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec
31−checkSchemaName sname proxy =
32− it ("schema name is " ++ show sname) $
33− schemaName proxy `shouldBe` fmap Text.pack sname
34−
35−checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
36−checkDefs proxy names =
37− it ("uses these definitions " ++ show names) $
38− InsOrdHashMap.keys defs `shouldBe` map Text.pack names
39− where
40− defs = execDeclare (declareNamedSchema proxy) mempty
41−
42−checkProperties :: ToSchema a => Proxy a -> [String] -> Spec
43−checkProperties proxy names =
44− it ("has these fields in order " ++ show names) $
45− InsOrdHashMap.keys fields `shouldBe` map Text.pack names
46− where
47− fields = toSchema proxy ^. properties
48−
49−checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
50−checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
51−
52−checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec
53−checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js
54− where
55− (defs, s) = runDeclare (declareSchema proxy) mempty
56−
57−checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec
58−checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js
59− where
60− (defs, s) = runDeclare (declareSchema proxy) mempty
23+checkSchemaName name proxy =
24+ it ("schema name is " ++ show name) $
25+ schemaName proxy `shouldBe` name
6126
6227spec :: Spec
6328spec = do
6429 describe "Generic ToSchema" $ do
65− context "Unit" $ checkToSchema (Proxy :: Proxy Unit) unitSchemaJSON
6630 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
6731 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
6832 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
73− context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
74− context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
75− context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON
7633 context "Unary records" $ do
7734 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
7835 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
7936 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
82− context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
84− context "Sum types" $ do
85− context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
86− context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
87− context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON
8837 context "Schema name" $ do
8938 context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)
9039 context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
9140 context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
92− context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
93− describe "Generic Definitions" $ do
94− context "Unit" $ checkDefs (Proxy :: Proxy Unit) []
95− context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]
96− context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
97− context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
98− 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"]
101− context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
102− describe "Inlining Schemas" $ do
103− context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON
104− context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON
105− context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
106− context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
107− 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
41+ describe "toSchemaBoundedEnum" $ do
42+ context "Color" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
11243
11344main :: IO ()
11445main = hspec spec
46+
47+-- ========================================================================
48+-- Person (simple record with optional fields)
49+-- ========================================================================
50+data Person = Person
51+ { name :: String
52+ , phone :: Integer
53+ , email :: Maybe String
54+ } deriving (Generic, ToSchema)
55+
56+personSchemaJSON :: Value
57+personSchemaJSON = [aesonQQ|
58+{
59+ "type": "object",
60+ "properties":
61+ {
62+ "name": { "type": "string" },
63+ "phone": { "type": "integer" },
64+ "email": { "type": "string" }
65+ },
66+ "required": ["name", "phone"]
67+}
68+|]
69+
70+-- ========================================================================
71+-- ISPair (non-record product data type)
72+-- ========================================================================
73+data ISPair = ISPair Integer String
74+ deriving (Generic, ToSchema)
75+
76+ispairSchemaJSON :: Value
77+ispairSchemaJSON = [aesonQQ|
78+{
79+ "type": "array",
80+ "items":
81+ [
82+ { "type": "integer" },
83+ { "type": "string" }
84+ ]
85+}
86+|]
87+
88+-- ========================================================================
89+-- Point (record data type with custom fieldLabelModifier)
90+-- ========================================================================
91+data Point = Point
92+ { pointX :: Double
93+ , pointY :: Double
94+ } deriving (Generic)
95+
96+instance ToSchema Point where
97+ toNamedSchema = genericToNamedSchema defaultSchemaOptions
98+ { fieldLabelModifier = map toLower . drop (length "point") }
99+
100+pointSchemaJSON :: Value
101+pointSchemaJSON = [aesonQQ|
102+{
103+ "type": "object",
104+ "properties":
105+ {
106+ "x": { "type": "number" },
107+ "y": { "type": "number" }
108+ },
109+ "required": ["x", "y"]
110+}
111+|]
112+
113+
114+-- ========================================================================
115+-- Point (record data type with custom fieldLabelModifier)
116+-- ========================================================================
117+data Color
118+ = Red
119+ | Green
120+ | Blue
121+ deriving (Generic, Enum, Bounded, ToJSON)
122+
123+instance ToSchema Color where
124+ toNamedSchema = genericToNamedSchemaBoundedEnum
125+
126+colorSchemaJSON :: Value
127+colorSchemaJSON = [aesonQQ|
128+{
129+ "type": "string",
130+ "enum": ["Red", "Green", "Blue"]
131+}
132+|]
133+
134+-- ========================================================================
135+-- Email (newtype with unwrapUnaryRecords set to True)
136+-- ========================================================================
137+
138+newtype Email = Email { getEmail :: String }
139+ deriving (Generic)
140+
141+instance ToSchema Email where
142+ toNamedSchema = genericToNamedSchema defaultSchemaOptions
143+ { unwrapUnaryRecords = True }
144+
145+emailSchemaJSON :: Value
146+emailSchemaJSON = [aesonQQ|
147+{
148+ "type": "string"
149+}
150+|]
151+
152+-- ========================================================================
153+-- UserId (non-record newtype)
154+-- ========================================================================
155+
156+newtype UserId = UserId Integer
157+ deriving (Generic, ToSchema)
158+
159+userIdSchemaJSON :: Value
160+userIdSchemaJSON = [aesonQQ|
161+{
162+ "type": "integer"
163+}
164+|]
165+
166+-- ========================================================================
167+-- Player (record newtype)
168+-- ========================================================================
169+
170+newtype Player = Player
171+ { position :: Point
172+ } deriving (Generic, ToSchema)
173+
174+playerSchemaJSON :: Value
175+playerSchemaJSON = [aesonQQ|
176+{
177+ "type": "object",
178+ "properties":
179+ {
180+ "position":
181+ {
182+ "$ref": "#/definitions/Point"
183+ }
184+ },
185+ "required": ["position"]
186+}
187+|]
test/Data/SwaggerSpec.hs+486−551
@@ -4,49 +4,37 @@
44{-# LANGUAGE QuasiQuotes #-}
55module Data.SwaggerSpec where
66
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens
11−
127import Data.Aeson
13−import Data.Aeson.QQ.Simple
8+import Data.Aeson.QQ
9+import qualified Data.Foldable as F
1410import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashSet.InsOrd as InsOrdHS
11+import qualified Data.HashMap.Strict as HashMap
12+import Data.Maybe
13+import Data.Monoid
14+import qualified Data.Vector as Vector
1615import Data.Text (Text)
1716
1817import Data.Swagger
1918import SpecCommon
20−import Test.Hspec hiding (example)
19+import Test.Hspec
2120
2221spec :: Spec
2322spec = 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
3223 describe "License Object" $ licenseExample <=> licenseExampleJSON
3324 describe "Contact Object" $ contactExample <=> contactExampleJSON
3425 describe "Info Object" $ infoExample <=> infoExampleJSON
35− describe "Operation Object" $ operationExample <=> operationExampleJSON
26+ describe "Operation Object" $ operationExample <~> operationExampleJSON
3627 describe "Schema Object" $ do
37− context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
38− context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
39− context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
40− context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON
41− context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
42− describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
43− describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
44− describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
45− describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON
47− describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
28+ context "Primitive Sample" $ schemaPrimitiveExample <~> schemaPrimitiveExampleJSON
29+ context "Simple Model" $ schemaSimpleModelExample <~> schemaSimpleModelExampleJSON
30+ context "Model with Map/Dictionary Properties" $ schemaModelDictExample <~> schemaModelDictExampleJSON
31+ context "Model with Example" $ schemaWithExampleExample <~> schemaWithExampleExampleJSON
32+ describe "Definitions Object" $ definitionsExample <~> definitionsExampleJSON
33+ describe "Parameters Definition Object" $ parametersDefinitionExample <~> parametersDefinitionExampleJSON
34+ describe "Responses Definition Object" $ responsesDefinitionExample <~> responsesDefinitionExampleJSON
35+ describe "Security Definitions Object" $ securityDefinitionsExample <~> securityDefinitionsExampleJSON
4836 describe "Swagger Object" $ do
49− context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
37+ context "Todo Example" $ swaggerExample <~> swaggerExampleJSON
5038 context "PetStore Example" $
5139 it "decodes successfully" $ do
5240 fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: Swagger) -> True; _ -> False)
@@ -59,13 +47,17 @@ main = hspec spec
5947-- =======================================================================
6048
6149infoExample :: Info
62−infoExample = mempty
63− & title .~ "Swagger Sample App"
64− & description ?~ "This is a sample server Petstore server."
65− & termsOfService ?~ "http://swagger.io/terms/"
66− & contact ?~ contactExample
67− & license ?~ licenseExample
68− & version .~ "1.0.1"
50+infoExample = Info
51+ { _infoTitle = "Swagger Sample App"
52+ , _infoDescription = Just "This is a sample server Petstore server."
53+ , _infoTermsOfService = Just "http://swagger.io/terms/"
54+ , _infoContact = Just contactExample
55+ , _infoLicense = Just licenseExample
56+ , _infoVersion = "1.0.1" }
57+ where
58+ license = License
59+ { _licenseName = "Apache 2.0"
60+ , _licenseUrl = Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html") }
6961
7062infoExampleJSON :: Value
7163infoExampleJSON = [aesonQQ|
@@ -91,10 +83,10 @@ infoExampleJSON = [aesonQQ|
9183-- =======================================================================
9284
9385contactExample :: Contact
94−contactExample = mempty
95− & name ?~ "API Support"
96− & url ?~ URL "http://www.swagger.io/support"
97− & email ?~ "support@swagger.io"
86+contactExample = Contact
87+ { _contactName = Just "API Support"
88+ , _contactUrl = Just (URL "http://www.swagger.io/support")
89+ , _contactEmail = Just "support@swagger.io" }
9890
9991contactExampleJSON :: Value
10092contactExampleJSON = [aesonQQ|
@@ -110,8 +102,9 @@ contactExampleJSON = [aesonQQ|
110102-- =======================================================================
111103
112104licenseExample :: License
113−licenseExample = "Apache 2.0"
114− & url ?~ URL "http://www.apache.org/licenses/LICENSE-2.0.html"
105+licenseExample = License
106+ { _licenseName = "Apache 2.0"
107+ , _licenseUrl = Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html") }
115108
116109licenseExampleJSON :: Value
117110licenseExampleJSON = [aesonQQ|
@@ -128,38 +121,46 @@ licenseExampleJSON = [aesonQQ|
128121
129122operationExample :: Operation
130123operationExample = mempty
131− & tags .~ InsOrdHS.fromList ["pet"]
132− & summary ?~ "Updates a pet in the store with form data"
133− & description ?~ ""
134− & operationId ?~ "updatePetWithForm"
135− & consumes ?~ MimeList ["application/x-www-form-urlencoded"]
136− & produces ?~ MimeList ["application/json", "application/xml"]
137− & parameters .~ map Inline
138− [ mempty
139− & name .~ "petId"
140− & description ?~ "ID of pet that needs to be updated"
141− & required ?~ True
142− & schema .~ ParamOther (stringSchema ParamPath)
143− , mempty
144− & name .~ "name"
145− & description ?~ "Updated name of the pet"
146− & required ?~ False
147− & schema .~ ParamOther (stringSchema ParamFormData)
148− , mempty
149− & name .~ "status"
150− & description ?~ "Updated status of the pet"
151− & required ?~ False
152− & schema .~ ParamOther (stringSchema ParamFormData)
124+ { _operationTags = ["pet"]
125+ , _operationSummary = Just "Updates a pet in the store with form data"
126+ , _operationDescription = Just ""
127+ , _operationOperationId = Just "updatePetWithForm"
128+ , _operationConsumes = Just (MimeList ["application/x-www-form-urlencoded"])
129+ , _operationProduces = Just (MimeList ["application/json", "application/xml"])
130+ , _operationParameters = params
131+ , _operationResponses = responses
132+ , _operationSecurity = security
133+ }
134+ where
135+ security = [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]
136+
137+ responses = mempty
138+ { _responsesResponses =
139+ [ (200, Inline mempty { _responseDescription = "Pet updated." })
140+ , (405, Inline mempty { _responseDescription = "Invalid input" }) ] }
141+
142+ params = map Inline
143+ [ Parameter
144+ { _parameterName = "petId"
145+ , _parameterDescription = Just "ID of pet that needs to be updated"
146+ , _parameterRequired = Just True
147+ , _parameterSchema = ParameterOther (stringSchema ParameterPath) }
148+ , Parameter
149+ { _parameterName = "name"
150+ , _parameterDescription = Just "Updated name of the pet"
151+ , _parameterRequired = Just False
152+ , _parameterSchema = ParameterOther (stringSchema ParameterFormData) }
153+ , Parameter
154+ { _parameterName = "status"
155+ , _parameterDescription = Just "Updated status of the pet"
156+ , _parameterRequired = Just False
157+ , _parameterSchema = ParameterOther (stringSchema ParameterFormData) }
153158 ]
154159
155− & at 200 ?~ "Pet updated."
156− & at 405 ?~ "Invalid input"
157− & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]
158− where
159− stringSchema :: ParamLocation -> ParamOtherSchema
160− stringSchema loc = mempty
161− & in_ .~ loc
162− & type_ ?~ SwaggerString
160+ stringSchema i = mempty
161+ { _parameterOtherSchemaIn = i
162+ , _parameterOtherSchemaType = ParamString
163+ }
163164
164165operationExampleJSON :: Value
165166operationExampleJSON = [aesonQQ|
@@ -225,8 +226,9 @@ operationExampleJSON = [aesonQQ|
225226
226227schemaPrimitiveExample :: Schema
227228schemaPrimitiveExample = mempty
228− & type_ ?~ SwaggerString
229− & format ?~ "email"
229+ { _schemaType = SchemaString
230+ , _schemaFormat = Just "email"
231+ }
230232
231233schemaPrimitiveExampleJSON :: Value
232234schemaPrimitiveExampleJSON = [aesonQQ|
@@ -238,15 +240,17 @@ schemaPrimitiveExampleJSON = [aesonQQ|
238240
239241schemaSimpleModelExample :: Schema
240242schemaSimpleModelExample = mempty
241− & type_ ?~ SwaggerObject
242− & required .~ [ "name" ]
243− & properties .~
244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))
245− , ("address", Ref (Reference "Address"))
246− , ("age", Inline $ mempty
247− & minimum_ ?~ 0
248− & type_ ?~ SwaggerInteger
249− & format ?~ "int32" ) ]
243+ { _schemaType = SchemaObject
244+ , _schemaRequired = [ "name" ]
245+ , _schemaProperties =
246+ [ ("name", Inline mempty
247+ { _schemaType = SchemaString } )
248+ , ("address", Ref (Reference "#/definitions/Address"))
249+ , ("age", Inline mempty
250+ { _schemaType = SchemaInteger
251+ , _schemaFormat = Just "int32"
252+ , _schemaSchemaCommon = mempty
253+ { _schemaCommonMinimum = Just 0 } } ) ] }
250254
251255schemaSimpleModelExampleJSON :: Value
252256schemaSimpleModelExampleJSON = [aesonQQ|
@@ -273,8 +277,9 @@ schemaSimpleModelExampleJSON = [aesonQQ|
273277
274278schemaModelDictExample :: Schema
275279schemaModelDictExample = mempty
276− & type_ ?~ SwaggerObject
277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
280+ { _schemaType = SchemaObject
281+ , _schemaAdditionalProperties = Just mempty
282+ { _schemaType = SchemaString } }
278283
279284schemaModelDictExampleJSON :: Value
280285schemaModelDictExampleJSON = [aesonQQ|
@@ -286,35 +291,22 @@ schemaModelDictExampleJSON = [aesonQQ|
286291}
287292|]
288293
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−
302294schemaWithExampleExample :: Schema
303295schemaWithExampleExample = mempty
304− & type_ ?~ SwaggerObject
305− & properties .~
306− [ ("id", Inline $ mempty
307− & type_ ?~ SwaggerInteger
308− & format ?~ "int64" )
309− , ("name", Inline $ mempty
310− & type_ ?~ SwaggerString) ]
311− & required .~ [ "name" ]
312− & example ?~ [aesonQQ|
313− {
314− "name": "Puma",
315− "id": 1
316− }
317− |]
296+ { _schemaType = SchemaObject
297+ , _schemaProperties =
298+ [ ("id", Inline mempty
299+ { _schemaType = SchemaInteger
300+ , _schemaFormat = Just "int64" })
301+ , ("name", Inline mempty
302+ { _schemaType = SchemaString }) ]
303+ , _schemaRequired = [ "name" ]
304+ , _schemaExample = Just [aesonQQ|
305+ {
306+ "name": "Puma",
307+ "id": 1
308+ }
309+ |] }
318310
319311schemaWithExampleExampleJSON :: Value
320312schemaWithExampleExampleJSON = [aesonQQ|
@@ -346,19 +338,21 @@ schemaWithExampleExampleJSON = [aesonQQ|
346338definitionsExample :: HashMap Text Schema
347339definitionsExample =
348340 [ ("Category", mempty
349− & type_ ?~ SwaggerObject
350− & properties .~
351− [ ("id", Inline $ mempty
352− & type_ ?~ SwaggerInteger
353− & format ?~ "int64")
354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
341+ { _schemaType = SchemaObject
342+ , _schemaProperties =
343+ [ ("id", Inline mempty
344+ { _schemaType = SchemaInteger
345+ , _schemaFormat = Just "int64" })
346+ , ("name", Inline mempty
347+ { _schemaType = SchemaString }) ] })
355348 , ("Tag", mempty
356− & type_ ?~ SwaggerObject
357− & properties .~
358− [ ("id", Inline $ mempty
359− & type_ ?~ SwaggerInteger
360− & format ?~ "int64")
361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
349+ { _schemaType = SchemaObject
350+ , _schemaProperties =
351+ [ ("id", Inline mempty
352+ { _schemaType = SchemaInteger
353+ , _schemaFormat = Just "int64" })
354+ , ("name", Inline mempty
355+ { _schemaType = SchemaString }) ] }) ]
362356
363357definitionsExampleJSON :: Value
364358definitionsExampleJSON = [aesonQQ|
@@ -394,27 +388,27 @@ definitionsExampleJSON = [aesonQQ|
394388-- Parameters Definition object
395389-- =======================================================================
396390
397−paramsDefinitionExample :: HashMap Text Param
398−paramsDefinitionExample =
391+parametersDefinitionExample :: HashMap Text Parameter
392+parametersDefinitionExample =
399393 [ ("skipParam", mempty
400− & name .~ "skip"
401− & description ?~ "number of items to skip"
402− & required ?~ True
403− & schema .~ ParamOther (mempty
404− & in_ .~ ParamQuery
405− & type_ ?~ SwaggerInteger
406− & format ?~ "int32" ))
394+ { _parameterName = "skip"
395+ , _parameterDescription = Just "number of items to skip"
396+ , _parameterRequired = Just True
397+ , _parameterSchema = ParameterOther mempty
398+ { _parameterOtherSchemaIn = ParameterQuery
399+ , _parameterOtherSchemaType = ParamInteger
400+ , _parameterOtherSchemaFormat = Just "int32" } })
407401 , ("limitParam", mempty
408− & name .~ "limit"
409− & description ?~ "max records to return"
410− & required ?~ True
411− & schema .~ ParamOther (mempty
412− & in_ .~ ParamQuery
413− & type_ ?~ SwaggerInteger
414− & format ?~ "int32" )) ]
402+ { _parameterName = "limit"
403+ , _parameterDescription = Just "max records to return"
404+ , _parameterRequired = Just True
405+ , _parameterSchema = ParameterOther mempty
406+ { _parameterOtherSchemaIn = ParameterQuery
407+ , _parameterOtherSchemaType = ParamInteger
408+ , _parameterOtherSchemaFormat = Just "int32" } }) ]
415409
416−paramsDefinitionExampleJSON :: Value
417−paramsDefinitionExampleJSON = [aesonQQ|
410+parametersDefinitionExampleJSON :: Value
411+parametersDefinitionExampleJSON = [aesonQQ|
418412{
419413 "skipParam": {
420414 "name": "skip",
@@ -441,8 +435,8 @@ paramsDefinitionExampleJSON = [aesonQQ|
441435
442436responsesDefinitionExample :: HashMap Text Response
443437responsesDefinitionExample =
444− [ ("NotFound", mempty & description .~ "Entity not found.")
445− , ("IllegalInput", mempty & description .~ "Illegal input for operation.") ]
438+ [ ("NotFound", mempty { _responseDescription = "Entity not found." })
439+ , ("IllegalInput", mempty { _responseDescription = "Illegal input for operation." }) ]
446440
447441responsesDefinitionExampleJSON :: Value
448442responsesDefinitionExampleJSON = [aesonQQ|
@@ -460,8 +454,8 @@ responsesDefinitionExampleJSON = [aesonQQ|
460454-- Responses Definition object
461455-- =======================================================================
462456
463−securityDefinitionsExample :: SecurityDefinitions
464−securityDefinitionsExample = SecurityDefinitions
457+securityDefinitionsExample :: HashMap Text SecurityScheme
458+securityDefinitionsExample =
465459 [ ("api_key", SecurityScheme
466460 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
467461 , _securitySchemeDescription = Nothing })
@@ -493,86 +487,53 @@ securityDefinitionsExampleJSON = [aesonQQ|
493487}
494488|]
495489
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−
536490-- =======================================================================
537491-- Swagger object
538492-- =======================================================================
539493
540494swaggerExample :: Swagger
541495swaggerExample = mempty
542− & basePath ?~ "/"
543− & schemes ?~ [Http]
544− & info .~ (mempty
545− & version .~ "1.0"
546− & title .~ "Todo API"
547− & license ?~ "MIT"
548− & license._Just.url ?~ URL "http://mit.com"
549− & description ?~ "This is a an API that tests servant-swagger support for a Todo API")
550− & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation)
551− & at 200 ?~ Inline (mempty
552− & description .~ "OK"
553− & schema ?~ Inline (mempty
554− & type_ ?~ SwaggerObject
555− & example ?~ [aesonQQ|
556− {
557− "created": 100,
558− "description": "get milk"
559− } |]
560− & description ?~ "This is some real Todo right here"
561− & properties .~
562− [ ("created", Inline $ mempty
563− & type_ ?~ SwaggerInteger
564− & format ?~ "int32")
565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))
566− & produces ?~ MimeList [ "application/json" ]
567− & parameters .~
568− [ Inline $ mempty
569− & required ?~ True
570− & name .~ "id"
571− & description ?~ "TodoId param"
572− & schema .~ ParamOther (mempty
573− & in_ .~ ParamPath
574− & type_ ?~ SwaggerString ) ]
575− & tags .~ InsOrdHS.fromList [ "todo" ] ))
496+ { _basePath = Just "/"
497+ , _schemes = Just [Http]
498+ , _info = mempty
499+ { _infoVersion = "1.0"
500+ , _infoTitle = "Todo API"
501+ , _infoLicense = Just License
502+ { _licenseName = "MIT"
503+ , _licenseUrl = Just (URL "http://mit.com") }
504+ , _infoDescription = Just "This is a an API that tests servant-swagger support for a Todo API" }
505+ , _paths = mempty
506+ { _pathsMap =
507+ [ ("/todo/{id}", mempty
508+ { _pathItemGet = Just mempty
509+ { _operationResponses = mempty
510+ { _responsesResponses =
511+ [ (200, Inline mempty
512+ { _responseSchema = Just $ Inline mempty
513+ { _schemaExample = Just [aesonQQ|
514+ {
515+ "created": 100,
516+ "description": "get milk"
517+ } |]
518+ , _schemaType = SchemaObject
519+ , _schemaDescription = Just "This is some real Todo right here"
520+ , _schemaProperties =
521+ [ ("created", Inline mempty
522+ { _schemaType = SchemaInteger
523+ , _schemaFormat = Just "int32" })
524+ , ("description", Inline mempty
525+ { _schemaType = SchemaString }) ] }
526+ , _responseDescription = "OK" }) ] }
527+ , _operationProduces = Just (MimeList [ "application/json" ])
528+ , _operationParameters =
529+ [ Inline mempty
530+ { _parameterRequired = Just True
531+ , _parameterName = "id"
532+ , _parameterDescription = Just "TodoId param"
533+ , _parameterSchema = ParameterOther mempty
534+ { _parameterOtherSchemaIn = ParameterPath
535+ , _parameterOtherSchemaType = ParamString } } ]
536+ , _operationTags = [ "todo" ] } }) ] } }
576537
577538swaggerExampleJSON :: Value
578539swaggerExampleJSON = [aesonQQ|
@@ -639,130 +600,130 @@ swaggerExampleJSON = [aesonQQ|
639600
640601petstoreExampleJSON :: Value
641602petstoreExampleJSON = [aesonQQ|
642−{
603+{
643604 "swagger":"2.0",
644− "info":{
605+ "info":{
645606 "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.",
646607 "version":"1.0.0",
647608 "title":"Swagger Petstore",
648609 "termsOfService":"http://swagger.io/terms/",
649− "contact":{
610+ "contact":{
650611 "email":"apiteam@swagger.io"
651612 },
652− "license":{
613+ "license":{
653614 "name":"Apache 2.0",
654615 "url":"http://www.apache.org/licenses/LICENSE-2.0.html"
655616 }
656617 },
657618 "host":"petstore.swagger.io",
658619 "basePath":"/v2",
659− "tags":[
660− {
620+ "tags":[
621+ {
661622 "name":"pet",
662623 "description":"Everything about your Pets",
663− "externalDocs":{
624+ "externalDocs":{
664625 "description":"Find out more",
665626 "url":"http://swagger.io"
666627 }
667628 },
668− {
629+ {
669630 "name":"store",
670631 "description":"Access to Petstore orders"
671632 },
672− {
633+ {
673634 "name":"user",
674635 "description":"Operations about user",
675− "externalDocs":{
636+ "externalDocs":{
676637 "description":"Find out more about our store",
677638 "url":"http://swagger.io"
678639 }
679640 }
680641 ],
681− "schemes":[
642+ "schemes":[
682643 "http"
683644 ],
684− "paths":{
685− "/pet":{
686− "post":{
687− "tags":[
645+ "paths":{
646+ "/pet":{
647+ "post":{
648+ "tags":[
688649 "pet"
689650 ],
690651 "summary":"Add a new pet to the store",
691652 "description":"",
692653 "operationId":"addPet",
693− "consumes":[
654+ "consumes":[
694655 "application/json",
695656 "application/xml"
696657 ],
697− "produces":[
658+ "produces":[
698659 "application/xml",
699660 "application/json"
700661 ],
701− "parameters":[
702− {
662+ "parameters":[
663+ {
703664 "in":"body",
704665 "name":"body",
705666 "description":"Pet object that needs to be added to the store",
706667 "required":true,
707− "schema":{
668+ "schema":{
708669 "$ref":"#/definitions/Pet"
709670 }
710671 }
711672 ],
712− "responses":{
713− "405":{
673+ "responses":{
674+ "405":{
714675 "description":"Invalid input"
715676 }
716677 },
717− "security":[
718− {
719− "petstore_auth":[
678+ "security":[
679+ {
680+ "petstore_auth":[
720681 "write:pets",
721682 "read:pets"
722683 ]
723684 }
724685 ]
725686 },
726− "put":{
727− "tags":[
687+ "put":{
688+ "tags":[
728689 "pet"
729690 ],
730691 "summary":"Update an existing pet",
731692 "description":"",
732693 "operationId":"updatePet",
733− "consumes":[
694+ "consumes":[
734695 "application/json",
735696 "application/xml"
736697 ],
737− "produces":[
698+ "produces":[
738699 "application/xml",
739700 "application/json"
740701 ],
741− "parameters":[
742− {
702+ "parameters":[
703+ {
743704 "in":"body",
744705 "name":"body",
745706 "description":"Pet object that needs to be added to the store",
746707 "required":true,
747− "schema":{
708+ "schema":{
748709 "$ref":"#/definitions/Pet"
749710 }
750711 }
751712 ],
752− "responses":{
753− "400":{
713+ "responses":{
714+ "400":{
754715 "description":"Invalid ID supplied"
755716 },
756− "404":{
717+ "404":{
757718 "description":"Pet not found"
758719 },
759− "405":{
720+ "405":{
760721 "description":"Validation exception"
761722 }
762723 },
763− "security":[
764− {
765− "petstore_auth":[
724+ "security":[
725+ {
726+ "petstore_auth":[
766727 "write:pets",
767728 "read:pets"
768729 ]
@@ -770,28 +731,28 @@ petstoreExampleJSON = [aesonQQ|
770731 ]
771732 }
772733 },
773− "/pet/findByStatus":{
774− "get":{
775− "tags":[
734+ "/pet/findByStatus":{
735+ "get":{
736+ "tags":[
776737 "pet"
777738 ],
778739 "summary":"Finds Pets by status",
779740 "description":"Multiple status values can be provided with comma seperated strings",
780741 "operationId":"findPetsByStatus",
781− "produces":[
742+ "produces":[
782743 "application/xml",
783744 "application/json"
784745 ],
785− "parameters":[
786− {
746+ "parameters":[
747+ {
787748 "name":"status",
788749 "in":"query",
789750 "description":"Status values that need to be considered for filter",
790751 "required":true,
791752 "type":"array",
792− "items":{
753+ "items":{
793754 "type":"string",
794− "enum":[
755+ "enum":[
795756 "available",
796757 "pending",
797758 "sold"
@@ -801,23 +762,23 @@ petstoreExampleJSON = [aesonQQ|
801762 "collectionFormat":"csv"
802763 }
803764 ],
804− "responses":{
805− "200":{
765+ "responses":{
766+ "200":{
806767 "description":"successful operation",
807− "schema":{
768+ "schema":{
808769 "type":"array",
809− "items":{
770+ "items":{
810771 "$ref":"#/definitions/Pet"
811772 }
812773 }
813774 },
814− "400":{
775+ "400":{
815776 "description":"Invalid status value"
816777 }
817778 },
818− "security":[
819− {
820− "petstore_auth":[
779+ "security":[
780+ {
781+ "petstore_auth":[
821782 "write:pets",
822783 "read:pets"
823784 ]
@@ -825,48 +786,48 @@ petstoreExampleJSON = [aesonQQ|
825786 ]
826787 }
827788 },
828− "/pet/findByTags":{
829− "get":{
830− "tags":[
789+ "/pet/findByTags":{
790+ "get":{
791+ "tags":[
831792 "pet"
832793 ],
833794 "summary":"Finds Pets by tags",
834795 "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",
835796 "operationId":"findPetsByTags",
836− "produces":[
797+ "produces":[
837798 "application/xml",
838799 "application/json"
839800 ],
840− "parameters":[
841− {
801+ "parameters":[
802+ {
842803 "name":"tags",
843804 "in":"query",
844805 "description":"Tags to filter by",
845806 "required":true,
846807 "type":"array",
847− "items":{
808+ "items":{
848809 "type":"string"
849810 },
850811 "collectionFormat":"csv"
851812 }
852813 ],
853− "responses":{
854− "200":{
814+ "responses":{
815+ "200":{
855816 "description":"successful operation",
856− "schema":{
817+ "schema":{
857818 "type":"array",
858− "items":{
819+ "items":{
859820 "$ref":"#/definitions/Pet"
860821 }
861822 }
862823 },
863− "400":{
824+ "400":{
864825 "description":"Invalid tag value"
865826 }
866827 },
867− "security":[
868− {
869− "petstore_auth":[
828+ "security":[
829+ {
830+ "petstore_auth":[
870831 "write:pets",
871832 "read:pets"
872833 ]
@@ -874,20 +835,20 @@ petstoreExampleJSON = [aesonQQ|
874835 ]
875836 }
876837 },
877− "/pet/{petId}":{
878− "get":{
879− "tags":[
838+ "/pet/{petId}":{
839+ "get":{
840+ "tags":[
880841 "pet"
881842 ],
882843 "summary":"Find pet by ID",
883844 "description":"Returns a single pet",
884845 "operationId":"getPetById",
885− "produces":[
846+ "produces":[
886847 "application/xml",
887848 "application/json"
888849 ],
889− "parameters":[
890− {
850+ "parameters":[
851+ {
891852 "name":"petId",
892853 "in":"path",
893854 "description":"ID of pet to return",
@@ -896,42 +857,43 @@ petstoreExampleJSON = [aesonQQ|
896857 "format":"int64"
897858 }
898859 ],
899− "responses":{
900− "200":{
860+ "responses":{
861+ "200":{
901862 "description":"successful operation",
902− "schema":{
863+ "schema":{
903864 "$ref":"#/definitions/Pet"
904865 }
905866 },
906− "400":{
867+ "400":{
907868 "description":"Invalid ID supplied"
908869 },
909− "404":{
870+ "404":{
910871 "description":"Pet not found"
911872 }
912873 },
913− "security":[
914− {
915− "api_key": []
874+ "security":[
875+ {
876+ "api_key":[
877+ ]
916878 }
917879 ]
918880 },
919− "post":{
920− "tags":[
881+ "post":{
882+ "tags":[
921883 "pet"
922884 ],
923885 "summary":"Updates a pet in the store with form data",
924886 "description":"",
925887 "operationId":"updatePetWithForm",
926− "consumes":[
888+ "consumes":[
927889 "application/x-www-form-urlencoded"
928890 ],
929− "produces":[
891+ "produces":[
930892 "application/xml",
931893 "application/json"
932894 ],
933− "parameters":[
934− {
895+ "parameters":[
896+ {
935897 "name":"petId",
936898 "in":"path",
937899 "description":"ID of pet that needs to be updated",
@@ -939,14 +901,14 @@ petstoreExampleJSON = [aesonQQ|
939901 "type":"integer",
940902 "format":"int64"
941903 },
942− {
904+ {
943905 "name":"name",
944906 "in":"formData",
945907 "description":"Updated name of the pet",
946908 "required":false,
947909 "type":"string"
948910 },
949− {
911+ {
950912 "name":"status",
951913 "in":"formData",
952914 "description":"Updated status of the pet",
@@ -954,39 +916,39 @@ petstoreExampleJSON = [aesonQQ|
954916 "type":"string"
955917 }
956918 ],
957− "responses":{
958− "405":{
919+ "responses":{
920+ "405":{
959921 "description":"Invalid input"
960922 }
961923 },
962− "security":[
963− {
964− "petstore_auth":[
924+ "security":[
925+ {
926+ "petstore_auth":[
965927 "write:pets",
966928 "read:pets"
967929 ]
968930 }
969931 ]
970932 },
971− "delete":{
972− "tags":[
933+ "delete":{
934+ "tags":[
973935 "pet"
974936 ],
975937 "summary":"Deletes a pet",
976938 "description":"",
977939 "operationId":"deletePet",
978− "produces":[
940+ "produces":[
979941 "application/xml",
980942 "application/json"
981943 ],
982− "parameters":[
983− {
944+ "parameters":[
945+ {
984946 "name":"api_key",
985947 "in":"header",
986948 "required":false,
987949 "type":"string"
988950 },
989− {
951+ {
990952 "name":"petId",
991953 "in":"path",
992954 "description":"Pet id to delete",
@@ -995,14 +957,14 @@ petstoreExampleJSON = [aesonQQ|
995957 "format":"int64"
996958 }
997959 ],
998− "responses":{
999− "400":{
960+ "responses":{
961+ "400":{
1000962 "description":"Invalid pet value"
1001963 }
1002964 },
1003− "security":[
1004− {
1005− "petstore_auth":[
965+ "security":[
966+ {
967+ "petstore_auth":[
1006968 "write:pets",
1007969 "read:pets"
1008970 ]
@@ -1010,22 +972,22 @@ petstoreExampleJSON = [aesonQQ|
1010972 ]
1011973 }
1012974 },
1013− "/pet/{petId}/uploadImage":{
1014− "post":{
1015− "tags":[
975+ "/pet/{petId}/uploadImage":{
976+ "post":{
977+ "tags":[
1016978 "pet"
1017979 ],
1018980 "summary":"uploads an image",
1019981 "description":"",
1020982 "operationId":"uploadFile",
1021− "consumes":[
983+ "consumes":[
1022984 "multipart/form-data"
1023985 ],
1024− "produces":[
986+ "produces":[
1025987 "application/json"
1026988 ],
1027− "parameters":[
1028− {
989+ "parameters":[
990+ {
1029991 "name":"petId",
1030992 "in":"path",
1031993 "description":"ID of pet to update",
@@ -1033,14 +995,14 @@ petstoreExampleJSON = [aesonQQ|
1033995 "type":"integer",
1034996 "format":"int64"
1035997 },
1036− {
998+ {
1037999 "name":"additionalMetadata",
10381000 "in":"formData",
10391001 "description":"Additional data to pass to server",
10401002 "required":false,
10411003 "type":"string"
10421004 },
1043− {
1005+ {
10441006 "name":"file",
10451007 "in":"formData",
10461008 "description":"file to upload",
@@ -1048,17 +1010,17 @@ petstoreExampleJSON = [aesonQQ|
10481010 "type":"file"
10491011 }
10501012 ],
1051− "responses":{
1052− "200":{
1013+ "responses":{
1014+ "200":{
10531015 "description":"successful operation",
1054− "schema":{
1016+ "schema":{
10551017 "$ref":"#/definitions/ApiResponse"
10561018 }
10571019 }
10581020 },
1059− "security":[
1060− {
1061− "petstore_auth":[
1021+ "security":[
1022+ {
1023+ "petstore_auth":[
10621024 "write:pets",
10631025 "read:pets"
10641026 ]
@@ -1066,87 +1028,89 @@ petstoreExampleJSON = [aesonQQ|
10661028 ]
10671029 }
10681030 },
1069− "/store/inventory":{
1070− "get":{
1071− "tags":[
1031+ "/store/inventory":{
1032+ "get":{
1033+ "tags":[
10721034 "store"
10731035 ],
10741036 "summary":"Returns pet inventories by status",
10751037 "description":"Returns a map of status codes to quantities",
10761038 "operationId":"getInventory",
1077− "produces":[
1039+ "produces":[
10781040 "application/json"
10791041 ],
1080− "parameters": [],
1081− "responses":{
1082− "200":{
1042+ "parameters":[
1043+ ],
1044+ "responses":{
1045+ "200":{
10831046 "description":"successful operation",
1084− "schema":{
1047+ "schema":{
10851048 "type":"object",
1086− "additionalProperties":{
1049+ "additionalProperties":{
10871050 "type":"integer",
10881051 "format":"int32"
10891052 }
10901053 }
10911054 }
10921055 },
1093− "security":[
1094− {
1095− "api_key": []
1056+ "security":[
1057+ {
1058+ "api_key":[
1059+ ]
10961060 }
10971061 ]
10981062 }
10991063 },
1100− "/store/order":{
1101− "post":{
1102− "tags":[
1064+ "/store/order":{
1065+ "post":{
1066+ "tags":[
11031067 "store"
11041068 ],
11051069 "summary":"Place an order for a pet",
11061070 "description":"",
11071071 "operationId":"placeOrder",
1108− "produces":[
1072+ "produces":[
11091073 "application/xml",
11101074 "application/json"
11111075 ],
1112− "parameters":[
1113− {
1076+ "parameters":[
1077+ {
11141078 "in":"body",
11151079 "name":"body",
11161080 "description":"order placed for purchasing the pet",
11171081 "required":true,
1118− "schema":{
1082+ "schema":{
11191083 "$ref":"#/definitions/Order"
11201084 }
11211085 }
11221086 ],
1123− "responses":{
1124− "200":{
1087+ "responses":{
1088+ "200":{
11251089 "description":"successful operation",
1126− "schema":{
1090+ "schema":{
11271091 "$ref":"#/definitions/Order"
11281092 }
11291093 },
1130− "400":{
1094+ "400":{
11311095 "description":"Invalid Order"
11321096 }
11331097 }
11341098 }
11351099 },
1136− "/store/order/{orderId}":{
1137− "get":{
1138− "tags":[
1100+ "/store/order/{orderId}":{
1101+ "get":{
1102+ "tags":[
11391103 "store"
11401104 ],
11411105 "summary":"Find purchase order by ID",
11421106 "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",
11431107 "operationId":"getOrderById",
1144− "produces":[
1108+ "produces":[
11451109 "application/xml",
11461110 "application/json"
11471111 ],
1148− "parameters":[
1149− {
1112+ "parameters":[
1113+ {
11501114 "name":"orderId",
11511115 "in":"path",
11521116 "description":"ID of pet that needs to be fetched",
@@ -1157,34 +1121,34 @@ petstoreExampleJSON = [aesonQQ|
11571121 "format":"int64"
11581122 }
11591123 ],
1160− "responses":{
1161− "200":{
1124+ "responses":{
1125+ "200":{
11621126 "description":"successful operation",
1163− "schema":{
1127+ "schema":{
11641128 "$ref":"#/definitions/Order"
11651129 }
11661130 },
1167− "400":{
1131+ "400":{
11681132 "description":"Invalid ID supplied"
11691133 },
1170− "404":{
1134+ "404":{
11711135 "description":"Order not found"
11721136 }
11731137 }
11741138 },
1175− "delete":{
1176− "tags":[
1139+ "delete":{
1140+ "tags":[
11771141 "store"
11781142 ],
11791143 "summary":"Delete purchase order by ID",
11801144 "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",
11811145 "operationId":"deleteOrder",
1182− "produces":[
1146+ "produces":[
11831147 "application/xml",
11841148 "application/json"
11851149 ],
1186− "parameters":[
1187− {
1150+ "parameters":[
1151+ {
11881152 "name":"orderId",
11891153 "in":"path",
11901154 "description":"ID of the order that needs to be deleted",
@@ -1193,133 +1157,133 @@ petstoreExampleJSON = [aesonQQ|
11931157 "minimum":1.0
11941158 }
11951159 ],
1196− "responses":{
1197− "400":{
1160+ "responses":{
1161+ "400":{
11981162 "description":"Invalid ID supplied"
11991163 },
1200− "404":{
1164+ "404":{
12011165 "description":"Order not found"
12021166 }
12031167 }
12041168 }
12051169 },
1206− "/user":{
1207− "post":{
1208− "tags":[
1170+ "/user":{
1171+ "post":{
1172+ "tags":[
12091173 "user"
12101174 ],
12111175 "summary":"Create user",
12121176 "description":"This can only be done by the logged in user.",
12131177 "operationId":"createUser",
1214− "produces":[
1178+ "produces":[
12151179 "application/xml",
12161180 "application/json"
12171181 ],
1218− "parameters":[
1219− {
1182+ "parameters":[
1183+ {
12201184 "in":"body",
12211185 "name":"body",
12221186 "description":"Created user object",
12231187 "required":true,
1224− "schema":{
1188+ "schema":{
12251189 "$ref":"#/definitions/User"
12261190 }
12271191 }
12281192 ],
1229− "responses":{
1230− "default":{
1193+ "responses":{
1194+ "default":{
12311195 "description":"successful operation"
12321196 }
12331197 }
12341198 }
12351199 },
1236− "/user/createWithArray":{
1237− "post":{
1238− "tags":[
1200+ "/user/createWithArray":{
1201+ "post":{
1202+ "tags":[
12391203 "user"
12401204 ],
12411205 "summary":"Creates list of users with given input array",
12421206 "description":"",
12431207 "operationId":"createUsersWithArrayInput",
1244− "produces":[
1208+ "produces":[
12451209 "application/xml",
12461210 "application/json"
12471211 ],
1248− "parameters":[
1249− {
1212+ "parameters":[
1213+ {
12501214 "in":"body",
12511215 "name":"body",
12521216 "description":"List of user object",
12531217 "required":true,
1254− "schema":{
1218+ "schema":{
12551219 "type":"array",
1256− "items":{
1220+ "items":{
12571221 "$ref":"#/definitions/User"
12581222 }
12591223 }
12601224 }
12611225 ],
1262− "responses":{
1263− "default":{
1226+ "responses":{
1227+ "default":{
12641228 "description":"successful operation"
12651229 }
12661230 }
12671231 }
12681232 },
1269− "/user/createWithList":{
1270− "post":{
1271− "tags":[
1233+ "/user/createWithList":{
1234+ "post":{
1235+ "tags":[
12721236 "user"
12731237 ],
12741238 "summary":"Creates list of users with given input array",
12751239 "description":"",
12761240 "operationId":"createUsersWithListInput",
1277− "produces":[
1241+ "produces":[
12781242 "application/xml",
12791243 "application/json"
12801244 ],
1281− "parameters":[
1282− {
1245+ "parameters":[
1246+ {
12831247 "in":"body",
12841248 "name":"body",
12851249 "description":"List of user object",
12861250 "required":true,
1287− "schema":{
1251+ "schema":{
12881252 "type":"array",
1289− "items":{
1253+ "items":{
12901254 "$ref":"#/definitions/User"
12911255 }
12921256 }
12931257 }
12941258 ],
1295− "responses":{
1296− "default":{
1259+ "responses":{
1260+ "default":{
12971261 "description":"successful operation"
12981262 }
12991263 }
13001264 }
13011265 },
1302− "/user/login":{
1303− "get":{
1304− "tags":[
1266+ "/user/login":{
1267+ "get":{
1268+ "tags":[
13051269 "user"
13061270 ],
13071271 "summary":"Logs user into the system",
13081272 "description":"",
13091273 "operationId":"loginUser",
1310− "produces":[
1274+ "produces":[
13111275 "application/xml",
13121276 "application/json"
13131277 ],
1314− "parameters":[
1315− {
1278+ "parameters":[
1279+ {
13161280 "name":"username",
13171281 "in":"query",
13181282 "description":"The user name for login",
13191283 "required":true,
13201284 "type":"string"
13211285 },
1322− {
1286+ {
13231287 "name":"password",
13241288 "in":"query",
13251289 "description":"The password for login in clear text",
@@ -1327,65 +1291,66 @@ petstoreExampleJSON = [aesonQQ|
13271291 "type":"string"
13281292 }
13291293 ],
1330− "responses":{
1331− "200":{
1294+ "responses":{
1295+ "200":{
13321296 "description":"successful operation",
1333− "schema":{
1297+ "schema":{
13341298 "type":"string"
13351299 },
1336− "headers":{
1337− "X-Rate-Limit":{
1300+ "headers":{
1301+ "X-Rate-Limit":{
13381302 "type":"integer",
13391303 "format":"int32",
13401304 "description":"calls per hour allowed by the user"
13411305 },
1342− "X-Expires-After":{
1306+ "X-Expires-After":{
13431307 "type":"string",
13441308 "format":"date-time",
13451309 "description":"date in UTC when toekn expires"
13461310 }
13471311 }
13481312 },
1349− "400":{
1313+ "400":{
13501314 "description":"Invalid username/password supplied"
13511315 }
13521316 }
13531317 }
13541318 },
1355− "/user/logout":{
1356− "get":{
1357− "tags":[
1319+ "/user/logout":{
1320+ "get":{
1321+ "tags":[
13581322 "user"
13591323 ],
13601324 "summary":"Logs out current logged in user session",
13611325 "description":"",
13621326 "operationId":"logoutUser",
1363− "produces":[
1327+ "produces":[
13641328 "application/xml",
13651329 "application/json"
13661330 ],
1367− "parameters": [],
1368− "responses":{
1369− "default":{
1331+ "parameters":[
1332+ ],
1333+ "responses":{
1334+ "default":{
13701335 "description":"successful operation"
13711336 }
13721337 }
13731338 }
13741339 },
1375− "/user/{username}":{
1376− "get":{
1377− "tags":[
1340+ "/user/{username}":{
1341+ "get":{
1342+ "tags":[
13781343 "user"
13791344 ],
13801345 "summary":"Get user by user name",
13811346 "description":"",
13821347 "operationId":"getUserByName",
1383− "produces":[
1348+ "produces":[
13841349 "application/xml",
13851350 "application/json"
13861351 ],
1387− "parameters":[
1388− {
1352+ "parameters":[
1353+ {
13891354 "name":"username",
13901355 "in":"path",
13911356 "description":"The name that needs to be fetched. Use user1 for testing. ",
@@ -1393,72 +1358,72 @@ petstoreExampleJSON = [aesonQQ|
13931358 "type":"string"
13941359 }
13951360 ],
1396− "responses":{
1397− "200":{
1361+ "responses":{
1362+ "200":{
13981363 "description":"successful operation",
1399− "schema":{
1364+ "schema":{
14001365 "$ref":"#/definitions/User"
14011366 }
14021367 },
1403− "400":{
1368+ "400":{
14041369 "description":"Invalid username supplied"
14051370 },
1406− "404":{
1371+ "404":{
14071372 "description":"User not found"
14081373 }
14091374 }
14101375 },
1411− "put":{
1412− "tags":[
1376+ "put":{
1377+ "tags":[
14131378 "user"
14141379 ],
14151380 "summary":"Updated user",
14161381 "description":"This can only be done by the logged in user.",
14171382 "operationId":"updateUser",
1418− "produces":[
1383+ "produces":[
14191384 "application/xml",
14201385 "application/json"
14211386 ],
1422− "parameters":[
1423− {
1387+ "parameters":[
1388+ {
14241389 "name":"username",
14251390 "in":"path",
14261391 "description":"name that need to be deleted",
14271392 "required":true,
14281393 "type":"string"
14291394 },
1430− {
1395+ {
14311396 "in":"body",
14321397 "name":"body",
14331398 "description":"Updated user object",
14341399 "required":true,
1435− "schema":{
1400+ "schema":{
14361401 "$ref":"#/definitions/User"
14371402 }
14381403 }
14391404 ],
1440− "responses":{
1441− "400":{
1405+ "responses":{
1406+ "400":{
14421407 "description":"Invalid user supplied"
14431408 },
1444− "404":{
1409+ "404":{
14451410 "description":"User not found"
14461411 }
14471412 }
14481413 },
1449− "delete":{
1450− "tags":[
1414+ "delete":{
1415+ "tags":[
14511416 "user"
14521417 ],
14531418 "summary":"Delete user",
14541419 "description":"This can only be done by the logged in user.",
14551420 "operationId":"deleteUser",
1456− "produces":[
1421+ "produces":[
14571422 "application/xml",
14581423 "application/json"
14591424 ],
1460− "parameters":[
1461− {
1425+ "parameters":[
1426+ {
14621427 "name":"username",
14631428 "in":"path",
14641429 "description":"The name that needs to be deleted",
@@ -1466,237 +1431,207 @@ petstoreExampleJSON = [aesonQQ|
14661431 "type":"string"
14671432 }
14681433 ],
1469− "responses":{
1470− "400":{
1434+ "responses":{
1435+ "400":{
14711436 "description":"Invalid username supplied"
14721437 },
1473− "404":{
1438+ "404":{
14741439 "description":"User not found"
14751440 }
14761441 }
14771442 }
14781443 }
14791444 },
1480− "securityDefinitions":{
1481− "petstore_auth":{
1445+ "securityDefinitions":{
1446+ "petstore_auth":{
14821447 "type":"oauth2",
14831448 "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",
14841449 "flow":"implicit",
1485− "scopes":{
1450+ "scopes":{
14861451 "write:pets":"modify pets in your account",
14871452 "read:pets":"read your pets"
14881453 }
14891454 },
1490− "api_key":{
1455+ "api_key":{
14911456 "type":"apiKey",
14921457 "name":"api_key",
14931458 "in":"header"
14941459 }
14951460 },
1496− "definitions":{
1497− "Order":{
1461+ "definitions":{
1462+ "Order":{
14981463 "type":"object",
1499− "properties":{
1500− "id":{
1464+ "properties":{
1465+ "id":{
15011466 "type":"integer",
15021467 "format":"int64"
15031468 },
1504− "petId":{
1469+ "petId":{
15051470 "type":"integer",
15061471 "format":"int64"
15071472 },
1508− "quantity":{
1473+ "quantity":{
15091474 "type":"integer",
15101475 "format":"int32"
15111476 },
1512− "shipDate":{
1477+ "shipDate":{
15131478 "type":"string",
15141479 "format":"date-time"
15151480 },
1516− "status":{
1481+ "status":{
15171482 "type":"string",
15181483 "description":"Order Status",
1519− "enum":[
1484+ "enum":[
15201485 "placed",
15211486 "approved",
15221487 "delivered"
15231488 ]
15241489 },
1525− "complete":{
1490+ "complete":{
15261491 "type":"boolean",
15271492 "default":false
15281493 }
15291494 },
1530− "xml":{
1495+ "xml":{
15311496 "name":"Order"
15321497 }
15331498 },
1534− "Category":{
1499+ "Category":{
15351500 "type":"object",
1536− "properties":{
1537− "id":{
1501+ "properties":{
1502+ "id":{
15381503 "type":"integer",
15391504 "format":"int64"
15401505 },
1541− "name":{
1506+ "name":{
15421507 "type":"string"
15431508 }
15441509 },
1545− "xml":{
1510+ "xml":{
15461511 "name":"Category"
15471512 }
15481513 },
1549− "User":{
1514+ "User":{
15501515 "type":"object",
1551− "properties":{
1552− "id":{
1516+ "properties":{
1517+ "id":{
15531518 "type":"integer",
15541519 "format":"int64"
15551520 },
1556− "username":{
1521+ "username":{
15571522 "type":"string"
15581523 },
1559− "firstName":{
1524+ "firstName":{
15601525 "type":"string"
15611526 },
1562− "lastName":{
1527+ "lastName":{
15631528 "type":"string"
15641529 },
1565− "email":{
1530+ "email":{
15661531 "type":"string"
15671532 },
1568− "password":{
1533+ "password":{
15691534 "type":"string"
15701535 },
1571− "phone":{
1536+ "phone":{
15721537 "type":"string"
15731538 },
1574− "userStatus":{
1539+ "userStatus":{
15751540 "type":"integer",
15761541 "format":"int32",
15771542 "description":"User Status"
15781543 }
15791544 },
1580− "xml":{
1545+ "xml":{
15811546 "name":"User"
15821547 }
15831548 },
1584− "Tag":{
1549+ "Tag":{
15851550 "type":"object",
1586− "properties":{
1587− "id":{
1551+ "properties":{
1552+ "id":{
15881553 "type":"integer",
15891554 "format":"int64"
15901555 },
1591− "name":{
1556+ "name":{
15921557 "type":"string"
15931558 }
15941559 },
1595− "xml":{
1560+ "xml":{
15961561 "name":"Tag"
15971562 }
15981563 },
1599− "Pet":{
1564+ "Pet":{
16001565 "type":"object",
1601− "required":[
1566+ "required":[
16021567 "name",
16031568 "photoUrls"
16041569 ],
1605− "properties":{
1606− "id":{
1570+ "properties":{
1571+ "id":{
16071572 "type":"integer",
16081573 "format":"int64"
16091574 },
1610− "category":{
1575+ "category":{
16111576 "$ref":"#/definitions/Category"
16121577 },
1613− "name":{
1578+ "name":{
16141579 "type":"string",
16151580 "example":"doggie"
16161581 },
1617− "photoUrls":{
1582+ "photoUrls":{
16181583 "type":"array",
1619− "xml":{
1584+ "xml":{
16201585 "name":"photoUrl",
16211586 "wrapped":true
16221587 },
1623− "items":{
1588+ "items":{
16241589 "type":"string"
16251590 }
16261591 },
1627− "tags":{
1592+ "tags":{
16281593 "type":"array",
1629− "xml":{
1594+ "xml":{
16301595 "name":"tag",
16311596 "wrapped":true
16321597 },
1633− "items":{
1598+ "items":{
16341599 "$ref":"#/definitions/Tag"
16351600 }
16361601 },
1637− "status":{
1602+ "status":{
16381603 "type":"string",
16391604 "description":"pet status in the store",
1640− "enum":[
1605+ "enum":[
16411606 "available",
16421607 "pending",
16431608 "sold"
16441609 ]
16451610 }
16461611 },
1647− "xml":{
1612+ "xml":{
16481613 "name":"Pet"
16491614 }
16501615 },
1651− "ApiResponse":{
1616+ "ApiResponse":{
16521617 "type":"object",
1653− "properties":{
1654− "code":{
1618+ "properties":{
1619+ "code":{
16551620 "type":"integer",
16561621 "format":"int32"
16571622 },
1658− "type":{
1623+ "type":{
16591624 "type":"string"
16601625 },
1661− "message":{
1626+ "message":{
16621627 "type":"string"
16631628 }
16641629 }
16651630 }
16661631 },
1667− "externalDocs":{
1632+ "externalDocs":{
16681633 "description":"Find out more about Swagger",
16691634 "url":"http://swagger.io"
16701635 }
16711636}
16721637|]
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/SpecCommon.hs+19−10
@@ -1,10 +1,16 @@
11module SpecCommon where
22
33import Data.Aeson
4−import Data.ByteString.Builder (toLazyByteString)
4+import Data.Aeson.QQ
55import qualified Data.Foldable as F
6+import Data.HashMap.Strict (HashMap)
67import qualified Data.HashMap.Strict as HashMap
8+import Data.Maybe
9+import Data.Monoid
710import qualified Data.Vector as Vector
11+import Data.Text (Text)
12+
13+import Data.Swagger
814
915import Test.Hspec
1016
@@ -16,15 +22,18 @@ isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i
1622isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys)
1723isSubJSON x y = x == y
1824
25+(<~>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec
26+x <~> json = do
27+ it "encodes correctly (probably with extra properties)" $ do
28+ toJSON x `shouldSatisfy` (json `isSubJSON`)
29+ it "decodes correctly" $ do
30+ fromJSON json `shouldBe` Success x
31+
1932(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec
20−x <=> js = do
33+x <=> json = do
2134 it "encodes correctly" $ do
22− toJSON x `shouldBe` js
35+ toJSON x `shouldBe` json
2336 it "decodes correctly" $ do
24− fromJSON js `shouldBe` Success x
25− it "roundtrips: eitherDecode . encode" $ do
26− eitherDecode (encode x) `shouldBe` Right x
27− it "roundtrips with toJSON" $ do
28− eitherDecode (encode $ toJSON x) `shouldBe` Right x
29− it "roundtrips with toEncoding" $ do
30− eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x
37+ fromJSON json `shouldBe` Success x
38+
39+
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