git.iko.soy/typeable/swagger2
on master help sign in
41 files changed+7418−1900
since splitsnapshots
unifiedsplit
.ghci+2 .gitignore+2 .travis.yml+157−43 CHANGELOG.md+294−5 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+294−31 src/Data/Swagger/Declare.hs+199 src/Data/Swagger/Internal.hs+802−385 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+52−42 src/Data/Swagger/Lens.hs+173−95 src/Data/Swagger/Operation.hs+193 src/Data/Swagger/Optics.hs+597 src/Data/Swagger/ParamSchema.hs+26 src/Data/Swagger/Schema.hs+39−6 src/Data/Swagger/Schema/Generator.hs+114 src/Data/Swagger/Schema/Internal.hs−390 src/Data/Swagger/Schema/Validation.hs+90 src/Data/Swagger/SchemaOptions.hs+72 stack-7.8.yaml−5 stack-head.yaml−5 stack.yaml+6−2 swagger2.cabal+117−29 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+70−356 test/Data/SwaggerSpec.hs+551−486 test/SpecCommon.hs+10−19 test/doctests.hs+12
.ghcinew file+2
@@ -0,0 +1,2 @@
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,4 +1,6 @@
11dist
2+dist-newstyle
3+.ghc.environment.*
24cabal-dev
35*.o
46*.hi
.travis.yml+157−43
@@ -1,48 +1,162 @@
1−# explicitly request container-based infrastructure
2−sudo: false
3−
4−matrix:
5− include:
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−
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
3117cache:
3218 directories:
33− - $HOME/.stack/
34−
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
30+matrix:
31+ 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"]}}
3542before_install:
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−
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
4374install:
44− - stack --no-terminal --skip-ghc-check setup
45− - stack --no-terminal --skip-ghc-check test --only-snapshot
46−
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
47126script:
48− - stack --no-terminal --skip-ghc-check test
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
160+
161+# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])
162+# EOF
CHANGELOG.md+294−5
@@ -1,3 +1,292 @@
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+
12900.3
2291---
3292* Fixes:
@@ -8,9 +297,9 @@
8297
92980.2
10299---
11−* Add `Data.Swagger.Lens`
12−* Support references
300+* Add `Data.Swagger.Lens`;
301+* Support references;
13302* Fixes:
14− * Fix `FromJSON SwaggerHost` instance
15− * Add missing `Maybe`s for field types
16− * Decode petstore swagger.json successfully
303+ * Fix `FromJSON SwaggerHost` instance;
304+ * Add missing `Maybe`s for field types;
305+ * Decode petstore `swagger.json` successfully.
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015, GetShopTV
1+Copyright (c) 2015-2017, GetShopTV
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without
README.md+33
@@ -1,6 +1,39 @@
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+
35[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
46[![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)
59
610Swagger 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,2 +1,33 @@
1+{-# LANGUAGE CPP #-}
2+{-# OPTIONS_GHC -Wall #-}
3+module Main (main) where
4+
5+#ifndef MIN_VERSION_cabal_doctest
6+#define MIN_VERSION_cabal_doctest(x,y,z) 0
7+#endif
8+
9+#if MIN_VERSION_cabal_doctest(1,0,0)
10+
11+import Distribution.Extra.Doctest ( defaultMainWithDoctests )
12+main :: IO ()
13+main = defaultMainWithDoctests "doctests"
14+
15+#else
16+
17+#ifdef MIN_VERSION_Cabal
18+-- If the macro is defined, we have new cabal-install,
19+-- but for some reason we don't have cabal-doctest in package-db
20+--
21+-- Probably we are running cabal sdist, when otherwise using new-build
22+-- workflow
23+#warning You are configuring this package without cabal-doctest installed. \
24+ The doctests test-suite will not work as a result. \
25+ To fix this, install cabal-doctest before configuring.
26+#endif
27+
128import Distribution.Simple
29+
30+main :: IO ()
231main = defaultMain
32+
33+#endif
cabal.projectnew file+2
@@ -0,0 +1,2 @@
1+packages: .
2+tests: true
examples/hackage.hsnew file+86
@@ -0,0 +1,86 @@
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.shnew file+78
@@ -0,0 +1,78 @@
1+#!/bin/bash
2+set -e
3+
4+# This if stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh
5+
6+if [ "$#" -ne 1 ]; then
7+ echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
8+ exit 1
9+fi
10+
11+user=$1
12+
13+cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
14+if [ ! -f "$cabal_file" ]; then
15+ echo "Run this script in the top-level package directory"
16+ exit 1
17+fi
18+
19+pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
20+ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
21+
22+if [ -z "$pkg" ]; then
23+ echo "Unable to determine package name"
24+ exit 1
25+fi
26+
27+if [ -z "$ver" ]; then
28+ echo "Unable to determine package version"
29+ exit 1
30+fi
31+
32+echo "Detected package: $pkg-$ver"
33+
34+dir=$(mktemp -d build-docs.XXXXXX)
35+trap 'rm -r "$dir"' EXIT
36+
37+export PATH=$(stack path --bin-path)
38+
39+ghc --version
40+cabal --version
41+stack --version
42+
43+if haddock --hyperlinked-source >/dev/null
44+then
45+ echo "Using fancy hyperlinked source"
46+ HYPERLINK_FLAG="--haddock-option=--hyperlinked-source"
47+else
48+ echo "Using boring hyperlinked source"
49+ HYPERLINK_FLAG="--hyperlink-source"
50+fi
51+
52+# Cabal dist in temporary location
53+builddir=$dir/dist
54+
55+# Build dependencies haddocks with stack, so we get links
56+stack haddock --only-dependencies
57+
58+# Configure using stack databases
59+snapshotpkgdb=$(stack path --snapshot-pkg-db)
60+localpkgdb=$(stack path --local-pkg-db)
61+cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb
62+
63+# Build Hadckage compatible docs
64+cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
65+
66+# Copy into right directory
67+cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs
68+
69+# Tar and gzip
70+tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
71+
72+# Upload
73+curl -X PUT \
74+ -H 'Content-Type: application/x-tar' \
75+ -H 'Content-Encoding: gzip' \
76+ -u "$user" \
77+ --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
78+ "https://hackage.haskell.org/package/$pkg-$ver/docs"
include/overlapping-compat.hnew file+8
@@ -0,0 +1,8 @@
1+#if __GLASGOW_HASKELL__ >= 710
2+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
3+#define OVERLAPPING_ {-# OVERLAPPING #-}
4+#else
5+{-# LANGUAGE OverlappingInstances #-}
6+#define OVERLAPPABLE_
7+#define OVERLAPPING_
8+#endif
src/Data/Swagger.hs+294−31
@@ -1,4 +1,9 @@
1+{-# LANGUAGE CPP #-}
12-- |
3+-- Module: Data.Swagger
4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5+-- Stability: experimental
6+--
27-- Swagger™ is a project used to describe and document RESTful APIs.
38--
49-- The Swagger specification defines a set of files required to describe such an API.
@@ -6,82 +11,340 @@
611-- and Swagger-Codegen to generate clients in various languages.
712-- Additional utilities can also take advantage of the resulting files, such as testing tools.
813module 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,
937 module Data.Swagger.Schema,
38+ module Data.Swagger.Schema.Validation,
1039
1140 -- * Swagger specification
1241 Swagger(..),
1342 Host(..),
1443 Scheme(..),
1544
16− -- * Info types
45+ -- ** Info types
1746 Info(..),
1847 Contact(..),
1948 License(..),
2049
21− -- * Paths
22− Paths(..),
50+ -- ** PathItem
2351 PathItem(..),
2452
25− -- * Operations
26− Tag(..),
53+ -- ** Operations
2754 Operation(..),
55+ Tag(..),
56+ TagName,
2857
29− -- * Types and formats
30− ParameterType(..),
31− ItemsType(..),
32− SchemaType(..),
33− Format(..),
58+ -- ** Types and formats
59+ SwaggerType(..),
60+ Format,
61+ Definitions,
3462 CollectionFormat(..),
35− ItemsCollectionFormat(..),
36−
37− -- * Parameters
38− Parameter(..),
39− ParameterSchema(..),
40− ParameterOtherSchema(..),
41− ParameterLocation(..),
42− ParamName(..),
43− Items(..),
63+
64+ -- ** Parameters
65+ Param(..),
66+ ParamAnySchema(..),
67+ ParamOtherSchema(..),
68+ ParamLocation(..),
69+ ParamName,
4470 Header(..),
71+ HeaderName,
4572 Example(..),
4673
47− -- * Schema
74+ -- ** Schemas
75+ ParamSchema(..),
4876 Schema(..),
49− SchemaItems(..),
50− SchemaCommon(..),
77+ NamedSchema(..),
78+ SwaggerItems(..),
5179 Xml(..),
80+ Pattern,
81+ AdditionalProperties(..),
5282
53− -- * Responses
83+ -- ** Responses
5484 Responses(..),
5585 Response(..),
86+ HttpStatusCode,
5687
57− -- * Security
88+ -- ** Security
5889 SecurityScheme(..),
5990 SecuritySchemeType(..),
6091 SecurityRequirement(..),
92+ SecurityDefinitions(..),
6193
62− -- ** API key
94+ -- *** API key
6395 ApiKeyParams(..),
6496 ApiKeyLocation(..),
6597
66− -- ** OAuth2
98+ -- *** OAuth2
6799 OAuth2Params(..),
68100 OAuth2Flow(..),
69− AuthorizationURL(..),
70− TokenURL(..),
101+ AuthorizationURL,
102+ TokenURL,
71103
72− -- * External documentation
104+ -- ** External documentation
73105 ExternalDocs(..),
74106
75− -- * References
107+ -- ** References
76108 Reference(..),
77109 Referenced(..),
78110
79− -- * Miscellaneous
111+ -- ** Miscellaneous
80112 MimeList(..),
81113 URL(..),
82114) where
83115
116+import Data.Swagger.Lens
117+import Data.Swagger.Optics ()
118+import Data.Swagger.Operation
119+import Data.Swagger.ParamSchema
84120import Data.Swagger.Schema
121+import Data.Swagger.Schema.Validation
85122
86123import Data.Swagger.Internal
87124
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.hsnew file+199
@@ -0,0 +1,199 @@
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+802−385
@@ -1,97 +1,140 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE DeriveFunctor #-}
15{-# LANGUAGE DeriveGeneric #-}
26{-# LANGUAGE DeriveTraversable #-}
7+{-# LANGUAGE FlexibleContexts #-}
38{-# LANGUAGE FlexibleInstances #-}
9+{-# LANGUAGE GADTs #-}
410{-# LANGUAGE GeneralizedNewtypeDeriving #-}
511{-# LANGUAGE OverloadedStrings #-}
612{-# LANGUAGE RecordWildCards #-}
713{-# LANGUAGE ScopedTypeVariables #-}
814{-# LANGUAGE StandaloneDeriving #-}
915{-# LANGUAGE TemplateHaskell #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE UndecidableInstances #-}
18+#if __GLASGOW_HASKELL__ <710
19+{-# LANGUAGE PolyKinds #-}
20+#endif
21+#include "overlapping-compat.h"
1022module Data.Swagger.Internal where
1123
24+import Prelude ()
25+import Prelude.Compat
26+
27+import Control.Lens ((&), (.~), (?~))
1228import Control.Applicative
13−import Control.Monad
1429import Data.Aeson
15−import Data.Aeson.TH (deriveJSON)
16−import Data.Foldable (Foldable)
17−import Data.HashMap.Strict (HashMap)
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)
1833import qualified Data.HashMap.Strict as HashMap
34+import Data.HashSet.InsOrd (InsOrdHashSet)
1935import Data.Map (Map)
2036import qualified Data.Map as Map
21−import Data.Monoid
37+import Data.Monoid (Monoid (..))
38+import Data.Semigroup.Compat (Semigroup (..))
2239import Data.Scientific (Scientific)
23−import Data.String (fromString)
40+import Data.String (IsString(..))
2441import Data.Text (Text)
2542import qualified Data.Text as Text
26−import Data.Traversable (Traversable)
27−import Data.Hashable (Hashable)
2843import GHC.Generics (Generic)
29−import Network (HostName, PortNumber)
44+import Network.Socket (HostName, PortNumber)
3045import Network.HTTP.Media (MediaType)
3146import Text.Read (readMaybe)
3247
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)
3360import Data.Swagger.Internal.Utils
3461
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+
3576-- | This is the root document object for the API specification.
3677data Swagger = Swagger
3778 { -- | Provides metadata about the API.
3879 -- The metadata can be used by the clients if needed.
39− _info :: Info
80+ _swaggerInfo :: Info
4081
4182 -- | The host (name or ip) serving the API. It MAY include a port.
4283 -- If the host is not included, the host serving the documentation is to be used (including the port).
43− , _host :: Maybe Host
84+ , _swaggerHost :: Maybe Host
4485
4586 -- | The base path on which the API is served, which is relative to the host.
4687 -- If it is not included, the API is served directly under the host.
4788 -- The value MUST start with a leading slash (/).
48− , _basePath :: Maybe FilePath
89+ , _swaggerBasePath :: Maybe FilePath
4990
5091 -- | The transfer protocol of the API.
5192 -- If the schemes is not included, the default scheme to be used is the one used to access the Swagger definition itself.
52− , _schemes :: Maybe [Scheme]
93+ , _swaggerSchemes :: Maybe [Scheme]
5394
5495 -- | A list of MIME types the APIs can consume.
5596 -- This is global to all APIs but can be overridden on specific API calls.
56− , _consumes :: MimeList
97+ , _swaggerConsumes :: MimeList
5798
5899 -- | A list of MIME types the APIs can produce.
59− -- This is global to all APIs but can be overridden on specific API calls.
60− , _produces :: MimeList
100+ -- This is global to all APIs but can be overridden on specific API calls.
101+ , _swaggerProduces :: MimeList
61102
62103 -- | The available paths and operations for the API.
63− , _paths :: Paths
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
64107
65108 -- | An object to hold data types produced and consumed by operations.
66− , _definitions :: HashMap Text Schema
109+ , _swaggerDefinitions :: Definitions Schema
67110
68111 -- | An object to hold parameters that can be used across operations.
69112 -- This property does not define global parameters for all operations.
70− , _parameters :: HashMap Text Parameter
113+ , _swaggerParameters :: Definitions Param
71114
72115 -- | An object to hold responses that can be used across operations.
73116 -- This property does not define global responses for all operations.
74− , _responses :: HashMap Text Response
117+ , _swaggerResponses :: Definitions Response
75118
76119 -- | Security scheme definitions that can be used across the specification.
77− , _securityDefinitions :: HashMap Text SecurityScheme
120+ , _swaggerSecurityDefinitions :: SecurityDefinitions
78121
79122 -- | A declaration of which security schemes are applied for the API as a whole.
80123 -- The list of values describes alternative security schemes that can be used
81124 -- (that is, there is a logical OR between the security requirements).
82125 -- Individual operations can override this definition.
83− , _security :: [SecurityRequirement]
126+ , _swaggerSecurity :: [SecurityRequirement]
84127
85128 -- | A list of tags used by the specification with additional metadata.
86129 -- The order of the tags can be used to reflect on their order by the parsing tools.
87130 -- Not all tags that are used by the Operation Object must be declared.
88131 -- The tags that are not declared may be organized randomly or based on the tools' logic.
89132 -- Each tag name in the list MUST be unique.
90− , _tags :: [Tag]
133+ , _swaggerTags :: InsOrdHashSet Tag
91134
92135 -- | Additional external documentation.
93− , _externalDocs :: Maybe ExternalDocs
94− } deriving (Eq, Show, Generic)
136+ , _swaggerExternalDocs :: Maybe ExternalDocs
137+ } deriving (Eq, Show, Generic, Data, Typeable)
95138
96139-- | The object provides metadata about the API.
97140-- The metadata can be used by the clients if needed,
@@ -116,7 +159,7 @@ data Info = Info
116159 -- | Provides the version of the application API
117160 -- (not to be confused with the specification version).
118161 , _infoVersion :: Text
119− } deriving (Eq, Show, Generic)
162+ } deriving (Eq, Show, Generic, Data, Typeable)
120163
121164-- | Contact information for the exposed API.
122165data Contact = Contact
@@ -128,7 +171,7 @@ data Contact = Contact
128171
129172 -- | The email address of the contact person/organization.
130173 , _contactEmail :: Maybe Text
131− } deriving (Eq, Show)
174+ } deriving (Eq, Show, Generic, Data, Typeable)
132175
133176-- | License information for the exposed API.
134177data License = License
@@ -137,13 +180,32 @@ data License = License
137180
138181 -- | A URL to the license used for the API.
139182 , _licenseUrl :: Maybe URL
140− } deriving (Eq, Show)
183+ } deriving (Eq, Show, Generic, Data, Typeable)
184+
185+instance IsString License where
186+ fromString s = License (fromString s) Nothing
141187
142188-- | The host (name or ip) serving the API. It MAY include a port.
143189data Host = Host
144190 { _hostName :: HostName -- ^ Host name.
145191 , _hostPort :: Maybe PortNumber -- ^ Optional port.
146− } deriving (Eq, Show)
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
147209
148210-- | The transfer protocol of the API.
149211data Scheme
@@ -151,14 +213,7 @@ data Scheme
151213 | Https
152214 | Ws
153215 | Wss
154− deriving (Eq, Show)
155−
156−-- | The available paths and operations for the API.
157−data Paths = Paths
158− { -- | Holds the relative paths to the individual endpoints.
159− -- The path is appended to the @'basePath'@ in order to construct the full URL.
160− _pathsMap :: HashMap FilePath PathItem
161− } deriving (Eq, Show, Generic)
216+ deriving (Eq, Show, Generic, Data, Typeable)
162217
163218-- | Describes the operations available on a single path.
164219-- A @'PathItem'@ may be empty, due to ACL constraints.
@@ -190,14 +245,14 @@ data PathItem = PathItem
190245 -- These parameters can be overridden at the operation level, but cannot be removed there.
191246 -- The list MUST NOT include duplicated parameters.
192247 -- A unique parameter is defined by a combination of a name and location.
193− , _pathItemParameters :: [Referenced Parameter]
194− } deriving (Eq, Show, Generic)
248+ , _pathItemParameters :: [Referenced Param]
249+ } deriving (Eq, Show, Generic, Data, Typeable)
195250
196251-- | Describes a single API operation on a path.
197252data Operation = Operation
198253 { -- | A list of tags for API documentation control.
199254 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
200− _operationTags :: [Text]
255+ _operationTags :: InsOrdHashSet TagName
201256
202257 -- | A short summary of what the operation does.
203258 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -231,7 +286,7 @@ data Operation = Operation
231286 -- the new definition will override it, but can never remove it.
232287 -- The list MUST NOT include duplicated parameters.
233288 -- A unique parameter is defined by a combination of a name and location.
234− , _operationParameters :: [Referenced Parameter]
289+ , _operationParameters :: [Referenced Param]
235290
236291 -- | The list of possible responses as they are returned from executing this operation.
237292 , _operationResponses :: Responses
@@ -251,88 +306,205 @@ data Operation = Operation
251306 -- This definition overrides any declared top-level security.
252307 -- To remove a top-level security declaration, @Just []@ can be used.
253308 , _operationSecurity :: [SecurityRequirement]
254− } deriving (Eq, Show, Generic)
309+ } deriving (Eq, Show, Generic, Data, Typeable)
255310
256311newtype MimeList = MimeList { getMimeList :: [MediaType] }
257− deriving (Eq, Show, Monoid)
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
258326
259327-- | Describes a single operation parameter.
260328-- A unique parameter is defined by a combination of a name and location.
261−data Parameter = Parameter
329+data Param = Param
262330 { -- | The name of the parameter.
263331 -- Parameter names are case sensitive.
264− _parameterName :: Text
332+ _paramName :: Text
265333
266334 -- | A brief description of the parameter.
267335 -- This could contain examples of use.
268336 -- GFM syntax can be used for rich text representation.
269− , _parameterDescription :: Maybe Text
337+ , _paramDescription :: Maybe Text
270338
271339 -- | Determines whether this parameter is mandatory.
272340 -- If the parameter is in "path", this property is required and its value MUST be true.
273341 -- Otherwise, the property MAY be included and its default value is @False@.
274− , _parameterRequired :: Maybe Bool
342+ , _paramRequired :: Maybe Bool
275343
276344 -- | Parameter schema.
277− , _parameterSchema :: ParameterSchema
278− } deriving (Eq, Show, Generic)
345+ , _paramSchema :: ParamAnySchema
346+ } deriving (Eq, Show, Generic, Data, Typeable)
279347
280−data ParameterSchema
281− = ParameterBody (Referenced Schema)
282− | ParameterOther ParameterOtherSchema
283− deriving (Eq, Show)
348+data ParamAnySchema
349+ = ParamBody (Referenced Schema)
350+ | ParamOther ParamOtherSchema
351+ deriving (Eq, Show, Generic, Data, Typeable)
284352
285−data ParameterOtherSchema = ParameterOtherSchema
353+data ParamOtherSchema = ParamOtherSchema
286354 { -- | The location of the parameter.
287− _parameterOtherSchemaIn :: ParameterLocation
288−
289− -- | The type of the parameter.
290− -- Since the parameter is not located at the request body,
291− -- it is limited to simple types (that is, not an object).
292− -- If type is @'ParamFile'@, the @consumes@ MUST be either
293− -- "multipart/form-data" or " application/x-www-form-urlencoded"
294− -- and the parameter MUST be in @'ParameterFormData'@.
295− , _parameterOtherSchemaType :: ParameterType
296−
297− -- | The extending format for the previously mentioned type.
298− , _parameterOtherSchemaFormat :: Maybe Format
355+ _paramOtherSchemaIn :: ParamLocation
299356
300357 -- | Sets the ability to pass empty-valued parameters.
301− -- This is valid only for either @'ParameterQuery'@ or @'ParameterFormData'@
358+ -- This is valid only for either @'ParamQuery'@ or @'ParamFormData'@
302359 -- and allows you to send a parameter with a name only or an empty value.
303360 -- Default value is @False@.
304− , _parameterOtherSchemaAllowEmptyValue :: Maybe Bool
305−
306− -- | __Required if type is @'ParamArray'@__.
307− -- Describes the type of items in the array.
308− , _parameterOtherSchemaItems :: Maybe Items
309−
310− -- | Determines the format of the array if @'ParamArray'@ is used.
311− -- Default value is csv.
312− , _parameterOtherSchemaCollectionFormat :: Maybe CollectionFormat
313−
314− , _parameterOtherSchemaCommon :: SchemaCommon
315− } deriving (Eq, Show, Generic)
316−
317−data ParameterType
318− = ParamString
319− | ParamNumber
320− | ParamInteger
321− | ParamBoolean
322− | ParamArray
323− | ParamFile
324− deriving (Eq, Show)
325−
326−data ParameterLocation
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
327499 = -- | Parameters that are appended to the URL.
328500 -- For example, in @/items?id=###@, the query parameter is @id@.
329− ParameterQuery
501+ ParamQuery
330502 -- | Custom headers that are expected as part of the request.
331− | ParameterHeader
503+ | ParamHeader
332504 -- | Used together with Path Templating, where the parameter value is actually part of the operation's URL.
333505 -- This does not include the host or base path of the API.
334506 -- For example, in @/items/{itemId}@, the path parameter is @itemId@.
335− | ParameterPath
507+ | ParamPath
336508 -- | Used to describe the payload of an HTTP request when either @application/x-www-form-urlencoded@
337509 -- or @multipart/form-data@ are used as the content type of the request
338510 -- (in Swagger's definition, the @consumes@ property of an operation).
@@ -340,61 +512,57 @@ data ParameterLocation
340512 -- Since form parameters are sent in the payload, they cannot be declared together with a body parameter for the same operation.
341513 -- Form parameters have a different format based on the content-type used
342514 -- (for further details, consult <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).
343− | ParameterFormData
344− deriving (Eq, Show)
515+ | ParamFormData
516+ deriving (Eq, Show, Generic, Data, Typeable)
345517
346518type Format = Text
347519
348520-- | Determines the format of the array.
349−data CollectionFormat
350− = CollectionCSV -- ^ Comma separated values: @foo,bar@.
351− | CollectionSSV -- ^ Space separated values: @foo bar@.
352− | CollectionTSV -- ^ Tab separated values: @foo\\tbar@.
353− | CollectionPipes -- ^ Pipe separated values: @foo|bar@.
354− | CollectionMulti -- ^ Corresponds to multiple parameter instances
355− -- instead of multiple values for a single instance @foo=bar&foo=baz@.
356− -- This is valid only for parameters in @'ParameterQuery'@ or @'ParameterFormData'@.
357− deriving (Eq, Show)
358−
359−data ItemsType
360− = ItemsString
361− | ItemsNumber
362− | ItemsInteger
363− | ItemsBoolean
364− | ItemsArray
365− deriving (Eq, Show)
366−
367−data SchemaType
368− = SchemaArray
369− | SchemaBoolean
370− | SchemaInteger
371− | SchemaNumber
372− | SchemaNull
373− | SchemaObject
374− | SchemaString
375− deriving (Eq, Show)
376−
377−-- | Determines the format of the nested array.
378−data ItemsCollectionFormat
379− = ItemsCollectionCSV -- ^ Comma separated values: @foo,bar@.
380− | ItemsCollectionSSV -- ^ Space separated values: @foo bar@.
381− | ItemsCollectionTSV -- ^ Tab separated values: @foo\\tbar@.
382− | ItemsCollectionPipes -- ^ Pipe separated values: @foo|bar@.
383− deriving (Eq, Show)
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)
384555
385556type ParamName = Text
386557
387558data Schema = Schema
388− { _schemaType :: SchemaType
389− , _schemaFormat :: Maybe Format
390− , _schemaTitle :: Maybe Text
559+ { _schemaTitle :: Maybe Text
391560 , _schemaDescription :: Maybe Text
392561 , _schemaRequired :: [ParamName]
393562
394− , _schemaItems :: Maybe SchemaItems
395− , _schemaAllOf :: Maybe [Schema]
396− , _schemaProperties :: HashMap Text (Referenced Schema)
397− , _schemaAdditionalProperties :: Maybe Schema
563+ , _schemaAllOf :: Maybe [Referenced Schema]
564+ , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
565+ , _schemaAdditionalProperties :: Maybe AdditionalProperties
398566
399567 , _schemaDiscriminator :: Maybe Text
400568 , _schemaReadOnly :: Maybe Bool
@@ -405,39 +573,49 @@ data Schema = Schema
405573 , _schemaMaxProperties :: Maybe Integer
406574 , _schemaMinProperties :: Maybe Integer
407575
408− , _schemaSchemaCommon :: SchemaCommon
409− } deriving (Eq, Show, Generic)
576+ , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema
577+ } deriving (Eq, Show, Generic, Data, Typeable)
410578
411−data SchemaItems
412− = SchemaItemsObject (Referenced Schema)
413− | SchemaItemsArray [Referenced Schema]
414− deriving (Eq, Show)
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)
415585
416−data SchemaCommon = SchemaCommon
586+-- | Regex pattern for @string@ type.
587+type Pattern = Text
588+
589+data ParamSchema (t :: SwaggerKind *) = ParamSchema
417590 { -- | Declares the value of the parameter that the server will use if none is provided,
418591 -- for example a @"count"@ to control the number of results per page might default to @100@
419592 -- if not supplied by the client in the request.
420593 -- (Note: "default" has no meaning for required parameters.)
421594 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
422− _schemaCommonDefault :: Maybe Value
423−
424− , _schemaCommonMaximum :: Maybe Scientific
425− , _schemaCommonExclusiveMaximum :: Maybe Bool
426− , _schemaCommonMinimum :: Maybe Scientific
427− , _schemaCommonExclusiveMinimum :: Maybe Bool
428− , _schemaCommonMaxLength :: Maybe Integer
429− , _schemaCommonMinLength :: Maybe Integer
430− , _schemaCommonPattern :: Maybe Text
431− , _schemaCommonMaxItems :: Maybe Integer
432− , _schemaCommonMinItems :: Maybe Integer
433− , _schemaCommonUniqueItems :: Maybe Bool
434− , _schemaCommonEnum :: Maybe [Value]
435− , _schemaCommonMultipleOf :: Maybe Scientific
436− } deriving (Eq, Show, Generic)
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)
437615
438616data Xml = Xml
439617 { -- | Replaces the name of the element/attribute used for the described schema property.
440− -- When defined within the @'Items'@ (items), it will affect the name of the individual XML elements within the list.
618+ -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list.
441619 -- When defined alongside type being array (outside the items),
442620 -- it will affect the wrapping element and only if wrapped is true.
443621 -- If wrapped is false, it will be ignored.
@@ -461,25 +639,7 @@ data Xml = Xml
461639 -- Default value is @False@.
462640 -- The definition takes effect only when defined alongside type being array (outside the items).
463641 , _xmlWrapped :: Maybe Bool
464− } deriving (Eq, Show, Generic)
465−
466−data Items = Items
467− { -- | The internal type of the array.
468− _itemsType :: ItemsType
469−
470− -- | The extending format for the previously mentioned type.
471− , _itemsFormat :: Maybe Format
472−
473− -- | __Required if type is @'ItemsArray'@.__
474− -- Describes the type of items in the array.
475− , _itemsItems :: Maybe Items
476−
477− -- | Determines the format of the array if type array is used.
478− -- Default value is @'ItemsCollectionCSV'@.
479− , _itemsCollectionFormat :: Maybe ItemsCollectionFormat
480−
481− , _itemsCommon :: SchemaCommon
482− } deriving (Eq, Show, Generic)
642+ } deriving (Eq, Show, Generic, Data, Typeable)
483643
484644-- | A container for the expected responses of an operation.
485645-- The container maps a HTTP response code to the expected response.
@@ -493,8 +653,8 @@ data Responses = Responses
493653
494654 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
495655 -- Describes the expected response for those HTTP status codes.
496− , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
497− } deriving (Eq, Show, Generic)
656+ , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)
657+ } deriving (Eq, Show, Generic, Data, Typeable)
498658
499659type HttpStatusCode = Int
500660
@@ -512,11 +672,14 @@ data Response = Response
512672 , _responseSchema :: Maybe (Referenced Schema)
513673
514674 -- | A list of headers that are sent with the response.
515− , _responseHeaders :: HashMap HeaderName Header
675+ , _responseHeaders :: InsOrdHashMap HeaderName Header
516676
517677 -- | An example of the response message.
518678 , _responseExamples :: Maybe Example
519− } deriving (Eq, Show, Generic)
679+ } deriving (Eq, Show, Generic, Data, Typeable)
680+
681+instance IsString Response where
682+ fromString s = Response (fromString s) Nothing mempty Nothing
520683
521684type HeaderName = Text
522685
@@ -524,31 +687,30 @@ data Header = Header
524687 { -- | A short description of the header.
525688 _headerDescription :: Maybe Text
526689
527− -- | The type of the object.
528− , _headerType :: ItemsType
529−
530− -- | The extending format for the previously mentioned type. See Data Type Formats for further details.
531− , _headerFormat :: Maybe Format
690+ , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)
691+ } deriving (Eq, Show, Generic, Data, Typeable)
532692
533− -- | __Required if type is @'ItemsArray'@__.
534− -- Describes the type of items in the array.
535− , _headerItems :: Maybe Items
693+data Example = Example { getExample :: Map MediaType Value }
694+ deriving (Eq, Show, Generic, Typeable)
536695
537− -- | Determines the format of the array if type array is used.
538− -- Default value is @'ItemsCollectionCSV'@.
539− , _headerCollectionFormat :: Maybe ItemsCollectionFormat
696+exampleConstr :: Constr
697+exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix
540698
541− , _headerCommon :: SchemaCommon
542− } deriving (Eq, Show, Generic)
699+exampleDataType :: DataType
700+exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr]
543701
544−data Example = Example { getExample :: Map MediaType Value }
545− deriving (Eq, Show)
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
546708
547709-- | The location of the API key.
548710data ApiKeyLocation
549711 = ApiKeyQuery
550712 | ApiKeyHeader
551− deriving (Eq, Show)
713+ deriving (Eq, Show, Generic, Data, Typeable)
552714
553715data ApiKeyParams = ApiKeyParams
554716 { -- | The name of the header or query parameter to be used.
@@ -556,7 +718,7 @@ data ApiKeyParams = ApiKeyParams
556718
557719 -- | The location of the API key.
558720 , _apiKeyIn :: ApiKeyLocation
559− } deriving (Eq, Show)
721+ } deriving (Eq, Show, Generic, Data, Typeable)
560722
561723-- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
562724type AuthorizationURL = Text
@@ -569,21 +731,21 @@ data OAuth2Flow
569731 | OAuth2Password TokenURL
570732 | OAuth2Application TokenURL
571733 | OAuth2AccessCode AuthorizationURL TokenURL
572− deriving (Eq, Show)
734+ deriving (Eq, Show, Generic, Data, Typeable)
573735
574736data OAuth2Params = OAuth2Params
575737 { -- | The flow used by the OAuth2 security scheme.
576738 _oauth2Flow :: OAuth2Flow
577739
578740 -- | The available scopes for the OAuth2 security scheme.
579− , _oauth2Scopes :: HashMap Text Text
580− } deriving (Eq, Show, Generic)
741+ , _oauth2Scopes :: InsOrdHashMap Text Text
742+ } deriving (Eq, Show, Generic, Data, Typeable)
581743
582744data SecuritySchemeType
583745 = SecuritySchemeBasic
584746 | SecuritySchemeApiKey ApiKeyParams
585747 | SecuritySchemeOAuth2 OAuth2Params
586− deriving (Eq, Show)
748+ deriving (Eq, Show, Generic, Data, Typeable)
587749
588750data SecurityScheme = SecurityScheme
589751 { -- | The type of the security scheme.
@@ -591,20 +753,39 @@ data SecurityScheme = SecurityScheme
591753
592754 -- | A short description for security scheme.
593755 , _securitySchemeDescription :: Maybe Text
594− } deriving (Eq, Show, Generic)
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)
595773
596774-- | Lists the required security schemes to execute this operation.
597775-- The object can have multiple security schemes declared in it which are all required
598776-- (that is, there is a logical AND between the schemes).
599777newtype SecurityRequirement = SecurityRequirement
600− { getSecurityRequirement :: HashMap Text [Text]
601− } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON)
778+ { getSecurityRequirement :: InsOrdHashMap Text [Text]
779+ } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
780+
781+-- | Tag name.
782+type TagName = Text
602783
603784-- | Allows adding meta data to a single tag that is used by @Operation@.
604785-- It is not mandatory to have a @Tag@ per tag used there.
605786data Tag = Tag
606787 { -- | The name of the tag.
607− _tagName :: Text
788+ _tagName :: TagName
608789
609790 -- | A short description for the tag.
610791 -- GFM syntax can be used for rich text representation.
@@ -612,7 +793,12 @@ data Tag = Tag
612793
613794 -- | Additional external documentation for this tag.
614795 , _tagExternalDocs :: Maybe ExternalDocs
615− } deriving (Eq, Show)
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
616802
617803-- | Allows referencing an external resource for extended documentation.
618804data ExternalDocs = ExternalDocs
@@ -622,170 +808,236 @@ data ExternalDocs = ExternalDocs
622808
623809 -- | The URL for the target documentation.
624810 , _externalDocsUrl :: URL
625− } deriving (Eq, Show, Generic)
811+ } deriving (Eq, Ord, Show, Generic, Data, Typeable)
812+
813+instance Hashable ExternalDocs
626814
627815-- | A simple object to allow referencing other definitions in the specification.
628816-- It can be used to reference parameters and responses that are defined at the top level for reuse.
629817newtype Reference = Reference { getReference :: Text }
630− deriving (Eq, Show)
818+ deriving (Eq, Show, Data, Typeable)
631819
632820data Referenced a
633821 = Ref Reference
634822 | Inline a
635− deriving (Eq, Show)
823+ deriving (Eq, Show, Functor, Data, Typeable)
824+
825+instance IsString a => IsString (Referenced a) where
826+ fromString = Inline . fromString
636827
637−newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON)
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)
638834
639835-- =======================================================================
640836-- Monoid instances
641837-- =======================================================================
642838
839+instance Semigroup Swagger where
840+ (<>) = genericMappend
643841instance Monoid Swagger where
644842 mempty = genericMempty
645− mappend = genericMappend
843+ mappend = (<>)
646844
845+instance Semigroup Info where
846+ (<>) = genericMappend
647847instance Monoid Info where
648848 mempty = genericMempty
649− mappend = genericMappend
849+ mappend = (<>)
650850
651−instance Monoid Paths where
851+instance Semigroup Contact where
852+ (<>) = genericMappend
853+instance Monoid Contact where
652854 mempty = genericMempty
653− mappend = genericMappend
855+ mappend = (<>)
654856
857+instance Semigroup PathItem where
858+ (<>) = genericMappend
655859instance Monoid PathItem where
656860 mempty = genericMempty
657− mappend = genericMappend
861+ mappend = (<>)
658862
863+instance Semigroup Schema where
864+ (<>) = genericMappend
659865instance Monoid Schema where
660866 mempty = genericMempty
661− mappend = genericMappend
867+ mappend = (<>)
868+
869+instance Semigroup (ParamSchema t) where
870+ (<>) = genericMappend
871+instance Monoid (ParamSchema t) where
872+ mempty = genericMempty
873+ mappend = (<>)
662874
663−instance Monoid SchemaCommon where
875+instance Semigroup Param where
876+ (<>) = genericMappend
877+instance Monoid Param where
664878 mempty = genericMempty
665− mappend = genericMappend
879+ mappend = (<>)
666880
667−instance Monoid Parameter where
881+instance Semigroup ParamOtherSchema where
882+ (<>) = genericMappend
883+instance Monoid ParamOtherSchema where
668884 mempty = genericMempty
669− mappend = genericMappend
885+ mappend = (<>)
670886
671−instance Monoid ParameterOtherSchema where
887+instance Semigroup Header where
888+ (<>) = genericMappend
889+instance Monoid Header where
672890 mempty = genericMempty
673− mappend = genericMappend
891+ mappend = (<>)
674892
893+instance Semigroup Responses where
894+ (<>) = genericMappend
675895instance Monoid Responses where
676896 mempty = genericMempty
677− mappend = genericMappend
897+ mappend = (<>)
678898
899+instance Semigroup Response where
900+ (<>) = genericMappend
679901instance Monoid Response where
680902 mempty = genericMempty
681− mappend = genericMappend
903+ mappend = (<>)
682904
905+instance Semigroup ExternalDocs where
906+ (<>) = genericMappend
683907instance Monoid ExternalDocs where
684908 mempty = genericMempty
685− mappend = genericMappend
909+ mappend = (<>)
686910
911+instance Semigroup Operation where
912+ (<>) = genericMappend
687913instance Monoid Operation where
688914 mempty = genericMempty
689− mappend = genericMappend
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 = (<>)
690933
691934-- =======================================================================
692935-- SwaggerMonoid helper instances
693936-- =======================================================================
694937
695938instance SwaggerMonoid Info
696−instance SwaggerMonoid Paths
697939instance SwaggerMonoid PathItem
698940instance SwaggerMonoid Schema
699−instance SwaggerMonoid SchemaCommon
700−instance SwaggerMonoid Parameter
701−instance SwaggerMonoid ParameterOtherSchema
941+instance SwaggerMonoid (ParamSchema t)
942+instance SwaggerMonoid Param
943+instance SwaggerMonoid ParamOtherSchema
702944instance SwaggerMonoid Responses
703945instance SwaggerMonoid Response
704946instance SwaggerMonoid ExternalDocs
705947instance SwaggerMonoid Operation
948+instance SwaggerMonoid SecurityDefinitions
949+instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
706950
707951instance SwaggerMonoid MimeList
708952deriving instance SwaggerMonoid URL
709953
710−instance SwaggerMonoid SchemaType where
711− swaggerMempty = SchemaNull
954+instance SwaggerMonoid (SwaggerType t) where
955+ swaggerMempty = SwaggerString
712956 swaggerMappend _ y = y
713957
714−instance SwaggerMonoid ParameterType where
715− swaggerMempty = ParamString
958+instance SwaggerMonoid ParamLocation where
959+ swaggerMempty = ParamQuery
716960 swaggerMappend _ y = y
717961
718−instance SwaggerMonoid ParameterLocation where
719− swaggerMempty = ParameterQuery
720− swaggerMappend _ y = y
721−
722−instance SwaggerMonoid (HashMap Text Schema) where
723− swaggerMempty = HashMap.empty
724− swaggerMappend = HashMap.unionWith mappend
725−
726−instance SwaggerMonoid (HashMap Text (Referenced Schema)) where
727− swaggerMempty = HashMap.empty
728− swaggerMappend = HashMap.unionWith swaggerMappend
962+instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
963+ swaggerMempty = InsOrdHashMap.empty
964+ swaggerMappend = InsOrdHashMap.unionWith mappend
729965
730966instance Monoid a => SwaggerMonoid (Referenced a) where
731967 swaggerMempty = Inline mempty
732− swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
968+ swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
733969 swaggerMappend _ y = y
734970
735−instance SwaggerMonoid (HashMap Text Parameter) where
736− swaggerMempty = HashMap.empty
737− swaggerMappend = HashMap.unionWith mappend
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
738976
739−instance SwaggerMonoid (HashMap Text Response) where
740− swaggerMempty = HashMap.empty
741− swaggerMappend = flip HashMap.union
977+-- =======================================================================
978+-- Simple Generic-based ToJSON instances
979+-- =======================================================================
742980
743−instance SwaggerMonoid (HashMap Text SecurityScheme) where
744− swaggerMempty = HashMap.empty
745− swaggerMappend = flip HashMap.union
981+instance ToJSON ParamLocation where
982+ toJSON = genericToJSON (jsonPrefix "Param")
746983
747−instance SwaggerMonoid (HashMap FilePath PathItem) where
748− swaggerMempty = HashMap.empty
749− swaggerMappend = HashMap.unionWith mappend
984+instance ToJSON Info where
985+ toJSON = genericToJSON (jsonPrefix "Info")
750986
751−instance SwaggerMonoid (HashMap HeaderName Header) where
752− swaggerMempty = HashMap.empty
753− swaggerMappend = flip HashMap.union
987+instance ToJSON Contact where
988+ toJSON = genericToJSON (jsonPrefix "Contact")
754989
755−instance SwaggerMonoid (HashMap HttpStatusCode (Referenced Response)) where
756− swaggerMempty = HashMap.empty
757− swaggerMappend = flip HashMap.union
990+instance ToJSON License where
991+ toJSON = genericToJSON (jsonPrefix "License")
758992
759−instance SwaggerMonoid ParameterSchema where
760− swaggerMempty = ParameterOther swaggerMempty
761− swaggerMappend (ParameterBody x) (ParameterBody y) = ParameterBody (swaggerMappend x y)
762− swaggerMappend (ParameterOther x) (ParameterOther y) = ParameterOther (swaggerMappend x y)
763− swaggerMappend _ y = y
993+instance ToJSON ApiKeyLocation where
994+ toJSON = genericToJSON (jsonPrefix "ApiKey")
995+
996+instance ToJSON ApiKeyParams where
997+ toJSON = genericToJSON (jsonPrefix "apiKey")
998+
999+instance ToJSON Scheme where
1000+ toJSON = genericToJSON (jsonPrefix "")
1001+
1002+instance ToJSON Tag where
1003+ toJSON = genericToJSON (jsonPrefix "Tag")
1004+
1005+instance ToJSON ExternalDocs where
1006+ toJSON = genericToJSON (jsonPrefix "ExternalDocs")
1007+
1008+instance ToJSON Xml where
1009+ toJSON = genericToJSON (jsonPrefix "Xml")
7641010
7651011-- =======================================================================
766−-- TH derived ToJSON and FromJSON instances
1012+-- Simple Generic-based FromJSON instances
7671013-- =======================================================================
7681014
769−deriveJSON (jsonPrefix "Parameter") ''ParameterLocation
770−deriveJSON (jsonPrefix "Param") ''ParameterType
771−deriveJSON' ''Info
772−deriveJSON' ''Contact
773−deriveJSON' ''License
774−deriveJSON (jsonPrefix "Schema") ''SchemaType
775−deriveJSON (jsonPrefix "Items") ''ItemsType
776−deriveJSON (jsonPrefix "ItemsCollection") ''ItemsCollectionFormat
777−deriveJSON (jsonPrefix "Collection") ''CollectionFormat
778−deriveJSON (jsonPrefix "ApiKey") ''ApiKeyLocation
779−deriveJSON (jsonPrefix "apiKey") ''ApiKeyParams
780−deriveJSON' ''SchemaCommon
781−deriveJSONDefault ''Scheme
782−deriveJSON' ''Tag
783−deriveJSON' ''ExternalDocs
784−
785−deriveToJSON' ''Operation
786−deriveToJSON' ''Response
787−deriveToJSON' ''PathItem
788−deriveToJSON' ''Xml
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")
7891041
7901042-- =======================================================================
7911043-- Manual ToJSON instances
@@ -807,7 +1059,8 @@ instance ToJSON OAuth2Flow where
8071059 , "tokenUrl" .= tokenUrl ]
8081060
8091061instance ToJSON OAuth2Params where
810− toJSON = genericToJSONWithSub "flow" (jsonPrefix "oauth2")
1062+ toJSON = sopSwaggerGenericToJSON
1063+ DEFINE_TOENCODING
8111064
8121065instance ToJSON SecuritySchemeType where
8131066 toJSON SecuritySchemeBasic
@@ -820,22 +1073,38 @@ instance ToJSON SecuritySchemeType where
8201073 <+> object [ "type" .= ("oauth2" :: Text) ]
8211074
8221075instance ToJSON Swagger where
823− toJSON = addVersion . genericToJSON (jsonPrefix "")
824− where
825− addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
826− addVersion _ = error "impossible"
1076+ toJSON = sopSwaggerGenericToJSON
1077+ DEFINE_TOENCODING
8271078
8281079instance ToJSON SecurityScheme where
829− toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
1080+ toJSON = sopSwaggerGenericToJSON
1081+ DEFINE_TOENCODING
8301082
8311083instance ToJSON Schema where
832− toJSON = genericToJSONWithSub "schemaCommon" (jsonPrefix "schema")
1084+ toJSON = sopSwaggerGenericToJSON
1085+ DEFINE_TOENCODING
8331086
8341087instance ToJSON Header where
835− toJSON = genericToJSONWithSub "common" (jsonPrefix "header")
836−
837−instance ToJSON Items where
838− toJSON = genericToJSONWithSub "common" (jsonPrefix "items")
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 ]
8391108
8401109instance ToJSON Host where
8411110 toJSON (Host host mport) = toJSON $
@@ -843,38 +1112,79 @@ instance ToJSON Host where
8431112 Nothing -> host
8441113 Just port -> host ++ ":" ++ show port
8451114
846−instance ToJSON Paths where
847− toJSON (Paths m) = toJSON m
848−
8491115instance ToJSON MimeList where
8501116 toJSON (MimeList xs) = toJSON (map show xs)
8511117
852−instance ToJSON Parameter where
853− toJSON = genericToJSONWithSub "schema" (jsonPrefix "parameter")
1118+instance ToJSON Param where
1119+ toJSON = sopSwaggerGenericToJSON
1120+ DEFINE_TOENCODING
8541121
855−instance ToJSON ParameterSchema where
856− toJSON (ParameterBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
857− toJSON (ParameterOther s) = toJSON s
1122+instance ToJSON ParamAnySchema where
1123+ toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
1124+ toJSON (ParamOther s) = toJSON s
8581125
859−instance ToJSON ParameterOtherSchema where
860− toJSON = genericToJSONWithSub "common" (jsonPrefix "parameterOtherSchema")
861−
862−instance ToJSON SchemaItems where
863− toJSON (SchemaItemsObject x) = toJSON x
864− toJSON (SchemaItemsArray xs) = toJSON xs
1126+instance ToJSON ParamOtherSchema where
1127+ toJSON = sopSwaggerGenericToJSON
1128+ DEFINE_TOENCODING
8651129
8661130instance ToJSON Responses where
867− toJSON (Responses def rs) = toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
1131+ toJSON = sopSwaggerGenericToJSON
1132+ DEFINE_TOENCODING
1133+
1134+instance ToJSON Response where
1135+ toJSON = sopSwaggerGenericToJSON
1136+ DEFINE_TOENCODING
1137+
1138+instance ToJSON Operation where
1139+ toJSON = sopSwaggerGenericToJSON
1140+ DEFINE_TOENCODING
1141+
1142+instance ToJSON PathItem where
1143+ toJSON = sopSwaggerGenericToJSON
1144+ DEFINE_TOENCODING
8681145
8691146instance ToJSON Example where
8701147 toJSON = toJSON . Map.mapKeys show . getExample
8711148
1149+instance ToJSON SecurityDefinitions where
1150+ toJSON (SecurityDefinitions sd) = toJSON sd
1151+
8721152instance ToJSON Reference where
8731153 toJSON (Reference ref) = object [ "$ref" .= ref ]
8741154
875−instance ToJSON a => ToJSON (Referenced a) where
876− toJSON (Ref ref) = toJSON ref
877− toJSON (Inline x) = toJSON x
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
8781188
8791189-- =======================================================================
8801190-- Manual FromJSON instances
@@ -894,117 +1204,224 @@ instance FromJSON OAuth2Flow where
8941204 parseJSON _ = empty
8951205
8961206instance FromJSON OAuth2Params where
897− parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
1207+ parseJSON = sopSwaggerGenericParseJSON
8981208
8991209instance FromJSON SecuritySchemeType where
900− parseJSON json@(Object o) = do
1210+ parseJSON js@(Object o) = do
9011211 (t :: Text) <- o .: "type"
9021212 case t of
9031213 "basic" -> pure SecuritySchemeBasic
904− "apiKey" -> SecuritySchemeApiKey <$> parseJSON json
905− "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON json
1214+ "apiKey" -> SecuritySchemeApiKey <$> parseJSON js
1215+ "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js
9061216 _ -> empty
9071217 parseJSON _ = empty
9081218
9091219instance FromJSON Swagger where
910− parseJSON json@(Object o) = do
911− (version :: Text) <- o .: "swagger"
912− when (version /= "2.0") empty
913− (genericParseJSON (jsonPrefix "")
914− `withDefaults` [ "consumes" .= (mempty :: MimeList)
915− , "produces" .= (mempty :: MimeList)
916− , "security" .= ([] :: [SecurityRequirement])
917− , "tags" .= ([] :: [Tag])
918− , "definitions" .= (mempty :: HashMap Text Schema)
919− , "parameters" .= (mempty :: HashMap Text Parameter)
920− , "responses" .= (mempty :: HashMap Text Response)
921− , "securityDefinitions" .= (mempty :: HashMap Text SecurityScheme)
922− ] ) json
923− parseJSON _ = empty
1220+ parseJSON = sopSwaggerGenericParseJSON
9241221
9251222instance FromJSON SecurityScheme where
926− parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
1223+ parseJSON = sopSwaggerGenericParseJSON
9271224
9281225instance FromJSON Schema where
929− parseJSON = genericParseJSONWithSub "schemaCommon" (jsonPrefix "schema")
930− `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
931− , "required" .= ([] :: [ParamName]) ]
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
9321233
9331234instance FromJSON Header where
934− parseJSON = genericParseJSONWithSub "common" (jsonPrefix "header")
935−
936−instance FromJSON Items where
937− parseJSON = genericParseJSONWithSub "common" (jsonPrefix "items")
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
9381264
9391265instance FromJSON Host where
940− parseJSON (String s) =
941− case fromInteger <$> readMaybe portStr of
942− Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'"
943− mport -> pure $ Host host mport
944− where
945− (hostText, portText) = Text.breakOn ":" s
946− [host, portStr] = map Text.unpack [hostText, portText]
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 ++ "'"
9471272 parseJSON _ = empty
9481273
949−instance FromJSON Paths where
950− parseJSON json = Paths <$> parseJSON json
951−
9521274instance FromJSON MimeList where
953− parseJSON json = (MimeList . map fromString) <$> parseJSON json
1275+ parseJSON js = (MimeList . map fromString) <$> parseJSON js
9541276
955−instance FromJSON Parameter where
956− parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "parameter")
1277+instance FromJSON Param where
1278+ parseJSON = sopSwaggerGenericParseJSON
9571279
958−instance FromJSON ParameterSchema where
959− parseJSON json@(Object o) = do
1280+instance FromJSON ParamAnySchema where
1281+ parseJSON js@(Object o) = do
9601282 (i :: Text) <- o .: "in"
9611283 case i of
9621284 "body" -> do
9631285 schema <- o .: "schema"
964− ParameterBody <$> parseJSON schema
965− _ -> ParameterOther <$> parseJSON json
1286+ ParamBody <$> parseJSON schema
1287+ _ -> ParamOther <$> parseJSON js
9661288 parseJSON _ = empty
9671289
968−instance FromJSON ParameterOtherSchema where
969− parseJSON = genericParseJSONWithSub "common" (jsonPrefix "parameterOtherSchema")
970−
971−instance FromJSON SchemaItems where
972− parseJSON json@(Object _) = SchemaItemsObject <$> parseJSON json
973− parseJSON json@(Array _) = SchemaItemsArray <$> parseJSON json
974− parseJSON _ = empty
1290+instance FromJSON ParamOtherSchema where
1291+ parseJSON = sopSwaggerGenericParseJSON
9751292
9761293instance FromJSON Responses where
9771294 parseJSON (Object o) = Responses
9781295 <$> o .:? "default"
979− <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
1296+ <*> (parseJSON (Object (HashMap.delete "default" o)))
9801297 parseJSON _ = empty
9811298
9821299instance FromJSON Example where
983− parseJSON json = do
984− m <- parseJSON json
1300+ parseJSON js = do
1301+ m <- parseJSON js
9851302 pure $ Example (Map.mapKeys fromString m)
9861303
9871304instance FromJSON Response where
988− parseJSON = genericParseJSON (jsonPrefix "response")
989− `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
1305+ parseJSON = sopSwaggerGenericParseJSON
9901306
9911307instance FromJSON Operation where
992− parseJSON = genericParseJSON (jsonPrefix "operation")
993− `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) ]
1308+ parseJSON = sopSwaggerGenericParseJSON
9941309
9951310instance FromJSON PathItem where
996− parseJSON = genericParseJSON (jsonPrefix "pathItem")
997− `withDefaults` [ "parameters" .= ([] :: [Parameter]) ]
1311+ parseJSON = sopSwaggerGenericParseJSON
1312+
1313+instance FromJSON SecurityDefinitions where
1314+ parseJSON js = SecurityDefinitions <$> parseJSON js
9981315
9991316instance FromJSON Reference where
10001317 parseJSON (Object o) = Reference <$> o .: "$ref"
10011318 parseJSON _ = empty
10021319
1003−instance FromJSON a => FromJSON (Referenced a) where
1004− parseJSON json
1005− = Ref <$> parseJSON json
1006− <|> Inline <$> parseJSON json
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/"
10071336
10081337instance FromJSON Xml where
10091338 parseJSON = genericParseJSON (jsonPrefix "xml")
10101339
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.hsnew file+346
@@ -0,0 +1,346 @@
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.hsnew file+337
@@ -0,0 +1,337 @@
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.hsnew file+882
@@ -0,0 +1,882 @@
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.hsnew file+511
@@ -0,0 +1,511 @@
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.hsnew file+66
@@ -0,0 +1,66 @@
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+52−42
@@ -1,35 +1,55 @@
11{-# LANGUAGE DefaultSignatures #-}
22{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
34{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RankNTypes #-}
46{-# LANGUAGE TypeOperators #-}
57module Data.Swagger.Internal.Utils where
68
7−import Control.Arrow (first)
8−import Control.Applicative
9+import Prelude ()
10+import Prelude.Compat
11+
12+import Control.Lens ((&), (%~))
13+import Control.Lens.TH
914import Data.Aeson
10−import Data.Aeson.TH
11−import Data.Aeson.Types (Parser, Pair)
15+import Data.Aeson.Types
1216import Data.Char
17+import Data.Data
1318import Data.Hashable (Hashable)
1419import Data.HashMap.Strict (HashMap)
1520import qualified Data.HashMap.Strict as HashMap
16−import Data.Monoid
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)
1725import Data.Text (Text)
18−import Data.Traversable
1926import GHC.Generics
20−import Language.Haskell.TH
21−import Text.Read (readMaybe)
22−
23−hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v
24−hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList
27+import Language.Haskell.TH (mkName)
2528
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
29+swaggerFieldRules :: LensRules
30+swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
2831 where
29− g (x, y) = (\a -> (a, y)) <$> f x
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)
37+
38+ fixName = mkName . fixName' . show
3039
31−hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)
32−hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)
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
48+
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 ++ "."
3353
3454jsonPrefix :: String -> Options
3555jsonPrefix prefix = defaultOptions
@@ -44,37 +64,18 @@ jsonPrefix prefix = defaultOptions
4464 lowerFirstUppers s = map toLower x ++ y
4565 where (x, y) = span isUpper s
4666
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
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
6672 where
67− json = Object (HashMap.insert sub (Object o) o)
68−genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"
73+ ys = zip (map toJSON xs) xs
6974
7075(<+>) :: Value -> Value -> Value
7176Object x <+> Object y = Object (x <> y)
7277_ <+> _ = error "<+>: merging non-objects"
7378
74−withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
75−withDefaults parser defs json@(Object _) = parser (json <+> object defs)
76−withDefaults _ _ _ = empty
77−
7879genericMempty :: (Generic a, GMonoid (Rep a)) => a
7980genericMempty = to gmempty
8081
@@ -110,6 +111,16 @@ class SwaggerMonoid m where
110111 swaggerMappend = mappend
111112
112113instance 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)
113124
114125instance SwaggerMonoid Text where
115126 swaggerMempty = mempty
@@ -120,4 +131,3 @@ instance SwaggerMonoid (Maybe a) where
120131 swaggerMempty = Nothing
121132 swaggerMappend x Nothing = x
122133 swaggerMappend _ y = y
123−
src/Data/Swagger/Lens.hs+173−95
@@ -1,108 +1,186 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleContexts #-}
13{-# LANGUAGE FlexibleInstances #-}
24{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE GADTs #-}
36{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
48{-# 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.
520module Data.Swagger.Lens where
621
722import Control.Lens
8−import Control.Lens.TH
923import Data.Aeson (Value)
1024import Data.Scientific (Scientific)
1125import Data.Swagger.Internal
26+import Data.Swagger.Internal.Utils
1227import Data.Text (Text)
1328
14−-- =======================================================================
15−-- TH derived lenses
16−-- =======================================================================
17−
18−makeLenses ''Swagger
19−makeLenses ''Host
20−makeLenses ''Info
21−makeLenses ''Contact
22−makeLenses ''License
23−makeLenses ''Paths
24−makeLenses ''PathItem
25−makeLenses ''Tag
26−makeLenses ''Operation
27−makeLenses ''Parameter
28−makePrisms ''ParameterSchema
29−makeLenses ''ParameterOtherSchema
30−makeLenses ''Items
31−makeLenses ''Header
32−makeLenses ''Schema
33−makePrisms ''SchemaItems
34−makeLenses ''SchemaCommon
35−makeLenses ''Xml
36−makeLenses ''Responses
37−makeLenses ''Response
38−makeLenses ''SecurityScheme
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
3957makePrisms ''SecuritySchemeType
40−makeLenses ''ApiKeyParams
41−makeLenses ''OAuth2Params
42−makeLenses ''ExternalDocs
43−
44−-- =======================================================================
45−-- Helper classy lenses
46−-- =======================================================================
47−
48−class HasDescription s d | s -> d where
49− description :: Lens' s d
50−
51−instance HasDescription Response Text where description = responseDescription
52−instance HasDescription Info (Maybe Text) where description = infoDescription
53−instance HasDescription Tag (Maybe Text) where description = tagDescription
54−instance HasDescription Operation (Maybe Text) where description = operationDescription
55−instance HasDescription Parameter (Maybe Text) where description = parameterDescription
56−instance HasDescription Header (Maybe Text) where description = headerDescription
57−instance HasDescription Schema (Maybe Text) where description = schemaDescription
58−instance HasDescription SecurityScheme (Maybe Text) where description = securitySchemeDescription
59−instance HasDescription ExternalDocs (Maybe Text) where description = externalDocsDescription
60−
61−class HasSchemaCommon s where
62− schemaCommon :: Lens' s SchemaCommon
63−
64−instance HasSchemaCommon Schema where schemaCommon = schemaSchemaCommon
65−instance HasSchemaCommon ParameterOtherSchema where schemaCommon = parameterOtherSchemaCommon
66−instance HasSchemaCommon Items where schemaCommon = itemsCommon
67−instance HasSchemaCommon Header where schemaCommon = headerCommon
68−instance HasSchemaCommon SchemaCommon where schemaCommon = id
69−
70−schemaDefault :: HasSchemaCommon s => Lens' s (Maybe Value)
71−schemaDefault = schemaCommon.schemaCommonDefault
72−
73−schemaMaximum :: HasSchemaCommon s => Lens' s (Maybe Scientific)
74−schemaMaximum = schemaCommon.schemaCommonMaximum
75−
76−schemaExclusiveMaximum :: HasSchemaCommon s => Lens' s (Maybe Bool)
77−schemaExclusiveMaximum = schemaCommon.schemaCommonExclusiveMaximum
78−
79−schemaMinimum :: HasSchemaCommon s => Lens' s (Maybe Scientific)
80−schemaMinimum = schemaCommon.schemaCommonMinimum
81−
82−schemaExclusiveMinimum :: HasSchemaCommon s => Lens' s (Maybe Bool)
83−schemaExclusiveMinimum = schemaCommon.schemaCommonExclusiveMinimum
84−
85−schemaMaxLength :: HasSchemaCommon s => Lens' s (Maybe Integer)
86−schemaMaxLength = schemaCommon.schemaCommonMaxLength
87−
88−schemaMinLength :: HasSchemaCommon s => Lens' s (Maybe Integer)
89−schemaMinLength = schemaCommon.schemaCommonMinLength
90−
91−schemaPattern :: HasSchemaCommon s => Lens' s (Maybe Text)
92−schemaPattern = schemaCommon.schemaCommonPattern
93−
94−schemaMaxItems :: HasSchemaCommon s => Lens' s (Maybe Integer)
95−schemaMaxItems = schemaCommon.schemaCommonMaxItems
96−
97−schemaMinItems :: HasSchemaCommon s => Lens' s (Maybe Integer)
98−schemaMinItems = schemaCommon.schemaCommonMinItems
99−
100−schemaUniqueItems :: HasSchemaCommon s => Lens' s (Maybe Bool)
101−schemaUniqueItems = schemaCommon.schemaCommonUniqueItems
102−
103−schemaEnum :: HasSchemaCommon s => Lens' s (Maybe [Value])
104−schemaEnum = schemaCommon.schemaCommonEnum
105−
106−schemaMultipleOf :: HasSchemaCommon s => Lens' s (Maybe Scientific)
107−schemaMultipleOf = schemaCommon.schemaCommonMultipleOf
108−
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
src/Data/Swagger/Operation.hsnew file+193
@@ -0,0 +1,193 @@
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.hsnew file+597
@@ -0,0 +1,597 @@
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.hsnew file+26
@@ -0,0 +1,26 @@
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+39−6
@@ -1,7 +1,5 @@
11-- |
22-- Module: Data.Swagger.Schema
3−-- Copyright: (c) 2015 GetShopTV
4−-- License: BSD3
53-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
64-- Stability: experimental
75--
@@ -9,20 +7,55 @@
97module Data.Swagger.Schema (
108 -- * Encoding
119 ToSchema(..),
12− NamedSchema,
10+ declareSchema,
11+ declareSchemaRef,
1312 toSchema,
1413 toSchemaRef,
1514 schemaName,
15+ toInlinedSchema,
1616
1717 -- * Generic schema encoding
18− genericToSchema,
19− genericToNamedSchema,
18+ genericDeclareNamedSchema,
19+ genericDeclareSchema,
20+ genericDeclareNamedSchemaNewtype,
21+ genericNameSchema,
22+
23+ -- ** 'Bounded' 'Integral'
2024 genericToNamedSchemaBoundedIntegral,
2125 toSchemaBoundedIntegral,
2226
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+
2354 -- * Generic encoding configuration
2455 SchemaOptions(..),
2556 defaultSchemaOptions,
57+ fromAesonOptions,
2658) where
2759
28−import Data.Swagger.Schema.Internal
60+import Data.Swagger.Internal.Schema
61+import Data.Swagger.SchemaOptions
src/Data/Swagger/Schema/Generator.hsnew file+114
@@ -0,0 +1,114 @@
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.hsdeleted−390
@@ -1,390 +0,0 @@
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 TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE TypeSynonymInstances #-}
12−module Data.Swagger.Schema.Internal where
13−
14−import Control.Lens
15−import Data.Aeson
16−import Data.Char
17−import Data.HashMap.Strict (HashMap)
18−import Data.HashSet (HashSet)
19−import Data.Int
20−import Data.Map (Map)
21−import Data.Monoid
22−import Data.Proxy
23−import Data.Set (Set)
24−import qualified Data.Text as T
25−import qualified Data.Text.Lazy as TL
26−import Data.Word
27−import GHC.Generics
28−
29−import Data.Swagger.Internal
30−import Data.Swagger.Lens
31−
32−-- | A @'Schema'@ with an optional name.
33−-- This name can be used in references.
34−type NamedSchema = (Maybe String, Schema)
35−
36−unnamed :: Schema -> NamedSchema
37−unnamed schema = (Nothing, schema)
38−
39−named :: String -> Schema -> NamedSchema
40−named name schema = (Just name, schema)
41−
42−-- | Convert a type into @'Schema'@.
43−--
44−-- An example type and instance:
45−--
46−-- @
47−-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
48−-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' as list
49−--
50−-- import Control.Lens
51−--
52−-- data Coord = Coord { x :: Double, y :: Double }
53−--
54−-- instance ToSchema Coord where
55−-- toNamedSchema = (Just \"Coord\", mempty
56−-- & schemaType .~ SchemaObject
57−-- & schemaProperties .~
58−-- [ ("x", toSchemaRef (Proxy :: Proxy Double))
59−-- , ("y", toSchemaRef (Proxy :: Proxy Double))
60−-- ]
61−-- & schemaRequired .~ [ "x", "y" ]
62−-- @
63−--
64−-- Instead of manually writing your @'ToSchema'@ instance you can
65−-- use a default generic implementation of @'toNamedSchema'@.
66−--
67−-- To do that, simply add @deriving 'Generic'@ clause to your datatype
68−-- and declare a @'ToSchema'@ instance for your datatype without
69−-- giving definition for @'toNamedSchema'@.
70−--
71−-- For instance, the previous example can be simplified into this:
72−--
73−-- @
74−-- {-\# LANGUAGE DeriveGeneric \#-}
75−--
76−-- import GHC.Generics (Generic)
77−--
78−-- data Coord = Coord { x :: Double, y :: Double } deriving Generic
79−--
80−-- instance ToSchema Coord
81−-- @
82−class ToSchema a where
83− -- | Convert a type into an optionally named schema.
84− toNamedSchema :: proxy a -> NamedSchema
85− default toNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> NamedSchema
86− toNamedSchema = genericToNamedSchema defaultSchemaOptions
87−
88−-- | Get type's schema name according to its @'ToSchema'@ instance.
89−schemaName :: ToSchema a => proxy a -> Maybe String
90−schemaName = fst . toNamedSchema
91−
92−-- | Convert a type into a schema.
93−toSchema :: ToSchema a => proxy a -> Schema
94−toSchema = snd . toNamedSchema
95−
96−-- | Convert a type into a referenced schema if possible.
97−-- Only named schemas can be references, nameless schemas are inlined.
98−toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
99−toSchemaRef proxy = case toNamedSchema proxy of
100− (Just name, _) -> Ref (Reference ("#/definitions/" <> T.pack name))
101− (_, schema) -> Inline schema
102−
103−class GToSchema (f :: * -> *) where
104− gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema
105−
106−gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema
107−gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
108−
109−instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
110− toNamedSchema _ = unnamed $ mempty
111− & schemaType .~ SchemaArray
112− & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
113−
114−instance {-# OVERLAPPING #-} ToSchema String where
115− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaString
116−
117−instance ToSchema Bool where
118− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaBoolean
119−
120−instance ToSchema Integer where
121− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaInteger
122−
123−instance ToSchema Int where toNamedSchema = unnamed . toSchemaBoundedIntegral
124−instance ToSchema Int8 where toNamedSchema = unnamed . toSchemaBoundedIntegral
125−instance ToSchema Int16 where toNamedSchema = unnamed . toSchemaBoundedIntegral
126−instance ToSchema Int32 where toNamedSchema = unnamed . toSchemaBoundedIntegral
127−instance ToSchema Int64 where toNamedSchema = unnamed . toSchemaBoundedIntegral
128−
129−instance ToSchema Word where toNamedSchema = unnamed . toSchemaBoundedIntegral
130−instance ToSchema Word8 where toNamedSchema = unnamed . toSchemaBoundedIntegral
131−instance ToSchema Word16 where toNamedSchema = unnamed . toSchemaBoundedIntegral
132−instance ToSchema Word32 where toNamedSchema = unnamed . toSchemaBoundedIntegral
133−instance ToSchema Word64 where toNamedSchema = unnamed . toSchemaBoundedIntegral
134−
135−instance ToSchema Double where
136− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
137−
138−instance ToSchema Float where
139− toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
140−
141−instance ToSchema a => ToSchema (Maybe a) where
142− toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
143−
144−instance ToSchema ()
145−instance (ToSchema a, ToSchema b) => ToSchema (a, b)
146−instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
147−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
148−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
149−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
150−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
151−
152−instance ToSchema T.Text where
153− toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String)
154−
155−instance ToSchema TL.Text where
156− toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String)
157−
158−instance ToSchema a => ToSchema (Map String a) where
159− toNamedSchema _ = unnamed $ mempty
160− & schemaType .~ SchemaObject
161− & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
162−
163−instance ToSchema a => ToSchema (Map T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
164−instance ToSchema a => ToSchema (Map TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
165−
166−instance ToSchema a => ToSchema (HashMap String a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
167−instance ToSchema a => ToSchema (HashMap T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
168−instance ToSchema a => ToSchema (HashMap TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
169−
170−instance ToSchema a => ToSchema (Set a) where
171− toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy [a])
172− & schemaUniqueItems ?~ True
173−
174−instance ToSchema a => ToSchema (HashSet a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Set a))
175−
176−instance ToSchema All where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool)
177−instance ToSchema Any where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool)
178−instance ToSchema a => ToSchema (Sum a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
179−instance ToSchema a => ToSchema (Product a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
180−instance ToSchema a => ToSchema (First a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
181−instance ToSchema a => ToSchema (Last a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
182−instance ToSchema a => ToSchema (Dual a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
183−
184−-- | Options that specify how to encode your type to Swagger schema.
185−data SchemaOptions = SchemaOptions
186− { -- | Function applied to field labels. Handy for removing common record prefixes for example.
187− fieldLabelModifier :: String -> String
188− -- | Function applied to constructor tags which could be handy for lower-casing them for example.
189− , constructorTagModifier :: String -> String
190− -- | Function applied to datatype name.
191− , datatypeNameModifier :: String -> String
192− -- | If @'True'@ the constructors of a datatype, with all nullary constructors,
193− -- will be encoded to a string enumeration schema with the constructor tags as possible values.
194− , allNullaryToStringTag :: Bool
195− -- | If @'True'@ direct subschemas will be referenced if possible (rather than inlined).
196− -- Note that this option does not influence nested schemas, e.g. for these types
197− --
198− -- @
199− -- data Object = Object String deriving Generic
200− -- instance ToSchema Object
201− --
202− -- newtype Objects = Objects [Object] deriving Generic
203− -- instance ToSchema Objects where
204− -- toNamedSchema = genericToNamedSchema defaultSchemaOptions
205− -- { useReferences = False }
206− -- @
207− --
208− -- Schema for @Objects@ __will not__ inline @Object@ schema because
209− -- it is nested in a @[]@ schema.
210− , useReferences :: Bool
211− -- | Hide the field name when a record constructor has only one field, like a newtype.
212− , unwrapUnaryRecords :: Bool
213− }
214−
215−-- | Default encoding @'SchemaOptions'@.
216−--
217−-- @
218−-- 'SchemaOptions'
219−-- { 'fieldLabelModifier' = id
220−-- , 'constructorTagModifier' = id
221−-- , 'datatypeNameModifier' = id
222−-- , 'allNullaryToStringTag' = True
223−-- , 'useReferences' = True
224−-- , 'unwrapUnaryRecords' = False
225−-- }
226−-- @
227−defaultSchemaOptions :: SchemaOptions
228−defaultSchemaOptions = SchemaOptions
229− { fieldLabelModifier = id
230− , constructorTagModifier = id
231− , datatypeNameModifier = id
232− , allNullaryToStringTag = True
233− , useReferences = True
234− , unwrapUnaryRecords = False
235− }
236−
237−-- | Default schema for @'Bounded'@, @'Integral'@ types.
238−toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
239−toSchemaBoundedIntegral _ = mempty
240− & schemaType .~ SchemaInteger
241− & schemaMinimum ?~ fromInteger (toInteger (minBound :: a))
242− & schemaMaximum ?~ fromInteger (toInteger (maxBound :: a))
243−
244−-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
245−genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
246− ( Bounded a, Integral a
247− , Generic a, Rep a ~ D1 d f, Datatype d)
248− => SchemaOptions -> proxy a -> NamedSchema
249−genericToNamedSchemaBoundedIntegral opts proxy
250− = (gdatatypeSchemaName opts (Proxy :: Proxy d), toSchemaBoundedIntegral proxy)
251−
252−-- | A configurable generic @'Schema'@ creator.
253−genericToSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Schema
254−genericToSchema opts = snd . genericToNamedSchema opts
255−
256−-- | A configurable generic @'NamedSchema'@ creator.
257−-- This function applied to @'defaultSchemaOptions'@
258−-- is used as the default for @'toNamedSchema'@
259−-- when the type is an instance of @'Generic'@.
260−genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
261−genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
262−
263−gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String
264−gdatatypeSchemaName opts _ = case name of
265− (c:_) | isAlpha c && isUpper c -> Just name
266− _ -> Nothing
267− where
268− name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
269−
270−nullarySchema :: Schema
271−nullarySchema = mempty
272− & schemaType .~ SchemaArray
273− & schemaEnum ?~ [ toJSON () ]
274−
275−instance GToSchema U1 where
276− gtoNamedSchema _ _ _ = unnamed nullarySchema
277−
278−instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
279− gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g)
280−
281−instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
282− gtoNamedSchema opts _ s = (schemaName, gtoSchema opts (Proxy :: Proxy f) s)
283− where
284− schemaName = gdatatypeSchemaName opts (Proxy :: Proxy d)
285−
286−instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
287− gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f)
288−
289−-- | Single field constructor.
290−instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
291− gtoNamedSchema opts _ s
292− | unwrapUnaryRecords opts = fieldSchema
293− | otherwise =
294− case schema ^. schemaItems of
295− Just (SchemaItemsArray [_]) -> fieldSchema
296− _ -> unnamed schema
297− where
298− schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s
299− fieldSchema = gtoNamedSchema opts (Proxy :: Proxy f) s
300−
301−gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> Referenced Schema
302−gtoSchemaRef opts proxy = case gtoNamedSchema opts proxy mempty of
303− (Just name, _)
304− | useReferences opts -> Ref (Reference ("#/definitions/" <> T.pack name))
305− (_, schema) -> Inline schema
306−
307−appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
308−appendItem x Nothing = Just (SchemaItemsArray [x])
309−appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
310−appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
311−
312−withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Schema
313−withFieldSchema opts _ isRequiredField schema
314− | T.null fieldName = schema
315− & schemaType .~ SchemaArray
316− & schemaItems %~ appendItem fieldSchemaRef
317− | otherwise = schema
318− & schemaType .~ SchemaObject
319− & schemaProperties . at fieldName ?~ fieldSchemaRef
320− & if isRequiredField
321− then schemaRequired %~ (fieldName :)
322− else id
323− where
324− fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
325− fieldSchemaRef = gtoSchemaRef opts (Proxy :: Proxy f)
326−
327−-- | Optional record fields.
328−instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
329− gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
330−
331−-- | Record fields.
332−instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
333− gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
334−
335−instance ToSchema c => GToSchema (K1 i c) where
336− gtoNamedSchema _ _ _ = toNamedSchema (Proxy :: Proxy c)
337−
338−instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
339− gtoNamedSchema opts _ s
340− | allNullaryToStringTag opts && allNullary = unnamed (toStringTag sumSchema)
341− | otherwise = unnamed sumSchema
342− where
343− (All allNullary, sumSchema) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
344−
345− toStringTag schema = mempty
346− & schemaType .~ SchemaString
347− & schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex)
348−
349−type AllNullary = All
350−
351−class GSumToSchema f where
352− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> (AllNullary, Schema)
353−
354−instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
355− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <.> gsumToSchema opts (Proxy :: Proxy g)
356− where
357− (f <.> g) s = (a <> b, s'')
358− where
359− (a, s') = f s
360− (b, s'') = g s'
361−
362−gsumConToSchema :: forall c f proxy. Constructor c =>
363− Bool -> Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> (AllNullary, Schema)
364−gsumConToSchema isNullary tagSchemaRef opts _ schema = (All isNullary, schema
365− & schemaType .~ SchemaObject
366− & schemaProperties . at tag ?~ tagSchemaRef
367− & schemaMaxProperties ?~ 1
368− & schemaMinProperties ?~ 1)
369− where
370− tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
371−
372−instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
373− gsumToSchema opts = gsumConToSchema False tagSchemaRef opts
374− where
375− tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c f))
376−
377−instance Constructor c => GSumToSchema (C1 c U1) where
378− gsumToSchema opts = gsumConToSchema True tagSchemaRef opts
379− where
380− tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c U1))
381−
382−instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
383− gsumToSchema opts = gsumConToSchema False tagSchemaRef opts
384− where
385− tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c (S1 s f)))
386−
387−data Proxy2 a b = Proxy2
388−
389−data Proxy3 a b c = Proxy3
390−
src/Data/Swagger/Schema/Validation.hsnew file+90
@@ -0,0 +1,90 @@
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.hsnew file+72
@@ -0,0 +1,72 @@
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.yamldeleted−5
@@ -1,5 +0,0 @@
1−flags: {}
2−packages:
3−- '.'
4−extra-deps:
5−resolver: lts-2.22
stack-head.yamldeleted−5
@@ -1,5 +0,0 @@
1−flags: {}
2−packages:
3−- '.'
4−extra-deps:
5−resolver: nightly-2015-11-08
stack.yaml+6−2
@@ -1,5 +1,9 @@
1−flags: {}
1+resolver: lts-14.3
22packages:
33- '.'
44extra-deps:
5−resolver: lts-3.12
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
swagger2.cabal+117−29
@@ -1,66 +1,154 @@
1+cabal-version: >=1.10
12name: swagger2
2−version: 0.3
3+version: 2.5
4+
35synopsis: Swagger 2.0 data model
4−description: Please see README.md
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+
513homepage: https://github.com/GetShopTV/swagger2
614bug-reports: https://github.com/GetShopTV/swagger2/issues
715license: BSD3
816license-file: LICENSE
917author: Nickolay Kudasov
1018maintainer: nickolay@getshoptv.com
11−copyright: (c) 2015, GetShopTV
12−category: Web
13−build-type: Simple
19+copyright: (c) 2015-2016, GetShopTV
20+build-type: Custom
1421extra-source-files:
1522 README.md
1623 , CHANGELOG.md
17−cabal-version: >=1.10
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
1836
1937library
2038 hs-source-dirs: src
39+ include-dirs: include
2140 exposed-modules:
2241 Data.Swagger
42+ Data.Swagger.Declare
2343 Data.Swagger.Lens
44+ Data.Swagger.Operation
45+ Data.Swagger.Optics
46+ Data.Swagger.ParamSchema
2447 Data.Swagger.Schema
48+ Data.Swagger.Schema.Generator
49+ Data.Swagger.Schema.Validation
50+ Data.Swagger.SchemaOptions
2551
2652 -- internal modules
2753 Data.Swagger.Internal
54+ Data.Swagger.Internal.Schema
55+ Data.Swagger.Internal.Schema.Validation
56+ Data.Swagger.Internal.ParamSchema
2857 Data.Swagger.Internal.Utils
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
40− , scientific
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+
4196 default-language: Haskell2010
4297
4398test-suite spec
4499 type: exitcode-stdio-1.0
45100 hs-source-dirs: test
46101 main-is: Spec.hs
47− build-depends: base == 4.*
48− , swagger2
49− , hspec
50− , HUnit
51− , QuickCheck
52− , text
53− , aeson
54− , aeson-qq
55− , containers
56− , unordered-containers
57− , vector
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+
58134 other-modules:
59135 SpecCommon
60136 Data.SwaggerSpec
137+ Data.Swagger.CommonTestTypes
138+ Data.Swagger.ParamSchemaSpec
61139 Data.Swagger.SchemaSpec
140+ Data.Swagger.Schema.ValidationSpec
141+ Data.Swagger.Schema.GeneratorSpec
62142 default-language: Haskell2010
63143
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+
64152source-repository head
65153 type: git
66154 location: https://github.com/GetShopTV/swagger2.git
test/Data/Swagger/CommonTestTypes.hsnew file+679
@@ -0,0 +1,679 @@
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.hsnew file+40
@@ -0,0 +1,40 @@
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.hsnew file+168
@@ -0,0 +1,168 @@
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.hsnew file+278
@@ -0,0 +1,278 @@
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+70−356
@@ -1,30 +1,63 @@
11{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DeriveAnyClass #-}
32{-# LANGUAGE ScopedTypeVariables #-}
43{-# LANGUAGE TemplateHaskell #-}
54{-# LANGUAGE QuasiQuotes #-}
6−module Data.Swagger.SchemaSpec (main, spec) where
5+module Data.Swagger.SchemaSpec where
76
8−import Data.Aeson
9−import Data.Aeson.QQ
10−import Data.Char
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
1113import Data.Proxy
1214import Data.Set (Set)
13−import GHC.Generics
15+import qualified Data.Text as Text
1416
1517import Data.Swagger
16−import Data.Swagger.Schema
18+import Data.Swagger.Declare
1719
20+import Data.Swagger.CommonTestTypes
1821import SpecCommon
1922import Test.Hspec
2023
24+import qualified Data.HashMap.Strict as HM
25+import Data.Time.LocalTime
26+
2127checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
22−checkToSchema proxy js = toSchema proxy <~> js
28+checkToSchema proxy js = toSchema proxy <=> js
2329
2430checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec
25−checkSchemaName name proxy =
26− it ("schema name is " ++ show name) $
27− schemaName proxy `shouldBe` name
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
2861
2962spec :: Spec
3063spec = do
@@ -33,15 +66,21 @@ spec = do
3366 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
3467 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
3568 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
3672 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
73+ context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
3774 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
3875 context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON
3976 context "Unary records" $ do
4077 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
4178 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
4279 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
80+ context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
4381 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
4482 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83+ context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
4584 context "Sum types" $ do
4685 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
4786 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
@@ -50,351 +89,26 @@ spec = do
5089 context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)
5190 context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
5291 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
53112
54113main :: IO ()
55114main = hspec spec
56−
57−-- ========================================================================
58−-- Person (simple record with optional fields)
59−-- ========================================================================
60−data Person = Person
61− { name :: String
62− , phone :: Integer
63− , email :: Maybe String
64− } deriving (Generic, ToSchema)
65−
66−personSchemaJSON :: Value
67−personSchemaJSON = [aesonQQ|
68−{
69− "type": "object",
70− "properties":
71− {
72− "name": { "type": "string" },
73− "phone": { "type": "integer" },
74− "email": { "type": "string" }
75− },
76− "required": ["name", "phone"]
77−}
78−|]
79−
80−-- ========================================================================
81−-- ISPair (non-record product data type)
82−-- ========================================================================
83−data ISPair = ISPair Integer String
84− deriving (Generic, ToSchema)
85−
86−ispairSchemaJSON :: Value
87−ispairSchemaJSON = [aesonQQ|
88−{
89− "type": "array",
90− "items":
91− [
92− { "type": "integer" },
93− { "type": "string" }
94− ]
95−}
96−|]
97−
98−-- ========================================================================
99−-- Point (record data type with custom fieldLabelModifier)
100−-- ========================================================================
101−data Point = Point
102− { pointX :: Double
103− , pointY :: Double
104− } deriving (Generic)
105−
106−instance ToSchema Point where
107− toNamedSchema = genericToNamedSchema defaultSchemaOptions
108− { fieldLabelModifier = map toLower . drop (length "point") }
109−
110−pointSchemaJSON :: Value
111−pointSchemaJSON = [aesonQQ|
112−{
113− "type": "object",
114− "properties":
115− {
116− "x": { "type": "number" },
117− "y": { "type": "number" }
118− },
119− "required": ["x", "y"]
120−}
121−|]
122−
123−
124−-- ========================================================================
125−-- Color (enum)
126−-- ========================================================================
127−data Color
128− = Red
129− | Green
130− | Blue
131− deriving (Generic, ToSchema)
132−
133−colorSchemaJSON :: Value
134−colorSchemaJSON = [aesonQQ|
135−{
136− "type": "string",
137− "enum": ["Red", "Green", "Blue"]
138−}
139−|]
140−
141−-- ========================================================================
142−-- Paint (record with bounded enum property)
143−-- ========================================================================
144−
145−newtype Paint = Paint { color :: Color }
146− deriving (Generic, ToSchema)
147−
148−paintSchemaJSON :: Value
149−paintSchemaJSON = [aesonQQ|
150−{
151− "type": "object",
152− "properties":
153− {
154− "color":
155− {
156− "$ref": "#/definitions/Color"
157− }
158− },
159− "required": ["color"]
160−}
161−|]
162−
163−-- ========================================================================
164−-- Email (newtype with unwrapUnaryRecords set to True)
165−-- ========================================================================
166−
167−newtype Email = Email { getEmail :: String }
168− deriving (Generic)
169−
170−instance ToSchema Email where
171− toNamedSchema = genericToNamedSchema defaultSchemaOptions
172− { unwrapUnaryRecords = True }
173−
174−emailSchemaJSON :: Value
175−emailSchemaJSON = [aesonQQ|
176−{
177− "type": "string"
178−}
179−|]
180−
181−-- ========================================================================
182−-- UserId (non-record newtype)
183−-- ========================================================================
184−
185−newtype UserId = UserId Integer
186− deriving (Eq, Ord, Generic, ToSchema)
187−
188−userIdSchemaJSON :: Value
189−userIdSchemaJSON = [aesonQQ|
190−{
191− "type": "integer"
192−}
193−|]
194−
195−-- ========================================================================
196−-- UserGroup (set newtype)
197−-- ========================================================================
198−
199−newtype UserGroup = UserGroup (Set UserId)
200− deriving (Generic, ToSchema)
201−
202−userGroupSchemaJSON :: Value
203−userGroupSchemaJSON = [aesonQQ|
204−{
205− "type": "array",
206− "items": { "$ref": "#/definitions/UserId" },
207− "uniqueItems": true
208−}
209−|]
210−
211−-- ========================================================================
212−-- Player (record newtype)
213−-- ========================================================================
214−
215−newtype Player = Player
216− { position :: Point
217− } deriving (Generic, ToSchema)
218−
219−playerSchemaJSON :: Value
220−playerSchemaJSON = [aesonQQ|
221−{
222− "type": "object",
223− "properties":
224− {
225− "position":
226− {
227− "$ref": "#/definitions/Point"
228− }
229− },
230− "required": ["position"]
231−}
232−|]
233−
234−-- ========================================================================
235−-- MyRoseTree (custom datatypeNameModifier)
236−-- ========================================================================
237−
238−data MyRoseTree = MyRoseTree
239− { root :: String
240− , trees :: [MyRoseTree]
241− } deriving (Generic)
242−
243−instance ToSchema MyRoseTree where
244− toNamedSchema = genericToNamedSchema defaultSchemaOptions
245− { datatypeNameModifier = drop (length "My") }
246−
247−myRoseTreeSchemaJSON :: Value
248−myRoseTreeSchemaJSON = [aesonQQ|
249−{
250− "type": "object",
251− "properties":
252− {
253− "root": { "type": "string" },
254− "trees":
255− {
256− "type": "array",
257− "items":
258− {
259− "$ref": "#/definitions/RoseTree"
260− }
261− }
262− },
263− "required": ["root", "trees"]
264−}
265−|]
266−
267−-- ========================================================================
268−-- Inlined (newtype for inlining schemas)
269−-- ========================================================================
270−
271−newtype Inlined a = Inlined { getInlined :: a }
272−
273−instance ToSchema a => ToSchema (Inlined a) where
274− toNamedSchema _ = (Nothing, toSchema (Proxy :: Proxy a))
275−
276−newtype Players = Players [Inlined Player]
277− deriving (Generic, ToSchema)
278−
279−playersSchemaJSON :: Value
280−playersSchemaJSON = [aesonQQ|
281−{
282− "type": "array",
283− "items":
284− {
285− "type": "object",
286− "properties":
287− {
288− "position":
289− {
290− "$ref": "#/definitions/Point"
291− }
292− },
293− "required": ["position"]
294− }
295−}
296−|]
297−
298−-- ========================================================================
299−-- Status (sum type with unary constructors)
300−-- ========================================================================
301−
302−data Status
303− = StatusOk String
304− | StatusError String
305− deriving (Generic)
306−
307−instance ToSchema Status where
308− toNamedSchema = genericToNamedSchema defaultSchemaOptions
309− { constructorTagModifier = map toLower . drop (length "Status") }
310−
311−statusSchemaJSON :: Value
312−statusSchemaJSON = [aesonQQ|
313−{
314− "type": "object",
315− "properties":
316− {
317− "ok": { "type": "string" },
318− "error": { "type": "string" }
319− },
320− "maxProperties": 1,
321− "minProperties": 1
322−}
323−|]
324−
325−-- ========================================================================
326−-- Unit type
327−-- ========================================================================
328−
329−data Unit = Unit deriving (Generic, ToSchema)
330−
331−unitSchemaJSON :: Value
332−unitSchemaJSON = [aesonQQ|
333−{
334− "type": "array",
335− "enum": [[]]
336−}
337−|]
338−
339−
340−-- ========================================================================
341−-- Character (sum type with ref and record in alternative)
342−-- ========================================================================
343−
344−data Character
345− = PC Player
346− | NPC { npcName :: String, npcPosition :: Point }
347− deriving (Generic, ToSchema)
348−
349−characterSchemaJSON :: Value
350−characterSchemaJSON = [aesonQQ|
351−{
352− "type": "object",
353− "properties":
354− {
355− "PC": { "$ref": "#/definitions/Player" },
356− "NPC":
357− {
358− "type": "object",
359− "properties":
360− {
361− "npcName": { "type": "string" },
362− "npcPosition": { "$ref": "#/definitions/Point" }
363− },
364− "required": ["npcName", "npcPosition"]
365− }
366− },
367− "maxProperties": 1,
368− "minProperties": 1
369−}
370−|]
371−
372−-- ========================================================================
373−-- Light (sum type with unwrapUnaryRecords)
374−-- ========================================================================
375−
376−data Light
377− = LightFreq Double
378− | LightColor Color
379− | LightWaveLength { waveLength :: Double }
380− deriving (Generic)
381−
382−instance ToSchema Light where
383− toNamedSchema = genericToNamedSchema defaultSchemaOptions
384− { unwrapUnaryRecords = True }
385−
386−lightSchemaJSON :: Value
387−lightSchemaJSON = [aesonQQ|
388−{
389− "type": "object",
390− "properties":
391− {
392− "LightFreq": { "type": "number" },
393− "LightColor": { "$ref": "#/definitions/Color" },
394− "LightWaveLength": { "type": "number" }
395− },
396− "maxProperties": 1,
397− "minProperties": 1
398−}
399−|]
400−
test/Data/SwaggerSpec.hs+551−486
@@ -4,37 +4,49 @@
44{-# LANGUAGE QuasiQuotes #-}
55module Data.SwaggerSpec where
66
7+import Prelude ()
8+import Prelude.Compat
9+
10+import Control.Lens
11+
712import Data.Aeson
8−import Data.Aeson.QQ
9−import qualified Data.Foldable as F
13+import Data.Aeson.QQ.Simple
1014import Data.HashMap.Strict (HashMap)
11−import qualified Data.HashMap.Strict as HashMap
12−import Data.Maybe
13−import Data.Monoid
14−import qualified Data.Vector as Vector
15+import qualified Data.HashSet.InsOrd as InsOrdHS
1516import Data.Text (Text)
1617
1718import Data.Swagger
1819import SpecCommon
19−import Test.Hspec
20+import Test.Hspec hiding (example)
2021
2122spec :: Spec
2223spec = 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
2332 describe "License Object" $ licenseExample <=> licenseExampleJSON
2433 describe "Contact Object" $ contactExample <=> contactExampleJSON
2534 describe "Info Object" $ infoExample <=> infoExampleJSON
26− describe "Operation Object" $ operationExample <~> operationExampleJSON
35+ describe "Operation Object" $ operationExample <=> operationExampleJSON
2736 describe "Schema Object" $ do
28− context "Primitive Sample" $ schemaPrimitiveExample <~> schemaPrimitiveExampleJSON
29− context "Simple Model" $ schemaSimpleModelExample <~> schemaSimpleModelExampleJSON
30− context "Model with Map/Dictionary Properties" $ schemaModelDictExample <~> schemaModelDictExampleJSON
31− context "Model with Example" $ schemaWithExampleExample <~> schemaWithExampleExampleJSON
32− describe "Definitions Object" $ definitionsExample <~> definitionsExampleJSON
33− describe "Parameters Definition Object" $ parametersDefinitionExample <~> parametersDefinitionExampleJSON
34− describe "Responses Definition Object" $ responsesDefinitionExample <~> responsesDefinitionExampleJSON
35− describe "Security Definitions Object" $ securityDefinitionsExample <~> securityDefinitionsExampleJSON
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
3648 describe "Swagger Object" $ do
37− context "Todo Example" $ swaggerExample <~> swaggerExampleJSON
49+ context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
3850 context "PetStore Example" $
3951 it "decodes successfully" $ do
4052 fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: Swagger) -> True; _ -> False)
@@ -47,17 +59,13 @@ main = hspec spec
4759-- =======================================================================
4860
4961infoExample :: Info
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") }
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"
6169
6270infoExampleJSON :: Value
6371infoExampleJSON = [aesonQQ|
@@ -83,10 +91,10 @@ infoExampleJSON = [aesonQQ|
8391-- =======================================================================
8492
8593contactExample :: Contact
86−contactExample = Contact
87− { _contactName = Just "API Support"
88− , _contactUrl = Just (URL "http://www.swagger.io/support")
89− , _contactEmail = Just "support@swagger.io" }
94+contactExample = mempty
95+ & name ?~ "API Support"
96+ & url ?~ URL "http://www.swagger.io/support"
97+ & email ?~ "support@swagger.io"
9098
9199contactExampleJSON :: Value
92100contactExampleJSON = [aesonQQ|
@@ -102,9 +110,8 @@ contactExampleJSON = [aesonQQ|
102110-- =======================================================================
103111
104112licenseExample :: License
105−licenseExample = License
106− { _licenseName = "Apache 2.0"
107− , _licenseUrl = Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html") }
113+licenseExample = "Apache 2.0"
114+ & url ?~ URL "http://www.apache.org/licenses/LICENSE-2.0.html"
108115
109116licenseExampleJSON :: Value
110117licenseExampleJSON = [aesonQQ|
@@ -121,46 +128,38 @@ licenseExampleJSON = [aesonQQ|
121128
122129operationExample :: Operation
123130operationExample = mempty
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) }
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)
158153 ]
159154
160− stringSchema i = mempty
161− { _parameterOtherSchemaIn = i
162− , _parameterOtherSchemaType = ParamString
163− }
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
164163
165164operationExampleJSON :: Value
166165operationExampleJSON = [aesonQQ|
@@ -226,9 +225,8 @@ operationExampleJSON = [aesonQQ|
226225
227226schemaPrimitiveExample :: Schema
228227schemaPrimitiveExample = mempty
229− { _schemaType = SchemaString
230− , _schemaFormat = Just "email"
231− }
228+ & type_ ?~ SwaggerString
229+ & format ?~ "email"
232230
233231schemaPrimitiveExampleJSON :: Value
234232schemaPrimitiveExampleJSON = [aesonQQ|
@@ -240,17 +238,15 @@ schemaPrimitiveExampleJSON = [aesonQQ|
240238
241239schemaSimpleModelExample :: Schema
242240schemaSimpleModelExample = mempty
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 } } ) ] }
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" ) ]
254250
255251schemaSimpleModelExampleJSON :: Value
256252schemaSimpleModelExampleJSON = [aesonQQ|
@@ -277,9 +273,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
277273
278274schemaModelDictExample :: Schema
279275schemaModelDictExample = mempty
280− { _schemaType = SchemaObject
281− , _schemaAdditionalProperties = Just mempty
282− { _schemaType = SchemaString } }
276+ & type_ ?~ SwaggerObject
277+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
283278
284279schemaModelDictExampleJSON :: Value
285280schemaModelDictExampleJSON = [aesonQQ|
@@ -291,22 +286,35 @@ schemaModelDictExampleJSON = [aesonQQ|
291286}
292287|]
293288
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+
294302schemaWithExampleExample :: Schema
295303schemaWithExampleExample = mempty
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− |] }
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+ |]
310318
311319schemaWithExampleExampleJSON :: Value
312320schemaWithExampleExampleJSON = [aesonQQ|
@@ -338,21 +346,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
338346definitionsExample :: HashMap Text Schema
339347definitionsExample =
340348 [ ("Category", mempty
341− { _schemaType = SchemaObject
342− , _schemaProperties =
343− [ ("id", Inline mempty
344− { _schemaType = SchemaInteger
345− , _schemaFormat = Just "int64" })
346− , ("name", Inline mempty
347− { _schemaType = SchemaString }) ] })
349+ & type_ ?~ SwaggerObject
350+ & properties .~
351+ [ ("id", Inline $ mempty
352+ & type_ ?~ SwaggerInteger
353+ & format ?~ "int64")
354+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
348355 , ("Tag", mempty
349− { _schemaType = SchemaObject
350− , _schemaProperties =
351− [ ("id", Inline mempty
352− { _schemaType = SchemaInteger
353− , _schemaFormat = Just "int64" })
354− , ("name", Inline mempty
355− { _schemaType = SchemaString }) ] }) ]
356+ & type_ ?~ SwaggerObject
357+ & properties .~
358+ [ ("id", Inline $ mempty
359+ & type_ ?~ SwaggerInteger
360+ & format ?~ "int64")
361+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
356362
357363definitionsExampleJSON :: Value
358364definitionsExampleJSON = [aesonQQ|
@@ -388,27 +394,27 @@ definitionsExampleJSON = [aesonQQ|
388394-- Parameters Definition object
389395-- =======================================================================
390396
391−parametersDefinitionExample :: HashMap Text Parameter
392−parametersDefinitionExample =
397+paramsDefinitionExample :: HashMap Text Param
398+paramsDefinitionExample =
393399 [ ("skipParam", mempty
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" } })
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" ))
401407 , ("limitParam", mempty
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" } }) ]
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" )) ]
409415
410−parametersDefinitionExampleJSON :: Value
411−parametersDefinitionExampleJSON = [aesonQQ|
416+paramsDefinitionExampleJSON :: Value
417+paramsDefinitionExampleJSON = [aesonQQ|
412418{
413419 "skipParam": {
414420 "name": "skip",
@@ -435,8 +441,8 @@ parametersDefinitionExampleJSON = [aesonQQ|
435441
436442responsesDefinitionExample :: HashMap Text Response
437443responsesDefinitionExample =
438− [ ("NotFound", mempty { _responseDescription = "Entity not found." })
439− , ("IllegalInput", mempty { _responseDescription = "Illegal input for operation." }) ]
444+ [ ("NotFound", mempty & description .~ "Entity not found.")
445+ , ("IllegalInput", mempty & description .~ "Illegal input for operation.") ]
440446
441447responsesDefinitionExampleJSON :: Value
442448responsesDefinitionExampleJSON = [aesonQQ|
@@ -454,8 +460,8 @@ responsesDefinitionExampleJSON = [aesonQQ|
454460-- Responses Definition object
455461-- =======================================================================
456462
457−securityDefinitionsExample :: HashMap Text SecurityScheme
458−securityDefinitionsExample =
463+securityDefinitionsExample :: SecurityDefinitions
464+securityDefinitionsExample = SecurityDefinitions
459465 [ ("api_key", SecurityScheme
460466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
461467 , _securitySchemeDescription = Nothing })
@@ -487,53 +493,86 @@ securityDefinitionsExampleJSON = [aesonQQ|
487493}
488494|]
489495
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+
490536-- =======================================================================
491537-- Swagger object
492538-- =======================================================================
493539
494540swaggerExample :: Swagger
495541swaggerExample = mempty
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" ] } }) ] } }
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" ] ))
537576
538577swaggerExampleJSON :: Value
539578swaggerExampleJSON = [aesonQQ|
@@ -600,130 +639,130 @@ swaggerExampleJSON = [aesonQQ|
600639
601640petstoreExampleJSON :: Value
602641petstoreExampleJSON = [aesonQQ|
603−{
642+{
604643 "swagger":"2.0",
605− "info":{
644+ "info":{
606645 "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.",
607646 "version":"1.0.0",
608647 "title":"Swagger Petstore",
609648 "termsOfService":"http://swagger.io/terms/",
610− "contact":{
649+ "contact":{
611650 "email":"apiteam@swagger.io"
612651 },
613− "license":{
652+ "license":{
614653 "name":"Apache 2.0",
615654 "url":"http://www.apache.org/licenses/LICENSE-2.0.html"
616655 }
617656 },
618657 "host":"petstore.swagger.io",
619658 "basePath":"/v2",
620− "tags":[
621− {
659+ "tags":[
660+ {
622661 "name":"pet",
623662 "description":"Everything about your Pets",
624− "externalDocs":{
663+ "externalDocs":{
625664 "description":"Find out more",
626665 "url":"http://swagger.io"
627666 }
628667 },
629− {
668+ {
630669 "name":"store",
631670 "description":"Access to Petstore orders"
632671 },
633− {
672+ {
634673 "name":"user",
635674 "description":"Operations about user",
636− "externalDocs":{
675+ "externalDocs":{
637676 "description":"Find out more about our store",
638677 "url":"http://swagger.io"
639678 }
640679 }
641680 ],
642− "schemes":[
681+ "schemes":[
643682 "http"
644683 ],
645− "paths":{
646− "/pet":{
647− "post":{
648− "tags":[
684+ "paths":{
685+ "/pet":{
686+ "post":{
687+ "tags":[
649688 "pet"
650689 ],
651690 "summary":"Add a new pet to the store",
652691 "description":"",
653692 "operationId":"addPet",
654− "consumes":[
693+ "consumes":[
655694 "application/json",
656695 "application/xml"
657696 ],
658− "produces":[
697+ "produces":[
659698 "application/xml",
660699 "application/json"
661700 ],
662− "parameters":[
663− {
701+ "parameters":[
702+ {
664703 "in":"body",
665704 "name":"body",
666705 "description":"Pet object that needs to be added to the store",
667706 "required":true,
668− "schema":{
707+ "schema":{
669708 "$ref":"#/definitions/Pet"
670709 }
671710 }
672711 ],
673− "responses":{
674− "405":{
712+ "responses":{
713+ "405":{
675714 "description":"Invalid input"
676715 }
677716 },
678− "security":[
679− {
680− "petstore_auth":[
717+ "security":[
718+ {
719+ "petstore_auth":[
681720 "write:pets",
682721 "read:pets"
683722 ]
684723 }
685724 ]
686725 },
687− "put":{
688− "tags":[
726+ "put":{
727+ "tags":[
689728 "pet"
690729 ],
691730 "summary":"Update an existing pet",
692731 "description":"",
693732 "operationId":"updatePet",
694− "consumes":[
733+ "consumes":[
695734 "application/json",
696735 "application/xml"
697736 ],
698− "produces":[
737+ "produces":[
699738 "application/xml",
700739 "application/json"
701740 ],
702− "parameters":[
703− {
741+ "parameters":[
742+ {
704743 "in":"body",
705744 "name":"body",
706745 "description":"Pet object that needs to be added to the store",
707746 "required":true,
708− "schema":{
747+ "schema":{
709748 "$ref":"#/definitions/Pet"
710749 }
711750 }
712751 ],
713− "responses":{
714− "400":{
752+ "responses":{
753+ "400":{
715754 "description":"Invalid ID supplied"
716755 },
717− "404":{
756+ "404":{
718757 "description":"Pet not found"
719758 },
720− "405":{
759+ "405":{
721760 "description":"Validation exception"
722761 }
723762 },
724− "security":[
725− {
726− "petstore_auth":[
763+ "security":[
764+ {
765+ "petstore_auth":[
727766 "write:pets",
728767 "read:pets"
729768 ]
@@ -731,28 +770,28 @@ petstoreExampleJSON = [aesonQQ|
731770 ]
732771 }
733772 },
734− "/pet/findByStatus":{
735− "get":{
736− "tags":[
773+ "/pet/findByStatus":{
774+ "get":{
775+ "tags":[
737776 "pet"
738777 ],
739778 "summary":"Finds Pets by status",
740779 "description":"Multiple status values can be provided with comma seperated strings",
741780 "operationId":"findPetsByStatus",
742− "produces":[
781+ "produces":[
743782 "application/xml",
744783 "application/json"
745784 ],
746− "parameters":[
747− {
785+ "parameters":[
786+ {
748787 "name":"status",
749788 "in":"query",
750789 "description":"Status values that need to be considered for filter",
751790 "required":true,
752791 "type":"array",
753− "items":{
792+ "items":{
754793 "type":"string",
755− "enum":[
794+ "enum":[
756795 "available",
757796 "pending",
758797 "sold"
@@ -762,23 +801,23 @@ petstoreExampleJSON = [aesonQQ|
762801 "collectionFormat":"csv"
763802 }
764803 ],
765− "responses":{
766− "200":{
804+ "responses":{
805+ "200":{
767806 "description":"successful operation",
768− "schema":{
807+ "schema":{
769808 "type":"array",
770− "items":{
809+ "items":{
771810 "$ref":"#/definitions/Pet"
772811 }
773812 }
774813 },
775− "400":{
814+ "400":{
776815 "description":"Invalid status value"
777816 }
778817 },
779− "security":[
780− {
781− "petstore_auth":[
818+ "security":[
819+ {
820+ "petstore_auth":[
782821 "write:pets",
783822 "read:pets"
784823 ]
@@ -786,48 +825,48 @@ petstoreExampleJSON = [aesonQQ|
786825 ]
787826 }
788827 },
789− "/pet/findByTags":{
790− "get":{
791− "tags":[
828+ "/pet/findByTags":{
829+ "get":{
830+ "tags":[
792831 "pet"
793832 ],
794833 "summary":"Finds Pets by tags",
795834 "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",
796835 "operationId":"findPetsByTags",
797− "produces":[
836+ "produces":[
798837 "application/xml",
799838 "application/json"
800839 ],
801− "parameters":[
802− {
840+ "parameters":[
841+ {
803842 "name":"tags",
804843 "in":"query",
805844 "description":"Tags to filter by",
806845 "required":true,
807846 "type":"array",
808− "items":{
847+ "items":{
809848 "type":"string"
810849 },
811850 "collectionFormat":"csv"
812851 }
813852 ],
814− "responses":{
815− "200":{
853+ "responses":{
854+ "200":{
816855 "description":"successful operation",
817− "schema":{
856+ "schema":{
818857 "type":"array",
819− "items":{
858+ "items":{
820859 "$ref":"#/definitions/Pet"
821860 }
822861 }
823862 },
824− "400":{
863+ "400":{
825864 "description":"Invalid tag value"
826865 }
827866 },
828− "security":[
829− {
830− "petstore_auth":[
867+ "security":[
868+ {
869+ "petstore_auth":[
831870 "write:pets",
832871 "read:pets"
833872 ]
@@ -835,20 +874,20 @@ petstoreExampleJSON = [aesonQQ|
835874 ]
836875 }
837876 },
838− "/pet/{petId}":{
839− "get":{
840− "tags":[
877+ "/pet/{petId}":{
878+ "get":{
879+ "tags":[
841880 "pet"
842881 ],
843882 "summary":"Find pet by ID",
844883 "description":"Returns a single pet",
845884 "operationId":"getPetById",
846− "produces":[
885+ "produces":[
847886 "application/xml",
848887 "application/json"
849888 ],
850− "parameters":[
851− {
889+ "parameters":[
890+ {
852891 "name":"petId",
853892 "in":"path",
854893 "description":"ID of pet to return",
@@ -857,43 +896,42 @@ petstoreExampleJSON = [aesonQQ|
857896 "format":"int64"
858897 }
859898 ],
860− "responses":{
861− "200":{
899+ "responses":{
900+ "200":{
862901 "description":"successful operation",
863− "schema":{
902+ "schema":{
864903 "$ref":"#/definitions/Pet"
865904 }
866905 },
867− "400":{
906+ "400":{
868907 "description":"Invalid ID supplied"
869908 },
870− "404":{
909+ "404":{
871910 "description":"Pet not found"
872911 }
873912 },
874− "security":[
875− {
876− "api_key":[
877− ]
913+ "security":[
914+ {
915+ "api_key": []
878916 }
879917 ]
880918 },
881− "post":{
882− "tags":[
919+ "post":{
920+ "tags":[
883921 "pet"
884922 ],
885923 "summary":"Updates a pet in the store with form data",
886924 "description":"",
887925 "operationId":"updatePetWithForm",
888− "consumes":[
926+ "consumes":[
889927 "application/x-www-form-urlencoded"
890928 ],
891− "produces":[
929+ "produces":[
892930 "application/xml",
893931 "application/json"
894932 ],
895− "parameters":[
896− {
933+ "parameters":[
934+ {
897935 "name":"petId",
898936 "in":"path",
899937 "description":"ID of pet that needs to be updated",
@@ -901,14 +939,14 @@ petstoreExampleJSON = [aesonQQ|
901939 "type":"integer",
902940 "format":"int64"
903941 },
904− {
942+ {
905943 "name":"name",
906944 "in":"formData",
907945 "description":"Updated name of the pet",
908946 "required":false,
909947 "type":"string"
910948 },
911− {
949+ {
912950 "name":"status",
913951 "in":"formData",
914952 "description":"Updated status of the pet",
@@ -916,39 +954,39 @@ petstoreExampleJSON = [aesonQQ|
916954 "type":"string"
917955 }
918956 ],
919− "responses":{
920− "405":{
957+ "responses":{
958+ "405":{
921959 "description":"Invalid input"
922960 }
923961 },
924− "security":[
925− {
926− "petstore_auth":[
962+ "security":[
963+ {
964+ "petstore_auth":[
927965 "write:pets",
928966 "read:pets"
929967 ]
930968 }
931969 ]
932970 },
933− "delete":{
934− "tags":[
971+ "delete":{
972+ "tags":[
935973 "pet"
936974 ],
937975 "summary":"Deletes a pet",
938976 "description":"",
939977 "operationId":"deletePet",
940− "produces":[
978+ "produces":[
941979 "application/xml",
942980 "application/json"
943981 ],
944− "parameters":[
945− {
982+ "parameters":[
983+ {
946984 "name":"api_key",
947985 "in":"header",
948986 "required":false,
949987 "type":"string"
950988 },
951− {
989+ {
952990 "name":"petId",
953991 "in":"path",
954992 "description":"Pet id to delete",
@@ -957,14 +995,14 @@ petstoreExampleJSON = [aesonQQ|
957995 "format":"int64"
958996 }
959997 ],
960− "responses":{
961− "400":{
998+ "responses":{
999+ "400":{
9621000 "description":"Invalid pet value"
9631001 }
9641002 },
965− "security":[
966− {
967− "petstore_auth":[
1003+ "security":[
1004+ {
1005+ "petstore_auth":[
9681006 "write:pets",
9691007 "read:pets"
9701008 ]
@@ -972,22 +1010,22 @@ petstoreExampleJSON = [aesonQQ|
9721010 ]
9731011 }
9741012 },
975− "/pet/{petId}/uploadImage":{
976− "post":{
977− "tags":[
1013+ "/pet/{petId}/uploadImage":{
1014+ "post":{
1015+ "tags":[
9781016 "pet"
9791017 ],
9801018 "summary":"uploads an image",
9811019 "description":"",
9821020 "operationId":"uploadFile",
983− "consumes":[
1021+ "consumes":[
9841022 "multipart/form-data"
9851023 ],
986− "produces":[
1024+ "produces":[
9871025 "application/json"
9881026 ],
989− "parameters":[
990− {
1027+ "parameters":[
1028+ {
9911029 "name":"petId",
9921030 "in":"path",
9931031 "description":"ID of pet to update",
@@ -995,14 +1033,14 @@ petstoreExampleJSON = [aesonQQ|
9951033 "type":"integer",
9961034 "format":"int64"
9971035 },
998− {
1036+ {
9991037 "name":"additionalMetadata",
10001038 "in":"formData",
10011039 "description":"Additional data to pass to server",
10021040 "required":false,
10031041 "type":"string"
10041042 },
1005− {
1043+ {
10061044 "name":"file",
10071045 "in":"formData",
10081046 "description":"file to upload",
@@ -1010,17 +1048,17 @@ petstoreExampleJSON = [aesonQQ|
10101048 "type":"file"
10111049 }
10121050 ],
1013− "responses":{
1014− "200":{
1051+ "responses":{
1052+ "200":{
10151053 "description":"successful operation",
1016− "schema":{
1054+ "schema":{
10171055 "$ref":"#/definitions/ApiResponse"
10181056 }
10191057 }
10201058 },
1021− "security":[
1022− {
1023− "petstore_auth":[
1059+ "security":[
1060+ {
1061+ "petstore_auth":[
10241062 "write:pets",
10251063 "read:pets"
10261064 ]
@@ -1028,89 +1066,87 @@ petstoreExampleJSON = [aesonQQ|
10281066 ]
10291067 }
10301068 },
1031− "/store/inventory":{
1032− "get":{
1033− "tags":[
1069+ "/store/inventory":{
1070+ "get":{
1071+ "tags":[
10341072 "store"
10351073 ],
10361074 "summary":"Returns pet inventories by status",
10371075 "description":"Returns a map of status codes to quantities",
10381076 "operationId":"getInventory",
1039− "produces":[
1077+ "produces":[
10401078 "application/json"
10411079 ],
1042− "parameters":[
1043− ],
1044− "responses":{
1045− "200":{
1080+ "parameters": [],
1081+ "responses":{
1082+ "200":{
10461083 "description":"successful operation",
1047− "schema":{
1084+ "schema":{
10481085 "type":"object",
1049− "additionalProperties":{
1086+ "additionalProperties":{
10501087 "type":"integer",
10511088 "format":"int32"
10521089 }
10531090 }
10541091 }
10551092 },
1056− "security":[
1057− {
1058− "api_key":[
1059− ]
1093+ "security":[
1094+ {
1095+ "api_key": []
10601096 }
10611097 ]
10621098 }
10631099 },
1064− "/store/order":{
1065− "post":{
1066− "tags":[
1100+ "/store/order":{
1101+ "post":{
1102+ "tags":[
10671103 "store"
10681104 ],
10691105 "summary":"Place an order for a pet",
10701106 "description":"",
10711107 "operationId":"placeOrder",
1072− "produces":[
1108+ "produces":[
10731109 "application/xml",
10741110 "application/json"
10751111 ],
1076− "parameters":[
1077− {
1112+ "parameters":[
1113+ {
10781114 "in":"body",
10791115 "name":"body",
10801116 "description":"order placed for purchasing the pet",
10811117 "required":true,
1082− "schema":{
1118+ "schema":{
10831119 "$ref":"#/definitions/Order"
10841120 }
10851121 }
10861122 ],
1087− "responses":{
1088− "200":{
1123+ "responses":{
1124+ "200":{
10891125 "description":"successful operation",
1090− "schema":{
1126+ "schema":{
10911127 "$ref":"#/definitions/Order"
10921128 }
10931129 },
1094− "400":{
1130+ "400":{
10951131 "description":"Invalid Order"
10961132 }
10971133 }
10981134 }
10991135 },
1100− "/store/order/{orderId}":{
1101− "get":{
1102− "tags":[
1136+ "/store/order/{orderId}":{
1137+ "get":{
1138+ "tags":[
11031139 "store"
11041140 ],
11051141 "summary":"Find purchase order by ID",
11061142 "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",
11071143 "operationId":"getOrderById",
1108− "produces":[
1144+ "produces":[
11091145 "application/xml",
11101146 "application/json"
11111147 ],
1112− "parameters":[
1113− {
1148+ "parameters":[
1149+ {
11141150 "name":"orderId",
11151151 "in":"path",
11161152 "description":"ID of pet that needs to be fetched",
@@ -1121,34 +1157,34 @@ petstoreExampleJSON = [aesonQQ|
11211157 "format":"int64"
11221158 }
11231159 ],
1124− "responses":{
1125− "200":{
1160+ "responses":{
1161+ "200":{
11261162 "description":"successful operation",
1127− "schema":{
1163+ "schema":{
11281164 "$ref":"#/definitions/Order"
11291165 }
11301166 },
1131− "400":{
1167+ "400":{
11321168 "description":"Invalid ID supplied"
11331169 },
1134− "404":{
1170+ "404":{
11351171 "description":"Order not found"
11361172 }
11371173 }
11381174 },
1139− "delete":{
1140− "tags":[
1175+ "delete":{
1176+ "tags":[
11411177 "store"
11421178 ],
11431179 "summary":"Delete purchase order by ID",
11441180 "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",
11451181 "operationId":"deleteOrder",
1146− "produces":[
1182+ "produces":[
11471183 "application/xml",
11481184 "application/json"
11491185 ],
1150− "parameters":[
1151− {
1186+ "parameters":[
1187+ {
11521188 "name":"orderId",
11531189 "in":"path",
11541190 "description":"ID of the order that needs to be deleted",
@@ -1157,133 +1193,133 @@ petstoreExampleJSON = [aesonQQ|
11571193 "minimum":1.0
11581194 }
11591195 ],
1160− "responses":{
1161− "400":{
1196+ "responses":{
1197+ "400":{
11621198 "description":"Invalid ID supplied"
11631199 },
1164− "404":{
1200+ "404":{
11651201 "description":"Order not found"
11661202 }
11671203 }
11681204 }
11691205 },
1170− "/user":{
1171− "post":{
1172− "tags":[
1206+ "/user":{
1207+ "post":{
1208+ "tags":[
11731209 "user"
11741210 ],
11751211 "summary":"Create user",
11761212 "description":"This can only be done by the logged in user.",
11771213 "operationId":"createUser",
1178− "produces":[
1214+ "produces":[
11791215 "application/xml",
11801216 "application/json"
11811217 ],
1182− "parameters":[
1183− {
1218+ "parameters":[
1219+ {
11841220 "in":"body",
11851221 "name":"body",
11861222 "description":"Created user object",
11871223 "required":true,
1188− "schema":{
1224+ "schema":{
11891225 "$ref":"#/definitions/User"
11901226 }
11911227 }
11921228 ],
1193− "responses":{
1194− "default":{
1229+ "responses":{
1230+ "default":{
11951231 "description":"successful operation"
11961232 }
11971233 }
11981234 }
11991235 },
1200− "/user/createWithArray":{
1201− "post":{
1202− "tags":[
1236+ "/user/createWithArray":{
1237+ "post":{
1238+ "tags":[
12031239 "user"
12041240 ],
12051241 "summary":"Creates list of users with given input array",
12061242 "description":"",
12071243 "operationId":"createUsersWithArrayInput",
1208− "produces":[
1244+ "produces":[
12091245 "application/xml",
12101246 "application/json"
12111247 ],
1212− "parameters":[
1213− {
1248+ "parameters":[
1249+ {
12141250 "in":"body",
12151251 "name":"body",
12161252 "description":"List of user object",
12171253 "required":true,
1218− "schema":{
1254+ "schema":{
12191255 "type":"array",
1220− "items":{
1256+ "items":{
12211257 "$ref":"#/definitions/User"
12221258 }
12231259 }
12241260 }
12251261 ],
1226− "responses":{
1227− "default":{
1262+ "responses":{
1263+ "default":{
12281264 "description":"successful operation"
12291265 }
12301266 }
12311267 }
12321268 },
1233− "/user/createWithList":{
1234− "post":{
1235− "tags":[
1269+ "/user/createWithList":{
1270+ "post":{
1271+ "tags":[
12361272 "user"
12371273 ],
12381274 "summary":"Creates list of users with given input array",
12391275 "description":"",
12401276 "operationId":"createUsersWithListInput",
1241− "produces":[
1277+ "produces":[
12421278 "application/xml",
12431279 "application/json"
12441280 ],
1245− "parameters":[
1246− {
1281+ "parameters":[
1282+ {
12471283 "in":"body",
12481284 "name":"body",
12491285 "description":"List of user object",
12501286 "required":true,
1251− "schema":{
1287+ "schema":{
12521288 "type":"array",
1253− "items":{
1289+ "items":{
12541290 "$ref":"#/definitions/User"
12551291 }
12561292 }
12571293 }
12581294 ],
1259− "responses":{
1260− "default":{
1295+ "responses":{
1296+ "default":{
12611297 "description":"successful operation"
12621298 }
12631299 }
12641300 }
12651301 },
1266− "/user/login":{
1267− "get":{
1268− "tags":[
1302+ "/user/login":{
1303+ "get":{
1304+ "tags":[
12691305 "user"
12701306 ],
12711307 "summary":"Logs user into the system",
12721308 "description":"",
12731309 "operationId":"loginUser",
1274− "produces":[
1310+ "produces":[
12751311 "application/xml",
12761312 "application/json"
12771313 ],
1278− "parameters":[
1279− {
1314+ "parameters":[
1315+ {
12801316 "name":"username",
12811317 "in":"query",
12821318 "description":"The user name for login",
12831319 "required":true,
12841320 "type":"string"
12851321 },
1286− {
1322+ {
12871323 "name":"password",
12881324 "in":"query",
12891325 "description":"The password for login in clear text",
@@ -1291,66 +1327,65 @@ petstoreExampleJSON = [aesonQQ|
12911327 "type":"string"
12921328 }
12931329 ],
1294− "responses":{
1295− "200":{
1330+ "responses":{
1331+ "200":{
12961332 "description":"successful operation",
1297− "schema":{
1333+ "schema":{
12981334 "type":"string"
12991335 },
1300− "headers":{
1301− "X-Rate-Limit":{
1336+ "headers":{
1337+ "X-Rate-Limit":{
13021338 "type":"integer",
13031339 "format":"int32",
13041340 "description":"calls per hour allowed by the user"
13051341 },
1306− "X-Expires-After":{
1342+ "X-Expires-After":{
13071343 "type":"string",
13081344 "format":"date-time",
13091345 "description":"date in UTC when toekn expires"
13101346 }
13111347 }
13121348 },
1313− "400":{
1349+ "400":{
13141350 "description":"Invalid username/password supplied"
13151351 }
13161352 }
13171353 }
13181354 },
1319− "/user/logout":{
1320− "get":{
1321− "tags":[
1355+ "/user/logout":{
1356+ "get":{
1357+ "tags":[
13221358 "user"
13231359 ],
13241360 "summary":"Logs out current logged in user session",
13251361 "description":"",
13261362 "operationId":"logoutUser",
1327− "produces":[
1363+ "produces":[
13281364 "application/xml",
13291365 "application/json"
13301366 ],
1331− "parameters":[
1332− ],
1333− "responses":{
1334− "default":{
1367+ "parameters": [],
1368+ "responses":{
1369+ "default":{
13351370 "description":"successful operation"
13361371 }
13371372 }
13381373 }
13391374 },
1340− "/user/{username}":{
1341− "get":{
1342− "tags":[
1375+ "/user/{username}":{
1376+ "get":{
1377+ "tags":[
13431378 "user"
13441379 ],
13451380 "summary":"Get user by user name",
13461381 "description":"",
13471382 "operationId":"getUserByName",
1348− "produces":[
1383+ "produces":[
13491384 "application/xml",
13501385 "application/json"
13511386 ],
1352− "parameters":[
1353− {
1387+ "parameters":[
1388+ {
13541389 "name":"username",
13551390 "in":"path",
13561391 "description":"The name that needs to be fetched. Use user1 for testing. ",
@@ -1358,72 +1393,72 @@ petstoreExampleJSON = [aesonQQ|
13581393 "type":"string"
13591394 }
13601395 ],
1361− "responses":{
1362− "200":{
1396+ "responses":{
1397+ "200":{
13631398 "description":"successful operation",
1364− "schema":{
1399+ "schema":{
13651400 "$ref":"#/definitions/User"
13661401 }
13671402 },
1368− "400":{
1403+ "400":{
13691404 "description":"Invalid username supplied"
13701405 },
1371− "404":{
1406+ "404":{
13721407 "description":"User not found"
13731408 }
13741409 }
13751410 },
1376− "put":{
1377− "tags":[
1411+ "put":{
1412+ "tags":[
13781413 "user"
13791414 ],
13801415 "summary":"Updated user",
13811416 "description":"This can only be done by the logged in user.",
13821417 "operationId":"updateUser",
1383− "produces":[
1418+ "produces":[
13841419 "application/xml",
13851420 "application/json"
13861421 ],
1387− "parameters":[
1388− {
1422+ "parameters":[
1423+ {
13891424 "name":"username",
13901425 "in":"path",
13911426 "description":"name that need to be deleted",
13921427 "required":true,
13931428 "type":"string"
13941429 },
1395− {
1430+ {
13961431 "in":"body",
13971432 "name":"body",
13981433 "description":"Updated user object",
13991434 "required":true,
1400− "schema":{
1435+ "schema":{
14011436 "$ref":"#/definitions/User"
14021437 }
14031438 }
14041439 ],
1405− "responses":{
1406− "400":{
1440+ "responses":{
1441+ "400":{
14071442 "description":"Invalid user supplied"
14081443 },
1409− "404":{
1444+ "404":{
14101445 "description":"User not found"
14111446 }
14121447 }
14131448 },
1414− "delete":{
1415− "tags":[
1449+ "delete":{
1450+ "tags":[
14161451 "user"
14171452 ],
14181453 "summary":"Delete user",
14191454 "description":"This can only be done by the logged in user.",
14201455 "operationId":"deleteUser",
1421− "produces":[
1456+ "produces":[
14221457 "application/xml",
14231458 "application/json"
14241459 ],
1425− "parameters":[
1426− {
1460+ "parameters":[
1461+ {
14271462 "name":"username",
14281463 "in":"path",
14291464 "description":"The name that needs to be deleted",
@@ -1431,207 +1466,237 @@ petstoreExampleJSON = [aesonQQ|
14311466 "type":"string"
14321467 }
14331468 ],
1434− "responses":{
1435− "400":{
1469+ "responses":{
1470+ "400":{
14361471 "description":"Invalid username supplied"
14371472 },
1438− "404":{
1473+ "404":{
14391474 "description":"User not found"
14401475 }
14411476 }
14421477 }
14431478 }
14441479 },
1445− "securityDefinitions":{
1446− "petstore_auth":{
1480+ "securityDefinitions":{
1481+ "petstore_auth":{
14471482 "type":"oauth2",
14481483 "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",
14491484 "flow":"implicit",
1450− "scopes":{
1485+ "scopes":{
14511486 "write:pets":"modify pets in your account",
14521487 "read:pets":"read your pets"
14531488 }
14541489 },
1455− "api_key":{
1490+ "api_key":{
14561491 "type":"apiKey",
14571492 "name":"api_key",
14581493 "in":"header"
14591494 }
14601495 },
1461− "definitions":{
1462− "Order":{
1496+ "definitions":{
1497+ "Order":{
14631498 "type":"object",
1464− "properties":{
1465− "id":{
1499+ "properties":{
1500+ "id":{
14661501 "type":"integer",
14671502 "format":"int64"
14681503 },
1469− "petId":{
1504+ "petId":{
14701505 "type":"integer",
14711506 "format":"int64"
14721507 },
1473− "quantity":{
1508+ "quantity":{
14741509 "type":"integer",
14751510 "format":"int32"
14761511 },
1477− "shipDate":{
1512+ "shipDate":{
14781513 "type":"string",
14791514 "format":"date-time"
14801515 },
1481− "status":{
1516+ "status":{
14821517 "type":"string",
14831518 "description":"Order Status",
1484− "enum":[
1519+ "enum":[
14851520 "placed",
14861521 "approved",
14871522 "delivered"
14881523 ]
14891524 },
1490− "complete":{
1525+ "complete":{
14911526 "type":"boolean",
14921527 "default":false
14931528 }
14941529 },
1495− "xml":{
1530+ "xml":{
14961531 "name":"Order"
14971532 }
14981533 },
1499− "Category":{
1534+ "Category":{
15001535 "type":"object",
1501− "properties":{
1502− "id":{
1536+ "properties":{
1537+ "id":{
15031538 "type":"integer",
15041539 "format":"int64"
15051540 },
1506− "name":{
1541+ "name":{
15071542 "type":"string"
15081543 }
15091544 },
1510− "xml":{
1545+ "xml":{
15111546 "name":"Category"
15121547 }
15131548 },
1514− "User":{
1549+ "User":{
15151550 "type":"object",
1516− "properties":{
1517− "id":{
1551+ "properties":{
1552+ "id":{
15181553 "type":"integer",
15191554 "format":"int64"
15201555 },
1521− "username":{
1556+ "username":{
15221557 "type":"string"
15231558 },
1524− "firstName":{
1559+ "firstName":{
15251560 "type":"string"
15261561 },
1527− "lastName":{
1562+ "lastName":{
15281563 "type":"string"
15291564 },
1530− "email":{
1565+ "email":{
15311566 "type":"string"
15321567 },
1533− "password":{
1568+ "password":{
15341569 "type":"string"
15351570 },
1536− "phone":{
1571+ "phone":{
15371572 "type":"string"
15381573 },
1539− "userStatus":{
1574+ "userStatus":{
15401575 "type":"integer",
15411576 "format":"int32",
15421577 "description":"User Status"
15431578 }
15441579 },
1545− "xml":{
1580+ "xml":{
15461581 "name":"User"
15471582 }
15481583 },
1549− "Tag":{
1584+ "Tag":{
15501585 "type":"object",
1551− "properties":{
1552− "id":{
1586+ "properties":{
1587+ "id":{
15531588 "type":"integer",
15541589 "format":"int64"
15551590 },
1556− "name":{
1591+ "name":{
15571592 "type":"string"
15581593 }
15591594 },
1560− "xml":{
1595+ "xml":{
15611596 "name":"Tag"
15621597 }
15631598 },
1564− "Pet":{
1599+ "Pet":{
15651600 "type":"object",
1566− "required":[
1601+ "required":[
15671602 "name",
15681603 "photoUrls"
15691604 ],
1570− "properties":{
1571− "id":{
1605+ "properties":{
1606+ "id":{
15721607 "type":"integer",
15731608 "format":"int64"
15741609 },
1575− "category":{
1610+ "category":{
15761611 "$ref":"#/definitions/Category"
15771612 },
1578− "name":{
1613+ "name":{
15791614 "type":"string",
15801615 "example":"doggie"
15811616 },
1582− "photoUrls":{
1617+ "photoUrls":{
15831618 "type":"array",
1584− "xml":{
1619+ "xml":{
15851620 "name":"photoUrl",
15861621 "wrapped":true
15871622 },
1588− "items":{
1623+ "items":{
15891624 "type":"string"
15901625 }
15911626 },
1592− "tags":{
1627+ "tags":{
15931628 "type":"array",
1594− "xml":{
1629+ "xml":{
15951630 "name":"tag",
15961631 "wrapped":true
15971632 },
1598− "items":{
1633+ "items":{
15991634 "$ref":"#/definitions/Tag"
16001635 }
16011636 },
1602− "status":{
1637+ "status":{
16031638 "type":"string",
16041639 "description":"pet status in the store",
1605− "enum":[
1640+ "enum":[
16061641 "available",
16071642 "pending",
16081643 "sold"
16091644 ]
16101645 }
16111646 },
1612− "xml":{
1647+ "xml":{
16131648 "name":"Pet"
16141649 }
16151650 },
1616− "ApiResponse":{
1651+ "ApiResponse":{
16171652 "type":"object",
1618− "properties":{
1619− "code":{
1653+ "properties":{
1654+ "code":{
16201655 "type":"integer",
16211656 "format":"int32"
16221657 },
1623− "type":{
1658+ "type":{
16241659 "type":"string"
16251660 },
1626− "message":{
1661+ "message":{
16271662 "type":"string"
16281663 }
16291664 }
16301665 }
16311666 },
1632− "externalDocs":{
1667+ "externalDocs":{
16331668 "description":"Find out more about Swagger",
16341669 "url":"http://swagger.io"
16351670 }
16361671}
16371672|]
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+10−19
@@ -1,16 +1,10 @@
11module SpecCommon where
22
33import Data.Aeson
4−import Data.Aeson.QQ
4+import Data.ByteString.Builder (toLazyByteString)
55import qualified Data.Foldable as F
6−import Data.HashMap.Strict (HashMap)
76import qualified Data.HashMap.Strict as HashMap
8−import Data.Maybe
9−import Data.Monoid
107import qualified Data.Vector as Vector
11−import Data.Text (Text)
12−
13−import Data.Swagger
148
159import Test.Hspec
1610
@@ -22,18 +16,15 @@ isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i
2216isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys)
2317isSubJSON x y = x == y
2418
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−
3219(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec
33−x <=> json = do
20+x <=> js = do
3421 it "encodes correctly" $ do
35− toJSON x `shouldBe` json
22+ toJSON x `shouldBe` js
3623 it "decodes correctly" $ do
37− fromJSON json `shouldBe` Success x
38−
39−
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
test/doctests.hsnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Build_doctests (flags, pkgs, module_sources)
4+import Data.Foldable (traverse_)
5+import Test.DocTest
6+
7+main :: IO ()
8+main = do
9+ traverse_ putStrLn args
10+ doctest args
11+ where
12+ args = flags ++ pkgs ++ module_sources